packages feed

BASIC (empty) → 0.1.0.0

raw patch · 11 files changed

+577/−0 lines, 11 filesdep +basedep +containersdep +llvmsetup-changed

Dependencies added: base, containers, llvm, random, timeit

Files

+ BASIC.cabal view
@@ -0,0 +1,21 @@+Name:		BASIC+Version:	0.1.0.0+License:	BSD3+Author:		Lennart Augustsson+Maintainer:	Lennart Augustsson+Category:	Language+Synopsis:	Embedded BASIC+Description:	A simplified version of the original BASIC embedded in Haskell.+Build-type:	Simple+Build-Depends:	base, containers, llvm >= 0.6.3, random, timeit+Exposed-modules:	Language.BASIC+Other-modules:+	Language.BASIC.Interp+	Language.BASIC.Parser+	Language.BASIC.Translate+	Language.BASIC.Types+Extra-source-files:+	examples/Hello.hs+	examples/HiLo.hs+	examples/Infinity.hs+	examples/Makefile
+ Language/BASIC.hs view
@@ -0,0 +1,27 @@+-- |A simplified embedded version of original BASIC.+-- Some things work, some things just give utterly mysterious type errors.+--+-- Beware, this is just a fun weekend hack.+module Language.BASIC(module Language.BASIC.Parser, module Language.BASIC.Types, runBASIC, runBASIC') where+import System.TimeIt++import Language.BASIC.Parser hiding (Expr)+import Language.BASIC.Types(Expr(I, S, X, Y, Z, RND, INT, SGN))+import Language.BASIC.Interp+import Language.BASIC.Translate++-- |Run a BASIC program with an interpreter.+runBASIC :: BASIC -> IO ()+runBASIC x = do+    let cmds = getBASIC x+--    putStrLn $ unlines $ map show cmds+    timeIt $ executeBASIC cmds++-- |Run a BASIC program with a compiler.+runBASIC' :: BASIC -> IO ()+runBASIC' x = do+    let cmds = getBASIC x+--    putStrLn $ unlines $ map show cmds+--    executeBASIC cmds+    func <- translateBASIC cmds+    timeIt func
+ Language/BASIC/Interp.hs view
@@ -0,0 +1,67 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+module Language.BASIC.Interp(executeBASIC) where+import Data.List+import qualified Data.Map as M+import System.Random+import Text.Printf++import Language.BASIC.Types++executeBASIC :: [Expr a] -> IO ()+executeBASIC cmds = run M.empty [] [] cmds+  where --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+	run env stk fors (Cmd _ Gosub [Label l]:cs) = goto env (cs:stk) fors l+	run env stk fors (Cmd _ If [e, Label l]:cs) = do+            d <- eval env e+            if d /= Dbl 0 then goto env stk fors l else run env stk fors cs+	run _ [] fors (Cmd _ Return _ : _) = error "RETURN without GOSUB"+	run env (cs:stk) fors (Cmd _ Return _:_) = run env stk fors cs+	run env stk fors cs@(Cmd _ For [v,l,_] : cs') = do+            d <- eval env l+	    run (M.insert v d env) stk (cs:fors) cs'+	run env stk fors@((Cmd _ For [v,_,h] : bs) : fors') (Cmd _ Next [v'] : cs) | v == v' = do+	    let Dbl i = env M.! v+	    Dbl hv <- eval env h+	    let i' = i + 1+	    if i' <= hv then run (M.insert v (Dbl i') env) stk fors bs+	               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+	run1 env (Cmd _ Input [v]) = do+            let loop = do+                    s <- getLine+		    case reads s of+		        [(d,"")] -> return d+			_ -> do putStrLn "Not a number, try again"; loop+            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+            v1 <- eval env e1+	    v2 <- eval env e2+            case (v1, op, v2) of+             (Dbl d1, "+", Dbl d2)  -> return $ Dbl (d1 + d2)+             (Dbl d1, "-", Dbl d2)  -> return $ Dbl (d1 - d2)+             (Dbl d1, "*", Dbl d2)  -> return $ Dbl (d1 * d2)+             (Dbl d1, "/", Dbl d2)  -> return $ Dbl (d1 / d2)+             (Dbl d1, "<>", Dbl d2) -> return $ Dbl (if d1 /= d2 then 1 else 0)+	     x -> error $ "Expected numbers " ++ show x+	eval env (SGN e) = fmap (\ (Dbl x) -> Dbl $ signum x) $ eval env e+	eval env (INT e) = fmap (\ (Dbl x) -> Dbl $ fromIntegral $ truncate x) $ eval env e+	eval _   (RND _) = do d <- randomIO; return (Dbl d)+	eval env x | x > Var = 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
+ Language/BASIC/Parser.hs view
@@ -0,0 +1,192 @@+{-# OPTIONS_GHC -fno-warn-missing-methods -fno-warn-orphans #-}+{-# LANGUAGE FlexibleInstances, IncoherentInstances, ExtendedDefaultRules, OverloadedStrings, DeriveDataTypeable #-}+module Language.BASIC.Parser(+    getBASIC, BASIC,+    PRINT(..), END(..), LET(..), GOTO(..), IF(..), THEN(..), INPUT(..), FOR(..), TO(..), NEXT(..),+    Expr((:=)), (<>)+    ) where+import Data.List+import Data.Maybe+import Data.Function+import Data.Typeable+import Data.IORef+import Data.String+import System.IO.Unsafe++import Language.BASIC.Types++--import Debug.Trace++getBASIC :: BASIC -> [Expr ()]+getBASIC cs = getBASIC' (cs >> 999999 END)++getBASIC' :: BASIC -> [Expr ()]+getBASIC' None =+    sortBy (compare `on` cmdLabel) $+    joinPrint $+    map joinAssign $+    reverse $+    unsafePerformIO (readIORef stack)+getBASIC' e = error $ "getBASIC: " ++ show e++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 [] = []++joinAssign :: Expr a -> Expr a+--joinAssign c | trace (show c) False = undefined+joinAssign (Cmd l For [v] := Binop e1 ";" e2) = Cmd l For [v, e1, e2]+joinAssign (Cmd l Let [v] := e) = Cmd l Let [v, e]+joinAssign c = c++isCmd :: Expr a -> Bool+isCmd (Cmd _ _ _) = True+isCmd _ = False++infix 4 <>+(<>) :: Expr a -> Expr a -> Expr a+(<>) = binop "<>"++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 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]++flex :: Expr a -> Expr b+flex (Cmd l c es) = Cmd l c (map flex es)+flex (Str s) = Str s+flex (Dbl d) = Dbl d+flex (Label l) = Label l+flex (Binop e1 op e2) = Binop (flex e1) op (flex e2)+flex (e1 := e2) = flex e1 := flex e2+flex (RND x) = RND x+flex (INT x) = INT (flex x)+flex (SGN x) = SGN (flex x)+flex Var = Var+flex I = I+flex S = S+flex X = X+flex Y = Y+flex Z = Z+flex None = None++data PRINT = PRINT+data END = END | STOP | RETURN | REM deriving (Eq)+data LET = LET+data GOTO = GOTO | GOSUB deriving (Eq)+data IF = IF+data THEN = THEN+data INPUT = INPUT+data FOR = FOR+data TO = TO+data NEXT = NEXT++-- 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+-- would be no need for unsafePerformIO.+instance Monad Expr where+    a >> b = unsafePerformIO $ do push (flex a); push (flex b)++stack :: IORef [Expr ()]+stack = unsafePerformIO $ newIORef []++push :: Expr () -> IO (Expr a)+push None = return None+push x = do+    s <- readIORef stack+    writeIORef stack (x:s)+    return None++instance Num (Expr a) where+    (+) = binop "+"+    (-) = binop "-"+    (*) = binop "*"+    fromInteger = Dbl . fromInteger++instance Fractional (Expr a) where+    (/) = binop "/"+    fromRational = Dbl . fromRational++instance IsString (Expr a) where+    fromString = Str++-- (^) :: E++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]++instance Eq (PRINT -> t -> Expr a)+instance Show (PRINT -> t -> Expr a)+instance (Show t, Typeable t) => Num (PRINT -> t -> Expr a) where+    fromInteger i _ x =+        let f con = fmap (\ v -> Cmd i Print [con v]) (cast x)+        in  case catMaybes [f Str, f (Dbl . fromInteger), f Dbl] of+            c : _ -> c+	    [] -> error $ "Bad type " ++ show x++instance Eq (END -> Expr a)+instance Show (END -> Expr a)+instance Num (END -> Expr a) where+    fromInteger i c = Cmd i (if c == RETURN then Return else if c == REM then Rem else End) []++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]++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 == GOSUB then Gosub else Goto) [Label $ toInteger l]++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]++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)++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]++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]++instance Eq (TO -> t -> Expr a)+instance Show (TO -> t -> Expr a)+instance (Show t, Typeable t) => Num (TO -> t -> Expr a) where+    fromInteger c _ x = -- Binop (Dbl (fromInteger c)) ";" (Dbl $ fromIntegral x)+      Binop (Dbl (fromInteger c)) ";" $+        let f con = fmap con (cast x)+        in  case catMaybes [f (Dbl . fromInteger), f Dbl] of+            e : _ -> e+	    [] -> error $ "Bad type " ++ show x+instance (Show t, Typeable t) => Fractional (TO -> t -> Expr a) where+    fromRational c _ x = -- Binop (Dbl (fromRational c)) ";" (Dbl $ fromIntegral x)+      Binop (Dbl (fromRational c)) ";" $+        let f con = fmap con (cast x)+        in  case catMaybes [f (Dbl . fromInteger), f Dbl] of+            e : _ -> e+	    [] -> error $ "Bad type " ++ show x++instance Eq (NEXT -> Expr a -> Expr b)+instance Show (NEXT -> Expr a -> Expr b)+instance Num (NEXT -> Expr a -> Expr b) where+    fromInteger i _ v = Cmd i Next [flex v]
+ Language/BASIC/Translate.hs view
@@ -0,0 +1,166 @@+module Language.BASIC.Translate(translateBASIC) where+import Control.Monad+import Data.List+import qualified Data.Map as M+import Data.Map((!), fromList)+import Data.Word++import LLVM.Core+import LLVM.Util.File++import Language.BASIC.Types++renumber :: [Expr a] -> [Expr a]+renumber cs =+    let m = M.fromList $ zip (map cmdLabel cs) [10, 20 ..]+        ren (Cmd l c es) = Cmd (m M.! l) c (map ren es)+	ren (Label l) = Label (m M.! l)+	ren e = e+    in  map ren cs++-- This assumes some sanity in loop nesting.+removeFor :: [Expr a] -> [Expr a]+removeFor [] = []+removeFor (Cmd l For [v, lo, hi] : cs) =+    let cs' = removeFor cs+        (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 "+" (Dbl 1)], 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]]+    in  loopStart ++ cs''+removeFor (c:cs) = c : removeFor cs++translateBASIC :: [Expr ()] -> IO (IO ())+translateBASIC cmds = do+    let cmds' = removeFor $ renumber cmds+--    putStrLn $ unlines $ map show cmds'++    let mfunc = trans cmds'+    writeCodeGenModule "run.bc" mfunc+    func <- optimizeFunctionCG mfunc+--    writeCodeGenModule "runo.bc" mfunc'+--    func <- simpleFunction mfunc+    return func+++trans :: [Expr ()] -> CodeGenModule (Function (IO ()))+trans acmds = do+    atof     <- newNamedFunction ExternalLinkage "atof"     :: TFunction (Ptr Word8 -> IO Double)+    gets     <- newNamedFunction ExternalLinkage "gets"     :: TFunction (Ptr Word8 -> IO (Ptr Word8))+    printfv  <- newNamedFunction ExternalLinkage "printf"   :: TFunction (Ptr Word8 -> VarArgs Word32)+    rand     <- newNamedFunction ExternalLinkage "rand"     :: TFunction (IO Word32)+    sranddev <- newNamedFunction ExternalLinkage "sranddev" :: TFunction (IO ())+    let printfd :: Function (Ptr Word8 -> Double -> IO Word32)+        printfd = castVarArgs printfv+        printfs :: Function (Ptr Word8 -> Ptr Word8 -> IO Word32)+        printfs = castVarArgs printfv+        printfn :: Function (Ptr Word8 -> IO Word32)+        printfn = castVarArgs printfv++    fmtg <- createStringNul "%g"+    fmts <- createStringNul "%s"+    fmtn <- createStringNul "\n"++    let cmds = acmds ++ [Cmd 99999 End []]+        nextmap = fromList $ zip (map cmdLabel cmds) (map cmdLabel (tail cmds))+        strings = nub $ concatMap getCmdStrings cmds+	getCmdStrings (Cmd _ _ es) = concatMap getExprStrings es+	getCmdStrings _ = error "getCmdStrings"+	getExprStrings (Str s) = [s]+	getExprStrings (Binop e1 _ e2) = getExprStrings e1 ++ getExprStrings e2+	getExprStrings _ = []+    strmap <- liftM (fromList . zip strings) $ mapM createStringNul strings++    let mkGlobal x = do+            v <- createNamedGlobal False InternalLinkage (show x) (constOf (0 :: Double))+	    return (x, v)+    globmap <- liftM fromList $ mapM mkGlobal [I,S,X,Y,Z]++    createFunction ExternalLinkage $ do+        let mkBlk c = do b <- newBasicBlock; return (cmdLabel c, b)+        blkmap <- liftM fromList $ mapM mkBlk cmds+	let block = (blkmap !)+	    next = block . (nextmap !)+	    gen (Cmd l kw es) = do+                defineBasicBlock (block l)+		case (kw, es) of+		    (End, _) -> ret ()+		    (Goto, [Label d]) -> br (block d)+		    (Print, as) -> do mapM_ pr as; newline; br (next l)+		    (Let, [v, e]) -> do+                        d <- genExpr e+                        store d (globmap ! v)+		        br (next l)+		    (If, [b, Label d]) -> do+                        v <- genBool b+                        condBr v (block d) (next l)+                    (Input, [v]) -> do+                        buff <- arrayMalloc (100 :: Word32)+			call gets buff+			d <- call atof buff+			store d (globmap ! v)+			free buff+			br (next l)+		    (Rem, _) -> br (next l)+		    x -> error $ "Unimplemented construct " ++ show x+            gen _ = error "gen"++            newline = do+                tmp <- getElementPtr fmtn (0::Word32, (0::Word32, ()))+                call printfn tmp++            pr (Str s) = do+	        tmp <- getElementPtr fmts (0::Word32, (0::Word32, ()))+	        tmpa <- getElementPtr (strmap ! s) (0::Word32, (0::Word32, ()))+                call printfs tmp tmpa+            pr e = do+                d <- genExpr e+                tmp <- getElementPtr fmtg (0::Word32, (0::Word32, ()))+                call printfd tmp d++--	    genExpr e | trace (show e) False = undefined+            genExpr (Dbl d) = return $ value $ constOf d+	    genExpr (Binop e1 "+" e2) = binop add e1 e2+	    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 (INT e) = do+	        v <- genExpr e+--		r <- frem v (1 :: Double)+--		sub v r+                i <- fptoui v+                uitofp (i :: Value Word64)+            genExpr (RND _) = do+                r <- call rand+                d <- uitofp r+		fdiv (d :: Value Double) (0x7fffffff :: Double)+            genExpr (SGN e) = do+                d <- genExpr e+                n <- fcmp FPOLT d (0 :: Double)+                p <- fcmp FPOGT d (0 :: Double)+		nd <- uitofp n+		pd <- uitofp p+		sub (pd :: Value Double) (nd :: Value Double)+	    genExpr e | e > Var = load (globmap ! e)+	    genExpr e = error $ "genExpr: " ++ show e++            genBool (Binop e1 "<>" e2) = binop (fcmp FPONE) e1 e2+	    genBool (Binop e1 "==" e2) = binop (fcmp FPOEQ) e1 e2+	    genBool (Binop e1 "<"  e2) = binop (fcmp FPOLT) e1 e2+	    genBool (Binop e1 "<=" e2) = binop (fcmp FPOLE) e1 e2+	    genBool (Binop e1 ">"  e2) = binop (fcmp FPOGT) e1 e2+	    genBool (Binop e1 ">=" e2) = binop (fcmp FPOGE) e1 e2+	    genBool e = error $ "Unknown bool op " ++ show e++	    binop :: (Value Double -> Value Double -> CodeGenFunction r (Value c)) ->+	             Expr () -> Expr () -> CodeGenFunction r (Value c)+            binop op e1 e2 = do+                d1 <- genExpr e1+                d2 <- genExpr e2+                op d1 d2++        call sranddev+	br (block $ cmdLabel $ head cmds)+        mapM_ gen cmds
+ Language/BASIC/Types.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Language.BASIC.Types where+import Data.Typeable++infix 0 :=+data Expr a+    = Cmd Integer Command [Expr a]+    | Str String+    | Dbl Double+    | Label Integer+    | Binop (Expr a) String (Expr a)+    | Expr a := Expr a+    | RND () | INT (Expr a) | SGN (Expr a)+    | Var+    | I | S | X | Y | Z+    | None+    deriving (Eq, Ord, Show, Typeable)++cmdLabel :: Expr a -> Integer+cmdLabel (Cmd l _ _) = l+cmdLabel e = error $ "Strange top level command " ++ show e++data Command = Print | End | Let | Goto | Gosub | Return | If | Input | For | Next | Rem+    deriving (Eq, Ord, Show, Typeable)++type BASIC = Expr ()+
+ Setup.hs view
@@ -0,0 +1,3 @@+module Main where+import Distribution.Simple+main = defaultMain
+ examples/Hello.hs view
@@ -0,0 +1,9 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}+module Hello where+import Language.BASIC++main :: IO ()+main = runBASIC $ do++    10 PRINT "Hello BASIC World!"
+ examples/HiLo.hs view
@@ -0,0 +1,34 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}+module HiLo where+import Language.BASIC++main :: IO ()+main = runBASIC $ do+    10 GOSUB 1000+    20 PRINT "* Welcome to HiLo *"+    30 GOSUB 1000++    100 LET I := INT(100 * RND())+--    110 PRINT I+    200 PRINT "Guess my number:"+    210 INPUT X+    220 LET S := SGN(I-X)+    230 IF S <> 0 THEN 300++    240 FOR X := 1 TO 5+    250   PRINT X*X;" You won!"+    260 NEXT X+    270 STOP++    300 IF S <> 1 THEN 400+    310 PRINT "Your guess ";X;" is too low."+    320 GOTO 200++    400 PRINT "Your guess ";X;" is too high."+    410 GOTO 200++    1000 PRINT "*******************"+    1010 RETURN++    9999 END
+ examples/Infinity.hs view
@@ -0,0 +1,15 @@+{-# OPTIONS_GHC -fno-warn-type-defaults #-}+{-# LANGUAGE ExtendedDefaultRules, OverloadedStrings #-}+module Infinity where+import Language.BASIC++main :: IO ()+main = runBASIC' $ do++    10 LET I := 1+    20 LET S := 0+    30 LET S := S + 1/I+    40 LET I := I + 1+    50 IF I <> 100000000 THEN 30+    60 PRINT "Almost infinity is ";S+    80 END
+ examples/Makefile view
@@ -0,0 +1,16 @@+ghc := ghc+ghcflags := -Wall -optl -w+examples := Hello HiLo Infinity++all: $(examples)++%: %.hs+	$(ghc) $(ghcflags) --make -o $@ -main-is $(basename $<).main $<++%.run: %+	./$<++run:	$(examples:%=%.run)++clean:+	rm -f $(examples) *.o *.hi *.s *.bc Fib *.exe *.exe.manifest *.bc