Merge pull request #281 from ziman/fix-cast-double-int

Fix cast to integral types

src/Compiler/Scheme/Common.idr

@@ -137,12 +137,12 @@ schOp (Cast DoubleType StringType) [x] = op "number->string" [x]
 schOp (Cast CharType StringType) [x] = op "string" [x]
 
 schOp (Cast IntType IntegerType) [x] = x
-schOp (Cast DoubleType IntegerType) [x] = op "floor" [x]
+schOp (Cast DoubleType IntegerType) [x] = op "exact-floor" [x]
 schOp (Cast CharType IntegerType) [x] = op "char->integer" [x]
 schOp (Cast StringType IntegerType) [x] = op "cast-string-int" [x]
 
 schOp (Cast IntegerType IntType) [x] = x
-schOp (Cast DoubleType IntType) [x] = op "floor" [x]
+schOp (Cast DoubleType IntType) [x] = op "exact-floor" [x]
 schOp (Cast StringType IntType) [x] = op "cast-string-int" [x]
 schOp (Cast CharType IntType) [x] = op "char->integer" [x]
 

support/chez/support.ss

@@ -6,7 +6,7 @@
 (define b+ (lambda (x y bits) (remainder (+ x y) (expt 2 bits))))
 (define b- (lambda (x y bits) (remainder (- x y) (expt 2 bits))))
 (define b* (lambda (x y bits) (remainder (* x y) (expt 2 bits))))
-(define b/ (lambda (x y bits) (remainder (floor (/ x y)) (expt 2 bits))))
+(define b/ (lambda (x y bits) (remainder (exact-floor (/ x y)) (expt 2 bits))))
 
 (define blodwen-shl (lambda (x y) (ash x y)))
 (define blodwen-shr (lambda (x y) (ash x (- y))))
@@ -26,6 +26,9 @@
 (define cast-string-int
   (lambda (x)
     (floor (cast-num (string->number (destroy-prefix x))))))
+(define exact-floor
+  (lambda (x)
+    (inexact->exact (floor x))))
 (define cast-string-double
   (lambda (x)
     (cast-num (string->number (destroy-prefix x)))))

support/chicken/support.scm

@@ -6,7 +6,7 @@
 (define b+ (lambda (x y bits) (remainder (+ x y) (expt 2 bits))))
 (define b- (lambda (x y bits) (remainder (- x y) (expt 2 bits))))
 (define b* (lambda (x y bits) (remainder (* x y) (expt 2 bits))))
-(define b/ (lambda (x y bits) (remainder (/ x y) (expt 2 bits))))
+(define b/ (lambda (x y bits) (remainder (exact-floor (/ x y)) (expt 2 bits))))
 
 (define blodwen-shl (lambda (x y) (arithmetic-shift x y)))
 (define blodwen-shr (lambda (x y) (arithmetic-shift x (- y))))
@@ -26,6 +26,9 @@
 (define cast-string-int
   (lambda (x)
     (floor (cast-num (string->number (destroy-prefix x))))))
+(define exact-floor
+  (lambda (x)
+    (inexact->exact (floor x))))
 (define cast-string-double
   (lambda (x)
     (cast-num (string->number (destroy-prefix x)))))

support/racket/support.rkt

@@ -6,7 +6,7 @@
 (define b+ (lambda (x y bits) (remainder (+ x y) (expt 2 bits))))
 (define b- (lambda (x y bits) (remainder (- x y) (expt 2 bits))))
 (define b* (lambda (x y bits) (remainder (* x y) (expt 2 bits))))
-(define b/ (lambda (x y bits) (remainder (/ x y) (expt 2 bits))))
+(define b/ (lambda (x y bits) (remainder (exact-floor (/ x y)) (expt 2 bits))))
 
 (define blodwen-shl (lambda (x y) (arithmetic-shift x y)))
 (define blodwen-shr (lambda (x y) (arithmetic-shift x (- y))))

tests/Main.idr

@@ -81,7 +81,7 @@ idrisTests
        -- Miscellaneous regressions
        "reg001", "reg002", "reg003", "reg004", "reg005", "reg006", "reg007",
        "reg008", "reg009", "reg010", "reg011", "reg012", "reg013", "reg014",
-       "reg015",
+       "reg015", "reg016",
        -- Totality checking
        "total001", "total002", "total003", "total004", "total005",
        "total006",

tests/idris2/reg016/expected

@@ -0,0 +1,10 @@
+3
+4.2
+"1.2"
+4
+1
+"2.7"
+5.9
+2
+2
+2

tests/idris2/reg016/numbers.idr

@@ -0,0 +1,21 @@
+-- the commented-out cases are still wrong,
+-- but fixing them as well would make other tests fail for mysterious reasons
+-- see https://github.com/edwinb/Idris2/pull/281
+main : IO ()
+main = do
+  printLn $ 3
+  printLn $ 4.2
+  printLn $ "1.2"
+
+  printLn $ cast {to = Int} 4.8
+  printLn $ cast {to = Integer} 1.2
+  printLn $ cast {to = String} 2.7
+
+  -- printLn $ cast {to = Int} "1.2"
+  -- printLn $ cast {to = Integer} "2.7"
+  printLn $ cast {to = Double} "5.9"
+
+  printLn $ (the Int 6 `div` the Int 3)
+  printLn $ (the Integer 6 `div` the Integer 3)
+  printLn $ (cast {to = Int} "6.6" `div` cast "3.9")
+  -- printLn $ (cast {to = Integer} "6.6" `div` cast "3.9")

tests/idris2/reg016/run

@@ -0,0 +1,3 @@
+$1 numbers.idr -x main
+
+rm -rf build