packages feed

BASIC 0.1.4.0 → 0.1.5.0

raw patch · 5 files changed

+66/−30 lines, 5 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

BASIC.cabal view
@@ -1,5 +1,5 @@ Name:		BASIC-Version:	0.1.4.0+Version:	0.1.5.0 License:	BSD3 Author:		Lennart Augustsson Maintainer:	Lennart Augustsson
Language/BASIC/Interp.hs view
@@ -9,7 +9,12 @@  executeBASIC :: [Expr a] -> IO () executeBASIC cmds = run M.empty [] [] cmds-  where --run stk cs | trace (show (stk, cmds)) False = undefined+  where -- map from line number to the rest of the lines from that point.+	mcmds = M.fromList $ map (\ cs -> (cmdLabel (head cs), cs)) $ init $ tails cmds++	-- The function 'run' takes an environment (maps variables to values),+        -- a GOSUB stack, and FOR stack.+        --run stk cs | trace (show (stk, cmds)) False = undefined         run _ _ _ [] = return ()         run _ _ _ (Cmd _ End _:_) = return ()   	run env stk fors (Cmd _ Goto [Label l]:_) = goto env stk fors l@@ -31,8 +36,9 @@ 	               else run env stk fors' cs 	run env stk fors (Cmd _ Next _ : _) = error $ "Unmatched FOR/NEXT" 	run env stk fors (c:cs) = do env' <- run1 env c; run env' stk fors cs+ 	goto env stk fors l = maybe (error $ "No line " ++ show l) (run env stk fors) (M.lookup l mcmds)-	mcmds = M.fromList $ map (\ cs -> (cmdLabel (head cs), cs)) $ init $ tails cmds+ 	run1 env (Cmd _ Print es) = do mapM_ (\ e -> eval env e >>= prExpr) es; putStrLn ""; return env 	run1 env (Cmd _ Let [v,e]) = do d <- eval env e; return $ M.insert v d env 	run1 env (Cmd _ Rem _) = return env@@ -45,6 +51,7 @@             d <- loop 	    return $ M.insert v (Dbl d) env 	run1 _ e = error $ "run1: " ++ show e+ 	eval _ e@(Dbl _) = return e 	eval _ e@(Str _) = return e 	eval env (Binop e1 op e2) = do@@ -62,7 +69,7 @@              (Dbl d1, ">", Dbl d2) -> return $ Dbl (if d1 < d2 then 1 else 0)              (Dbl d1, "<=", Dbl d2) -> return $ Dbl (if d1 <= d2 then 1 else 0)              (Dbl d1, ">=", Dbl d2) -> return $ Dbl (if d1 >= d2 then 1 else 0)-	     x -> error $ "Expected numbers " ++ show x+	     x -> error $ "eval binop expected numbers " ++ show x 	eval env (SIN e) = unop env sin e 	eval env (COS e) = unop env cos e 	eval env (TAN e) = unop env tan e@@ -76,9 +83,14 @@ 	eval _   (RND _) = do d <- randomIO; return (Dbl d) 	eval env x | x > Var && x < None = return $ maybe (Dbl 0) id $ M.lookup x env 	eval _ x = error $ "eval: " ++ show x+ 	prExpr (Dbl i) = putStr $ chopDec $ printf "%g" i 	prExpr (Str s) = putStr s 	prExpr e = error $ "prExpr: " ++ show e 	chopDec s = let r = reverse s in if take 2 r == "0." then reverse (drop 2 r) else s -        unop env op e = fmap (\ (Dbl x) -> Dbl $ op x) $ eval env e+        unop env op e = do+            v <- eval env e+	    case v of+	        Dbl x -> return $ Dbl $ op x+		x -> error $ "eval unop expected numbers"
Language/BASIC/Parser.hs view
@@ -31,11 +31,13 @@     unsafePerformIO (readIORef stack) getBASIC' e = error $ "getBASIC: " ++ show e +-- 10 PRINT X; Y joinPrint :: [Expr a] -> [Expr a] joinPrint (Cmd l Print es : e : cs) | not (isCmd e) = joinPrint (Cmd l Print (es ++ [e]) : cs) joinPrint (c : cs) = c : joinPrint cs joinPrint [] = [] +-- Get rid of := by moving operands into the command. joinAssign :: Expr a -> Expr a --joinAssign c | trace (show c) False = undefined joinAssign (Cmd l For [v] := Binop e1 ";" (Binop e2 ";" e3)) = Cmd l For [v, e1, e2, e3]@@ -65,16 +67,18 @@ (^) :: Expr a -> Expr a -> Expr a (^) = binop "^" +-- Rebalance some ops binop :: String -> Expr a -> Expr a -> Expr a-binop op (Cmd l c [x]) y = Cmd l c (binops x op y)-binop op x (Binop y ";" z) = Binop (Binop x op y) ";" z-binop op (Binop x ";" y) z = Binop x ";" (Binop y op z)+binop op (Cmd l c [x]) y = Cmd l c (binops x op y)           -- 10 PRINT X+Y+binop op x (Binop y ";" z) = Binop (Binop x op y) ";" z      -- FOR+binop op (Binop x ";" y) z = Binop x ";" (Binop y op z)      -- FOR binop op x y = Binop x op y  binops :: Expr a -> String -> Expr a -> [Expr a] binops x op (Binop y ";" z) = [Binop x op y, z] binops x op y = [Binop x op y] +-- Allow pahntom type changes. flex :: Expr a -> Expr b flex (Cmd l c es) = Cmd l c (map flex es) flex (Str s) = Str s@@ -137,14 +141,16 @@ -- Yuck!  But this is the only way I could figure out -- how to make a Monad like Expr actually be able to save -- every statement.--- Now is we could just write 'x' instead of 'X' it there+-- Now if we could just write 'x' instead of 'X' there -- would be no need for unsafePerformIO. instance Monad Expr where     a >> b = unsafePerformIO $ do push (flex a); push (flex b) +-- Stack for saving allevery expression we see. stack :: IORef [Expr ()] stack = unsafePerformIO $ newIORef [] +-- Save an expression. push :: Expr () -> IO (Expr a) push None = return None push x = do@@ -165,18 +171,20 @@ instance IsString (Expr a) where     fromString = Str --- (^) :: E-+-- 10 PRINT X instance Eq (PRINT -> Expr a -> Expr b) instance Show (PRINT -> Expr a -> Expr b) instance Num (PRINT -> Expr a -> Expr b) where     fromInteger i _ v = Cmd i Print [flex v] +-- 10 PRINT SQR(X) instance Eq (PRINT -> (Expr c -> Expr c) -> Expr a -> Expr b) instance Show (PRINT -> (Expr c -> Expr c) -> Expr a -> Expr b) instance Num (PRINT -> (Expr c -> Expr c) -> Expr a -> Expr b) where     fromInteger i _ f v = Cmd i Print [flex $ f $ flex v] +-- 10 PRINT 1+-- 10 PRINT 1.5 instance Eq (PRINT -> t -> Expr a) instance Show (PRINT -> t -> Expr a) instance (Show t, Typeable t) => Num (PRINT -> t -> Expr a) where@@ -186,41 +194,49 @@             c : _ -> c 	    [] -> error $ "Bad type(1) " ++ show x ++ " :: " ++ show (typeOf x) +-- 10 END instance Eq (END -> Expr a) instance Show (END -> Expr a) instance Num (END -> Expr a) where     fromInteger i c = Cmd i (if c P.== RETURN then Return else if c P.== REM then Rem else End) [] +-- 10 LET X := Y, i.e., (10 LET X) := Y instance Eq (LET -> Expr a -> Expr b) instance Show (LET -> Expr a -> Expr b) instance Num (LET -> Expr a -> Expr b) where     fromInteger i _ v = Cmd i Let [flex v] +-- 10 GOTO 10 instance Eq (GOTO -> t -> Expr a) instance Show (GOTO -> t -> Expr a) instance (Integral t) => Num (GOTO -> t -> Expr a) where     fromInteger i c l = Cmd i (if c P.== GOSUB then Gosub else Goto) [Label $ toInteger l] +-- 10 IF X <> 0 THEN 10, i.e., (10 IF X) <> (0 THEN 10) instance Eq (IF -> Expr a -> Expr b) instance Show (IF -> Expr a -> Expr b) instance Num (IF -> Expr a -> Expr b) where     fromInteger i _ v = Cmd i If [flex v] +-- 10 IF X <> 0 THEN 10, i.e. (10 IF X) <> (0 THEN 10) instance Eq (THEN -> t -> Expr a) instance Show (THEN -> t -> Expr a) instance (Integral t) => Num (THEN -> t -> Expr a) where     fromInteger c _ l = Binop (Dbl (fromInteger c)) ";" (Label $ fromIntegral l) +-- 10 INPUT X instance Eq (INPUT -> Expr a -> Expr b) instance Show (INPUT -> Expr a -> Expr b) instance Num (INPUT -> Expr a -> Expr b) where     fromInteger i _ v = Cmd i Input [flex v] +-- 10 FOR X := ... instance Eq (FOR -> Expr a -> Expr b) instance Show (FOR -> Expr a -> Expr b) instance Num (FOR -> Expr a -> Expr b) where     fromInteger i _ v = Cmd i For [flex v] +-- 10 FOR X := 1 TO Y, i.e., (10 FOR X) := (1 TO Y) instance Num (TO -> Expr b -> Expr a) where     fromInteger c _ x = Binop (Dbl (fromInteger c)) ";" (flex x) @@ -232,6 +248,8 @@         e : _ -> e         [] -> error $ "Bad type(3) " ++ show x ++ " :: " ++ show (typeOf x) +-- 10 FOR X := 1 TO 10+-- 10 FOR X := 1 TO 10.5 instance Eq (TO -> t -> Expr a) instance Show (TO -> t -> Expr a) instance (Show t, Typeable t) => Num (TO -> t -> Expr a) where@@ -239,6 +257,7 @@ instance (Show t, Typeable t) => Fractional (TO -> t -> Expr a) where     fromRational c _ x = Binop (Dbl (fromRational c)) ";" (castExpr x) +-- 10 FOR X := 1 TO 10 STEP 2 instance Eq (TO -> t -> STEP -> s -> Expr a) instance Show (TO -> t -> STEP -> s -> Expr a) instance (Show t, Typeable t, Show s, Typeable s) => Num (TO -> t -> STEP -> s -> Expr a) where@@ -248,6 +267,7 @@     fromRational c _ x _ y =       Binop (Dbl (fromRational c)) ";" (Binop (castExpr x) ";" (castExpr y)) +-- 10 NEXT X instance Eq (NEXT -> Expr a -> Expr b) instance Show (NEXT -> Expr a -> Expr b) instance Num (NEXT -> Expr a -> Expr b) where
Language/BASIC/Translate.hs view
@@ -28,9 +28,12 @@         (n, cs'') = removeNext cs' 	removeNext [] = error $ "No NEXT for line " ++ show (l, v) 	removeNext (Cmd ln Next [v'] : bs) | v == v' = (ln+2,-	    [Cmd ln Let [v, Binop v "+" inc], Cmd (ln+1) Goto [Label (l+1)], Cmd (ln+2) Rem []] ++ bs)+	    [Cmd ln Let [v, Binop v "+" inc],+             Cmd (ln+1) Goto [Label (l+1)],+             Cmd (ln+2) Rem []] ++ bs) 	removeNext (c:bs) = (ln, c:bs') where (ln, bs') = removeNext bs-	loopStart = [Cmd l Let [v, lo], Cmd (l+1) If [Binop v ">" hi, Label n]]+	loopStart = [Cmd l Let [v, lo],+                     Cmd (l+1) If [Binop v ">" hi, Label n]]     in  loopStart ++ cs'' removeFor (c:cs) = c : removeFor cs @@ -41,14 +44,18 @@      let mfunc = trans cmds'     writeCodeGenModule "run.bc" mfunc++    -- Slow external optimizer.     func <- optimizeFunctionCG mfunc---    writeCodeGenModule "runo.bc" mfunc'++    -- Use this for unoptimized code --    func <- simpleFunction mfunc-    return func +    return func +-- Translate a (END terminated) list of lines to a function. trans :: [Expr ()] -> CodeGenModule (Function (IO ()))-trans acmds = do+trans cmds = do     atan     <- newNamedFunction ExternalLinkage "atan"     :: TFunction (Double -> IO Double)     atof     <- newNamedFunction ExternalLinkage "atof"     :: TFunction (Ptr Word8 -> IO Double)     cos      <- newNamedFunction ExternalLinkage "cos"      :: TFunction (Double -> IO Double)@@ -56,13 +63,14 @@     fabs     <- newNamedFunction ExternalLinkage "fabs"     :: TFunction (Double -> IO Double)     gets     <- newNamedFunction ExternalLinkage "gets"     :: TFunction (Ptr Word8 -> IO (Ptr Word8))     log      <- newNamedFunction ExternalLinkage "log"      :: TFunction (Double -> IO Double)-    power    <- newNamedFunction ExternalLinkage "power"    :: TFunction (Double -> Double -> IO Double)+    pow      <- newNamedFunction ExternalLinkage "pow"      :: TFunction (Double -> Double -> IO Double)     printfv  <- newNamedFunction ExternalLinkage "printf"   :: TFunction (Ptr Word8 -> VarArgs Word32)     rand     <- newNamedFunction ExternalLinkage "rand"     :: TFunction (IO Word32)     sin      <- newNamedFunction ExternalLinkage "sin"      :: TFunction (Double -> IO Double)     sqrt     <- newNamedFunction ExternalLinkage "sqrt"     :: TFunction (Double -> IO Double)     sranddev <- newNamedFunction ExternalLinkage "sranddev" :: TFunction (IO ())     tan      <- newNamedFunction ExternalLinkage "tan"      :: TFunction (Double -> IO Double)+    trunc    <- newNamedFunction ExternalLinkage "trunc"    :: TFunction (Double -> IO Double)     let printfd :: Function (Ptr Word8 -> Double -> IO Word32)         printfd = castVarArgs printfv         printfs :: Function (Ptr Word8 -> Ptr Word8 -> IO Word32)@@ -74,8 +82,7 @@     fmts <- createStringNul "%s"     fmtn <- createStringNul "\n" -    let cmds = acmds ++ [Cmd 99999 End []]-        nextmap = fromList $ zip (map cmdLabel cmds) (map cmdLabel (tail cmds))+    let nextmap = fromList $ zip (map cmdLabel cmds) (map cmdLabel (tail cmds))         strings = nub $ concatMap getCmdStrings cmds 	getCmdStrings (Cmd _ _ es) = concatMap getExprStrings es 	getCmdStrings _ = error "getCmdStrings"@@ -151,7 +158,7 @@ 	    genExpr (Binop e1 "-" e2) = binop sub e1 e2 	    genExpr (Binop e1 "*" e2) = binop mul e1 e2 	    genExpr (Binop e1 "/" e2) = binop fdiv e1 e2-	    genExpr (Binop e1 "^" e2) = binop (call power) e1 e2+	    genExpr (Binop e1 "^" e2) = binop (call pow) e1 e2 	    genExpr (SIN e) = unop (call sin) e 	    genExpr (COS e) = unop (call cos) e 	    genExpr (TAN e) = unop (call tan) e@@ -160,12 +167,7 @@ 	    genExpr (LOG e) = unop (call log) e 	    genExpr (SQR e) = unop (call sqrt) e 	    genExpr (ABS e) = unop (call fabs) e-	    genExpr (INT e) = do-	        v <- genExpr e---		r <- frem v (1 :: Double)---		sub v r-                i <- fptoui v-                uitofp (i :: Value Word64)+	    genExpr (INT e) = unop (call trunc) e             genExpr (RND _) = do                 r <- call rand                 d <- uitofp r@@ -199,15 +201,17 @@                 d <- genExpr e                 op d -        call sranddev+        call sranddev -- Make sure we get new random numbers 	p <- arrayMalloc (1000 :: Word32) 	store p gosubStack-	br (block $ cmdLabel $ head cmds)-        mapM_ gen cmds+	br (block $ cmdLabel $ head cmds)  -- jump to first line +        mapM_ gen cmds -- generate all lines+ 	unreach <- createBasicBlock 	unreachable +	-- The code for RETURN 	defineBasicBlock retlabel         sp' <- load gosubStack 	sp <- getElementPtr sp' ((-1)::Word32, ())
Language/BASIC/Types.hs view
@@ -22,7 +22,7 @@  cmdLabel :: Expr a -> Integer cmdLabel (Cmd l _ _) = l-cmdLabel e = error $ "Strange top level command " ++ show e+cmdLabel e = error $ "cmdLabel: Strange top level command " ++ show e  data Command = Print | End | Let | Goto | Gosub | Return | If | Input | For | Next | Rem     deriving (Eq, Ord, Show, Typeable)