diff --git a/BASIC.cabal b/BASIC.cabal --- a/BASIC.cabal +++ b/BASIC.cabal @@ -1,5 +1,5 @@ Name: BASIC -Version: 0.1.3.0 +Version: 0.1.4.0 License: BSD3 Author: Lennart Augustsson Maintainer: Lennart Augustsson diff --git a/Language/BASIC/Interp.hs b/Language/BASIC/Interp.hs --- a/Language/BASIC/Interp.hs +++ b/Language/BASIC/Interp.hs @@ -19,13 +19,14 @@ 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 + 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 + run env stk fors@((Cmd _ For [v,_,h,s] : bs) : fors') (Cmd _ Next [v'] : cs) | v == v' = do let Dbl i = env M.! v Dbl hv <- eval env h - let i' = i + 1 + Dbl sv <- eval env s + let i' = i + sv 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" diff --git a/Language/BASIC/Parser.hs b/Language/BASIC/Parser.hs --- a/Language/BASIC/Parser.hs +++ b/Language/BASIC/Parser.hs @@ -2,7 +2,7 @@ {-# LANGUAGE FlexibleInstances, IncoherentInstances, ExtendedDefaultRules, OverloadedStrings, DeriveDataTypeable #-} module Language.BASIC.Parser( getBASIC, BASIC, - PRINT(..), END(..), LET(..), GOTO(..), IF(..), THEN(..), INPUT(..), FOR(..), TO(..), NEXT(..), + PRINT(..), END(..), LET(..), GOTO(..), IF(..), THEN(..), INPUT(..), FOR(..), TO(..), NEXT(..), STEP(..), Expr((:=)), (<>), (==), (<), (>), (<=), (>=), (^) ) where import Prelude hiding ((==),(<),(>),(<=),(>=),(^)) @@ -38,7 +38,8 @@ 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 For [v] := Binop e1 ";" (Binop e2 ";" e3)) = Cmd l For [v, e1, e2, e3] +joinAssign (Cmd l For [v] := Binop e1 ";" e2) = Cmd l For [v, e1, e2, Dbl 1] joinAssign (Cmd l Let [v] := e) = Cmd l Let [v, e] joinAssign c = c @@ -131,6 +132,7 @@ data FOR = FOR data TO = TO data NEXT = NEXT +data STEP = STEP -- Yuck! But this is the only way I could figure out -- how to make a Monad like Expr actually be able to save @@ -170,6 +172,11 @@ instance Num (PRINT -> Expr a -> Expr b) where fromInteger i _ v = Cmd i Print [flex v] +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] + instance Eq (PRINT -> t -> Expr a) instance Show (PRINT -> t -> Expr a) instance (Show t, Typeable t) => Num (PRINT -> t -> Expr a) where @@ -177,7 +184,7 @@ 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 + [] -> error $ "Bad type(1) " ++ show x ++ " :: " ++ show (typeOf x) instance Eq (END -> Expr a) instance Show (END -> Expr a) @@ -214,22 +221,32 @@ instance Num (FOR -> Expr a -> Expr b) where fromInteger i _ v = Cmd i For [flex v] +instance Num (TO -> Expr b -> Expr a) where + fromInteger c _ x = Binop (Dbl (fromInteger c)) ";" (flex x) + +castExpr x = + let f con = fmap con (cast x) + id' :: Expr () -> Expr a + id' = flex + in case catMaybes [f (Dbl . fromInteger), f Dbl, f id'] of + e : _ -> e + [] -> error $ "Bad type(3) " ++ show x ++ " :: " ++ show (typeOf x) + 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 + fromInteger c _ x = Binop (Dbl (fromInteger c)) ";" (castExpr 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 + fromRational c _ x = Binop (Dbl (fromRational c)) ";" (castExpr x) + +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 + fromInteger c _ x _ y = + Binop (Dbl (fromInteger c)) ";" (Binop (castExpr x) ";" (castExpr y)) +instance (Show t, Typeable t, Show s, Typeable s) => Fractional (TO -> t -> STEP -> s -> Expr a) where + fromRational c _ x _ y = + Binop (Dbl (fromRational c)) ";" (Binop (castExpr x) ";" (castExpr y)) instance Eq (NEXT -> Expr a -> Expr b) instance Show (NEXT -> Expr a -> Expr b) diff --git a/Language/BASIC/Translate.hs b/Language/BASIC/Translate.hs --- a/Language/BASIC/Translate.hs +++ b/Language/BASIC/Translate.hs @@ -23,12 +23,12 @@ -- This assumes some sanity in loop nesting. removeFor :: [Expr a] -> [Expr a] removeFor [] = [] -removeFor (Cmd l For [v, lo, hi] : cs) = +removeFor (Cmd l For [v, lo, hi, inc] : 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) + [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]] in loopStart ++ cs'' diff --git a/examples/Func.hs b/examples/Func.hs --- a/examples/Func.hs +++ b/examples/Func.hs @@ -6,8 +6,7 @@ main :: IO () main = runBASIC' $ do - 10 FOR I := 0 TO 20 - 20 LET X := I/10 - 30 PRINT X;" ";SIN(X);" ";COS(X);" ";TAN(X);" ";ATN(X);" ";EXP(X);" ";LOG(X);" ";SQR(X);" ";ABS(X);" ";SGN(X);" ";INT(X);" ";RND(X) - 40 NEXT I + 10 FOR X := 0 TO 2.01 STEP 0.1 + 30 PRINT SIN(X);" ";COS(X);" ";TAN(X);" ";ATN(X);" ";EXP(X);" ";LOG(X);" ";SQR(X);" ";ABS(X);" ";SGN(X);" ";INT(X);" ";RND(X);" ";X + 40 NEXT X 100 END