From 8e9f7bfd90bf47936865c57449a8eed8cc924716 Mon Sep 17 00:00:00 2001 From: jacereda Date: Mon, 23 Nov 2020 06:28:30 +0100 Subject: [PATCH] Split integer/floating point number representation. (#1006) --- src/Commands.hs | 151 +++++++++++++++--------------------------------- src/Emit.hs | 6 +- src/Eval.hs | 4 +- src/Obj.hs | 44 +++++++++++++- src/Parsing.hs | 12 ++-- 5 files changed, 101 insertions(+), 116 deletions(-) diff --git a/src/Commands.hs b/src/Commands.hs index 8b992df8..ce6c1244 100644 --- a/src/Commands.hs +++ b/src/Commands.hs @@ -53,6 +53,9 @@ trueXObj = XObj (Bol True) Nothing Nothing falseXObj :: XObj falseXObj = XObj (Bol False) Nothing Nothing +boolToXObj :: Bool -> XObj +boolToXObj b = if b then trueXObj else falseXObj + -- | Use this function to register commands in the environment. addCommand :: SymPath -> Int -> CommandCallback -> String -> String -> (String, Binder) addCommand name arity callback doc example = addCommandConfigurable name (Just arity) callback doc example @@ -545,13 +548,13 @@ commandList ctx args = commandLength :: CommandCallback commandLength ctx [x] = - case x of + pure $ case x of XObj (Lst lst) _ _ -> - return (ctx, (Right (XObj (Num IntTy (fromIntegral (length lst))) Nothing Nothing))) + (ctx, (Right (XObj (Num IntTy (Integral (length lst))) Nothing Nothing))) XObj (Arr arr) _ _ -> - return (ctx, (Right (XObj (Num IntTy (fromIntegral (length arr))) Nothing Nothing))) + (ctx, (Right (XObj (Num IntTy (Integral (length arr))) Nothing Nothing))) _ -> - return (evalError ctx ("Applying 'length' to non-list: " ++ pretty x) (info x)) + (evalError ctx ("Applying 'length' to non-list: " ++ pretty x) (info x)) commandCar :: CommandCallback commandCar ctx [x] = @@ -631,18 +634,11 @@ commandMacroLog ctx msgs = do commandEq :: CommandCallback commandEq ctx [a, b] = - return $ case cmp (a, b) of + pure $ case cmp (a, b) of Left (a, b) -> evalError ctx ("Can't compare " ++ pretty a ++ " with " ++ pretty b) (info a) - Right True -> (ctx, Right trueXObj) - Right False -> (ctx, Right falseXObj) + Right b -> (ctx, Right (boolToXObj b)) where - cmp (XObj (Num IntTy aNum) _ _, XObj (Num IntTy bNum) _ _) = - Right $ (round aNum :: Int) == (round bNum :: Int) - cmp (XObj (Num LongTy aNum) _ _, XObj (Num LongTy bNum) _ _) = - Right $ (round aNum :: Int) == (round bNum :: Int) - cmp (XObj (Num FloatTy aNum) _ _, XObj (Num floatTy bNum) _ _) = - Right $ aNum == bNum - cmp (XObj (Num DoubleTy aNum) _ _, XObj (Num DoubleTy bNum) _ _) = + cmp (XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _) | aTy == bTy = Right $ aNum == bNum cmp (XObj (Str sa) _ _, XObj (Str sb) _ _) = Right $ sa == sb cmp (XObj (Chr ca) _ _, XObj (Chr cb) _ _) = Right $ ca == cb @@ -679,70 +675,46 @@ commandEq ctx [a, b] = cmp' _ (Right False) = Right False cmp' elem (Right True) = cmp elem +commandComp :: (Number -> Number -> Bool) -> String -> CommandCallback +commandComp op opname ctx [XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _] | aTy == bTy = pure $ (ctx, Right (boolToXObj (op aNum bNum))) +commandComp _ opname ctx [a, b] = pure $ evalError ctx ("Can't compare (" ++ opname ++ ") " ++ pretty a ++ " with " ++ pretty b) (info a) + + commandLt :: CommandCallback -commandLt ctx [a, b] = - return $ case (a, b) of - (XObj (Num IntTy aNum) _ _, XObj (Num IntTy bNum) _ _) -> - if (round aNum :: Int) < (round bNum :: Int) - then (ctx, Right trueXObj) else (ctx, Right falseXObj) - (XObj (Num LongTy aNum) _ _, XObj (Num LongTy bNum) _ _) -> - if (round aNum :: Int) < (round bNum :: Int) - then (ctx, Right trueXObj) else (ctx, Right falseXObj) - (XObj (Num FloatTy aNum) _ _, XObj (Num floatTy bNum) _ _) -> - if aNum < bNum - then (ctx, Right trueXObj) else (ctx, Right falseXObj) - (XObj (Num DoubleTy aNum) _ _, XObj (Num DoubleTy bNum) _ _) -> - if aNum < bNum - then (ctx, Right trueXObj) else (ctx, Right falseXObj) - _ -> evalError ctx ("Can't compare (<) " ++ pretty a ++ " with " ++ pretty b) (info a) +commandLt = commandComp (<) "<" commandGt :: CommandCallback -commandGt ctx [a, b] = - return $ case (a, b) of - (XObj (Num IntTy aNum) _ _, XObj (Num IntTy bNum) _ _) -> - if (round aNum :: Int) > (round bNum :: Int) - then (ctx, Right trueXObj) else (ctx, Right falseXObj) - (XObj (Num LongTy aNum) _ _, XObj (Num LongTy bNum) _ _) -> - if (round aNum :: Int) > (round bNum :: Int) - then (ctx, Right trueXObj) else (ctx, Right falseXObj) - (XObj (Num FloatTy aNum) _ _, XObj (Num floatTy bNum) _ _) -> - if aNum > bNum - then (ctx, Right trueXObj) else (ctx, Right falseXObj) - (XObj (Num DoubleTy aNum) _ _, XObj (Num DoubleTy bNum) _ _) -> - if aNum > bNum - then (ctx, Right trueXObj) else (ctx, Right falseXObj) - _ -> evalError ctx ("Can't compare (>) " ++ pretty a ++ " with " ++ pretty b) (info a) +commandGt = commandComp (>) ">" commandCharAt :: CommandCallback commandCharAt ctx [a, b] = - return $ case (a, b) of - (XObj (Str s) _ _, XObj (Num IntTy n) _ _) -> - let i = (round n :: Int) - in if length s > i - then (ctx, Right (XObj (Chr (s !! i)) (Just dummyInfo) (Just IntTy))) - else evalError ctx ("Can't call char-at with " ++ pretty a ++ " and " ++ show i ++ ", index too large") (info a) + pure $ case (a, b) of + (XObj (Str s) _ _, XObj (Num IntTy (Integral i)) _ _) -> + if length s > i + then (ctx, Right (XObj (Chr (s !! i)) (Just dummyInfo) (Just IntTy))) + else evalError ctx ("Can't call char-at with " ++ pretty a ++ " and " ++ show i ++ ", index too large") (info a) _ -> evalError ctx ("Can't call char-at with " ++ pretty a ++ " and " ++ pretty b) (info a) commandIndexOf :: CommandCallback commandIndexOf ctx [a, b] = - return $ case (a, b) of + pure $ case (a, b) of (XObj (Str s) _ _, XObj (Chr c) _ _) -> - (ctx, Right (XObj (Num IntTy (getIdx c s)) (Just dummyInfo) (Just IntTy))) + (ctx, Right (XObj (Num IntTy (Integral (getIdx c s))) (Just dummyInfo) (Just IntTy))) _ -> evalError ctx ("Can't call index-of with " ++ pretty a ++ " and " ++ pretty b) (info a) - where getIdx c s = fromIntegral $ fromMaybe (-1) $ elemIndex c s + where getIdx c s = fromMaybe (-1) $ elemIndex c s commandSubstring :: CommandCallback commandSubstring ctx [a, b, c] = - return $ case (a, b, c) of - (XObj (Str s) _ _, XObj (Num IntTy f) _ _, XObj (Num IntTy t) _ _) -> - (ctx, Right (XObj (Str (take (round t :: Int) (drop (round f :: Int) s))) (Just dummyInfo) (Just StringTy))) + pure $ case (a, b, c) of + (XObj (Str s) _ _, XObj (Num IntTy (Integral f)) _ _, XObj (Num IntTy (Integral t)) _ _) -> + (ctx, Right (XObj (Str (take t (drop f s))) (Just dummyInfo) (Just StringTy))) _ -> evalError ctx ("Can't call substring with " ++ pretty a ++ ", " ++ pretty b ++ " and " ++ pretty c) (info a) commandStringLength :: CommandCallback commandStringLength ctx [a] = - return $ case a of + pure $ case a of XObj (Str s) _ _ -> - (ctx, Right (XObj (Num IntTy (fromIntegral (length s))) (Just dummyInfo) (Just IntTy))) + (ctx, Right (XObj (Num IntTy (Integral (length s))) (Just dummyInfo) (Just IntTy))) _ -> evalError ctx ("Can't call length with " ++ pretty a) (info a) commandStringConcat :: CommandCallback @@ -783,8 +755,7 @@ commandSymFrom ctx [x@(XObj (Sym _ _) _ _)] = return (ctx, Right x) commandSymFrom ctx [XObj (Str s) i t] = return (ctx, Right $ XObj (sFrom_ s) i t) commandSymFrom ctx [XObj (Pattern s) i t] = return (ctx, Right $ XObj (sFrom_ s) i t) commandSymFrom ctx [XObj (Chr c) i t] = return (ctx, Right $ XObj (sFrom_ (show c)) i t) -commandSymFrom ctx [XObj n@(Num _ _) i t] = - return (ctx, Right $ XObj (sFrom_ (simpleFromNum n)) i t) +commandSymFrom ctx [XObj n@(Num _ v) i t] = pure (ctx, Right $ XObj (sFrom_ (show v)) i t) commandSymFrom ctx [XObj (Bol b) i t] = return (ctx, Right $ XObj (sFrom_ (show b)) i t) commandSymFrom ctx [x] = return $ evalError ctx ("Can’t call `from` with " ++ pretty x) (info x) @@ -797,10 +768,6 @@ commandSymStr ctx [x] = sFrom_ s = Sym (SymPath [] s) (LookupGlobal CarpLand AVariable) -simpleFromNum (Num IntTy num) = show (round num :: Int) -simpleFromNum (Num LongTy num) = show (round num :: Int) -simpleFromNum (Num _ num) = show num - commandPathDirectory :: CommandCallback commandPathDirectory ctx [a] = return $ case a of @@ -816,43 +783,25 @@ commandPathAbsolute ctx [a] = pure $ (ctx, Right (XObj (Str abs) (Just dummyInfo) (Just StringTy))) _ -> pure $ evalError ctx ("Can't call `absolute` with " ++ pretty a) (info a) + +commandArith :: (Number -> Number -> Number) -> String -> CommandCallback +commandArith op opname ctx [XObj (Num aTy aNum) _ _, XObj (Num bTy bNum) _ _] | aTy == bTy = + pure $ (ctx, Right (XObj (Num aTy (op aNum bNum)) (Just dummyInfo) (Just aTy))) +commandArith _ opname ctx [a, b] = pure $ evalError ctx ("Can't call " ++ opname ++ " with " ++ pretty a ++ " and " ++ pretty b) (info a) + commandPlus :: CommandCallback -commandPlus ctx [a, b] = - return $ case (a, b) of - (XObj (Num aty aNum) _ _, XObj (Num bty bNum) _ _) -> - if aty == bty - then (ctx, Right (XObj (Num aty (aNum + bNum)) (Just dummyInfo) (Just aty))) - else evalError ctx ("Can't call + with " ++ pretty a ++ " and " ++ pretty b) (info a) - _ -> evalError ctx ("Can't call + with " ++ pretty a ++ " and " ++ pretty b) (info a) +commandPlus = commandArith (+) "+" commandMinus :: CommandCallback -commandMinus ctx [a, b] = - return $ case (a, b) of - (XObj (Num aty aNum) _ _, XObj (Num bty bNum) _ _) -> - if aty == bty - then (ctx, Right (XObj (Num aty (aNum - bNum)) (Just dummyInfo) (Just aty))) - else evalError ctx ("Can't call - with " ++ pretty a ++ " and " ++ pretty b) (info a) - _ -> evalError ctx ("Can't call - with " ++ pretty a ++ " and " ++ pretty b) (info a) +commandMinus = commandArith (-) "-" commandDiv :: CommandCallback -commandDiv ctx [a, b] = - return $ case (a, b) of - (XObj (Num IntTy aNum) _ _, XObj (Num IntTy bNum) _ _) -> - (ctx, Right (XObj (Num IntTy (fromIntegral (quot (round aNum ::Int) (round bNum :: Int)))) (Just dummyInfo) (Just IntTy))) - (XObj (Num aty aNum) _ _, XObj (Num bty bNum) _ _) -> - if aty == bty - then (ctx, Right (XObj (Num aty (aNum / bNum)) (Just dummyInfo) (Just aty))) - else evalError ctx ("Can't call / with " ++ pretty a ++ " and " ++ pretty b) (info a) - _ -> evalError ctx ("Can't call / with " ++ pretty a ++ " and " ++ pretty b) (info a) +commandDiv ctx p@[XObj (Num _ (Integral _)) _ _, XObj (Num _ (Integral _)) _ _] = commandArith div "/" ctx p +commandDiv ctx p@[XObj (Num _ (Floating _)) _ _, XObj (Num _ (Floating _)) _ _] = commandArith (/) "/" ctx p +commandDiv ctx p = commandArith (error "div") "/" ctx p commandMul :: CommandCallback -commandMul ctx [a, b] = - return $ case (a, b) of - (XObj (Num aty aNum) _ _, XObj (Num bty bNum) _ _) -> - if aty == bty - then (ctx, Right (XObj (Num aty (aNum * bNum)) (Just dummyInfo) (Just aty))) - else evalError ctx ("Can't call * with " ++ pretty a ++ " and " ++ pretty b) (info a) - _ -> evalError ctx ("Can't call * with " ++ pretty a ++ " and " ++ pretty b) (info a) +commandMul = commandArith (*) "*" commandStr :: CommandCallback commandStr ctx xs = @@ -867,13 +816,9 @@ commandStr ctx xs = commandNot :: CommandCallback commandNot ctx [x] = - case x of - XObj (Bol ab) _ _ -> - if ab - then return (ctx, Right falseXObj) - else return (ctx, Right trueXObj) - _ -> - return (evalError ctx ("Can't perform logical operation (not) on " ++ pretty x) (info x)) + pure $ case x of + XObj (Bol ab) _ _ -> (ctx, Right (boolToXObj (not ab))) + _ -> evalError ctx ("Can't perform logical operation (not) on " ++ pretty x) (info x) commandReadFile :: CommandCallback commandReadFile ctx [filename] = @@ -906,8 +851,8 @@ commandWriteFile ctx [filename, contents] = commandHostBitWidth :: CommandCallback commandHostBitWidth ctx [] = - let bitSize = fromIntegral (finiteBitSize (undefined :: Int)) - in return (ctx, Right (XObj (Num IntTy bitSize) (Just dummyInfo) (Just IntTy))) + let bitSize = Integral (finiteBitSize (undefined :: Int)) + in pure (ctx, Right (XObj (Num IntTy bitSize) (Just dummyInfo) (Just IntTy))) commandSaveDocsInternal :: CommandCallback commandSaveDocsInternal ctx [modulePath] = do diff --git a/src/Emit.hs b/src/Emit.hs index 7449c4bb..c448dc6d 100644 --- a/src/Emit.hs +++ b/src/Emit.hs @@ -102,9 +102,9 @@ toC toCMode (Binder meta root) = emitterSrc (execState (visit startingIndent roo Lst _ -> visitList indent xobj Arr _ -> visitArray indent xobj StaticArr _ -> visitStaticArray indent xobj - Num IntTy num -> return (show (round num :: Int)) - Num LongTy num -> return (show (round num :: Int) ++ "l") - Num ByteTy num -> return (show (round num :: Int)) + Num IntTy num -> return (show num) + Num LongTy num -> return (show num ++ "l") + Num ByteTy num -> return (show num) Num FloatTy num -> return (show num ++ "f") Num DoubleTy num -> return (show num) Num _ _ -> error "Can't emit invalid number type." diff --git a/src/Eval.hs b/src/Eval.hs index c1ee8912..e6675be6 100644 --- a/src/Eval.hs +++ b/src/Eval.hs @@ -990,7 +990,7 @@ primitiveAnd _ ctx [a, b] = do case evaledB of Left e -> return (newCtx, Left e) Right (XObj (Bol bb) _ _) -> - return (newCtx', if bb then Right trueXObj else Right falseXObj) + return (newCtx', Right (boolToXObj bb)) Right b -> return (evalError ctx ("Can’t call `or` on " ++ pretty b) (info b)) else return (newCtx, Right falseXObj) Right a -> return (evalError ctx ("Can’t call `or` on " ++ pretty a) (info a)) @@ -1008,6 +1008,6 @@ primitiveOr _ ctx [a, b] = do case evaledB of Left e -> return (newCtx, Left e) Right (XObj (Bol bb) _ _) -> - return (newCtx', if bb then Right trueXObj else Right falseXObj) + return (newCtx', Right (boolToXObj bb)) Right b -> return (evalError ctx ("Can’t call `or` on " ++ pretty b) (info b)) Right a -> return (evalError ctx ("Can’t call `or` on " ++ pretty a) (info a)) diff --git a/src/Obj.hs b/src/Obj.hs index efb81b0d..937450ba 100644 --- a/src/Obj.hs +++ b/src/Obj.hs @@ -48,11 +48,51 @@ isLookupLocal _ = False data MatchMode = MatchValue | MatchRef deriving (Eq, Show) +data Number = Floating Double | Integral Int deriving (Eq, Ord) + +instance Num Number where + (Floating a) + (Floating b) = Floating (a + b) + (Integral a) + (Integral b) = Integral (a + b) + _ + _ = error "+" + (Floating a) * (Floating b) = Floating (a * b) + (Integral a) * (Integral b) = Integral (a * b) + _ * _ = error "*" + negate (Floating a) = Floating (negate a) + negate (Integral a) = Integral (negate a) + abs (Floating a) = Floating (abs a) + abs (Integral a) = Integral (abs a) + signum (Floating a) = Floating (signum a) + signum (Integral a) = Integral (signum a) + fromInteger a = Integral (fromInteger a) + + +instance Real Number where + toRational (Integral a) = toRational a + toRational (Floating a) = toRational a + +instance Enum Number where + toEnum a = Integral (toEnum a) + fromEnum (Integral a) = fromEnum a + +instance Fractional Number where + fromRational a = Floating (fromRational a) + recip (Floating a) = Floating (recip a) + +instance Integral Number where + quotRem (Integral a) (Integral b) = let (q,r) = quotRem a b in (Integral q, Integral r) + quotRem _ _ = error "quotRem" + toInteger (Integral a) = toInteger a + toInteger _ = error "toInteger" + +instance Show Number where + show (Floating a) = show a + show (Integral a) = show a + -- | The canonical Lisp object. data Obj = Sym SymPath SymbolMode | MultiSym String [SymPath] -- refering to multiple functions with the same name | InterfaceSym String -- refering to an interface. TODO: rename to InterfaceLookupSym? - | Num Ty Double + | Num Ty Number | Str String | Pattern String | Chr Char @@ -270,7 +310,7 @@ pretty = visit 0 Arr arr -> "[" ++ joinWithSpace (map (visit indent) arr) ++ "]" StaticArr arr -> "$[" ++ joinWithSpace (map (visit indent) arr) ++ "]" Dict dict -> "{" ++ joinWithSpace (map (visit indent) (concatMap (\(a, b) -> [a, b]) (Map.toList dict))) ++ "}" - Num IntTy num -> show (round num :: Int) + Num IntTy num -> show num Num LongTy num -> show num ++ "l" Num ByteTy num -> show num ++ "b" Num FloatTy num -> show num ++ "f" diff --git a/src/Parsing.hs b/src/Parsing.hs index 4b0ac3c6..72df925b 100644 --- a/src/Parsing.hs +++ b/src/Parsing.hs @@ -63,7 +63,7 @@ double = do (i, num) <- maybeSigned incColumn 1 decimals <- Parsec.many1 Parsec.digit incColumn (length decimals) - return (XObj (Num DoubleTy (read (num ++ "." ++ decimals))) i Nothing) + pure (XObj (Num DoubleTy (Floating (read (num ++ "." ++ decimals)))) i Nothing) float :: Parsec.Parsec String ParseState XObj float = do (i, num) <- maybeSigned @@ -73,30 +73,30 @@ float = do (i, num) <- maybeSigned incColumn (length decimals) _ <- Parsec.char 'f' incColumn 1 - return (XObj (Num FloatTy (read (num ++ "." ++ decimals))) i Nothing) + pure (XObj (Num FloatTy (Floating (read (num ++ "." ++ decimals)))) i Nothing) floatNoPeriod :: Parsec.Parsec String ParseState XObj floatNoPeriod = do (i, num) <- withBases _ <- Parsec.char 'f' incColumn 1 - return (XObj (Num FloatTy (read num)) i Nothing) + pure (XObj (Num FloatTy (Floating (read num))) i Nothing) integer :: Parsec.Parsec String ParseState XObj integer = do (i, num) <- withBases - return (XObj (Num IntTy (read num)) i Nothing) + pure (XObj (Num IntTy (Integral (read num))) i Nothing) byte :: Parsec.Parsec String ParseState XObj byte = do (i, num) <- withBases _ <- Parsec.char 'b' incColumn 1 - return (XObj (Num ByteTy (read num)) i Nothing) + pure (XObj (Num ByteTy (Integral (read num))) i Nothing) long :: Parsec.Parsec String ParseState XObj long = do (i, num) <- withBases _ <- Parsec.char 'l' incColumn 1 - return (XObj (Num LongTy (read num)) i Nothing) + pure (XObj (Num LongTy (Integral (read num))) i Nothing) number :: Parsec.Parsec String ParseState XObj number = Parsec.try float <|>