diff options
| -rw-r--r-- | hs/.gitignore | 3 | ||||
| -rw-r--r-- | hs/AST.hs | 121 | ||||
| -rw-r--r-- | hs/GCStore.hs | 49 | ||||
| -rw-r--r-- | hs/Interpreter.hs | 481 | ||||
| -rw-r--r-- | hs/Main.hs | 26 | ||||
| -rw-r--r-- | hs/Parser.hs | 163 | ||||
| -rw-r--r-- | hs/ding.txt | 237 | ||||
| -rw-r--r-- | hs/file.squig | 7 | ||||
| -rw-r--r-- | hs/list.squig | 132 | ||||
| -rw-r--r-- | hs/notes.txt | 47 | ||||
| -rw-r--r-- | hs/test.txt | 11 |
11 files changed, 1277 insertions, 0 deletions
diff --git a/hs/.gitignore b/hs/.gitignore new file mode 100644 index 0000000..619c2eb --- /dev/null +++ b/hs/.gitignore @@ -0,0 +1,3 @@ +*.hi +*.o +Main diff --git a/hs/AST.hs b/hs/AST.hs new file mode 100644 index 0000000..a809d6e --- /dev/null +++ b/hs/AST.hs @@ -0,0 +1,121 @@ +module AST where + +import Data.List +import qualified GCStore as GCS (Id) + + +type Name = String + +data Program = Program Block + deriving (Show) + +data Block = Block [Statement] + deriving (Show) + +data Statement + = Declaration Name Expression + | Assignment Name Expression + | Condition Expression Block Block + | Dive Name [Expression] Block + | Expr Expression + deriving (Show) + +data Expression + = EBin BinaryOp Expression Expression + | EUn UnaryOp Expression + | ELit Literal + deriving (Show) + +data Literal + = LNum Double + | LStr String + | LVar Name + | LBlock BlockType ArgList Block + | LGCSId GCS.Id + | LNil + deriving (Show) + +type ArgList = [Name] + +data BlockType = BT0 | BT1 | BT2 -- the number of ?'s + deriving (Show, Enum, Eq) + +data BinaryOp + = BOPlus | BOMinus | BOMul | BODiv | BOMod | BOPow + | BOLess | BOGreater | BOEqual | BOLEq | BOGEq + | BOBoolAnd | BOBoolOr + deriving (Show, Eq) + +data UnaryOp + = UONeg | UONot + deriving (Show, Eq) + + +class ASTPretty a where + astPrettyI :: Int -> a -> String + + astPretty :: a -> String + astPretty = astPrettyI 0 + + +indent :: Int -> String +indent n = replicate (4*n) ' ' + +instance ASTPretty Program where + astPrettyI i (Program (Block sts)) = + let pr = map (astPrettyI i) sts + in intercalate "\n" $ map (uncurry (++)) $ zip ("" : cycle [indent i]) pr + +instance ASTPretty Block where + astPrettyI _ (Block []) = "{}" + astPrettyI i (Block sts) = + let lns = map (('\n' : indent (i+1)) ++) $ map (astPrettyI (i+1)) sts + in "{" ++ concat lns ++ "\n" ++ indent i ++ "}" + +instance ASTPretty Statement where + astPrettyI i (Declaration n e) = n ++ " := " ++ astPrettyI i e ++ ";" + astPrettyI i (Assignment n e) = n ++ " = " ++ astPrettyI i e ++ ";" + astPrettyI i (Condition c b1 b2) = + "if " ++ astPrettyI i c ++ " " ++ astPrettyI i b1 ++ " else " ++ astPrettyI i b2 + astPrettyI i (Dive n [] b) = n ++ " " ++ astPrettyI i b + astPrettyI i (Dive n al b) = + n ++ "(" ++ intercalate ", " (map (astPrettyI i) al) ++ ") " ++ astPrettyI i b + astPrettyI i (Expr e) = astPrettyI i e ++ ";" + +instance ASTPretty Expression where + astPrettyI i (EBin bo e1 e2) = + "(" ++ astPrettyI i e1 ++ ") " ++ astPrettyI i bo ++ " (" ++ astPrettyI i e2 ++ ")" + astPrettyI i (EUn uo e) = + astPrettyI i uo ++ "(" ++ astPrettyI i e ++ ")" + astPrettyI i (ELit l) = astPrettyI i l + +instance ASTPretty Literal where + astPrettyI _ (LNum m) = show m + astPrettyI _ (LStr s) = show s + astPrettyI _ (LVar n) = n + astPrettyI i (LBlock bt [] b) = replicate (fromEnum bt) '?' ++ astPrettyI i b + astPrettyI i (LBlock bt al b) = + replicate (fromEnum bt) '?' ++ "(" ++ intercalate ", " al ++ ")" ++ astPrettyI i b + astPrettyI _ (LGCSId d) = "<[" ++ show d ++ "]>" + astPrettyI _ LNil = "nil" + +instance ASTPretty BinaryOp where + astPrettyI _ bo = case bo of + BOPlus -> "+" + BOMinus -> "-" + BOMul -> "*" + BODiv -> "/" + BOMod -> "%" + BOPow -> "**" + BOLess -> "<" + BOGreater -> ">" + BOEqual -> "==" + BOLEq -> "<=" + BOGEq -> ">=" + BOBoolAnd -> "&&" + BOBoolOr -> "||" + +instance ASTPretty UnaryOp where + astPrettyI _ uo = case uo of + UONeg -> "-" + UONot -> "!" diff --git a/hs/GCStore.hs b/hs/GCStore.hs new file mode 100644 index 0000000..d1e550f --- /dev/null +++ b/hs/GCStore.hs @@ -0,0 +1,49 @@ +-- Intended to be imported qualified. + +module GCStore(Store, Id, empty, store, retrieve, update, refcount, ref, deref) where + +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +-- import Debug.Trace + + +type Id = Int + +data Store a = Store (Map.Map Id (a, Int)) (Set.Set Id) (Set.Set Id) + deriving (Show) + +empty :: Store a +empty = Store Map.empty Set.empty Set.empty + +store :: Show a => Store a -> a -> (Id, Store a) +store (Store vm fs us) a = + let (i, fs') = if Set.null fs + then (maybe 1 succ (Set.lookupMax us), fs) + else Set.deleteFindMin fs + in (i, Store (Map.insert i (a, 1) vm) fs' (Set.insert i us)) + +retrieve :: Store a -> Id -> Maybe a +retrieve (Store vm _ _) i = fst <$> Map.lookup i vm + +update :: Show a => Store a -> Id -> a -> Store a +update (Store vm fs us) i a = + maybe (error $ "GCStore.update on nonexistent id " ++ show i) + (\(_, rc) -> Store (Map.insert i (a, rc) vm) fs us) + (Map.lookup i vm) + +refcount :: Store a -> Id -> Int +refcount (Store vm _ _) i = maybe 0 snd $ Map.lookup i vm + +ref :: Store a -> Id -> Store a +ref (Store vm fs us) i = Store (Map.alter updf i vm) fs us + where updf Nothing = error $ "GCStore.ref on nonexistent id " ++ show i + updf (Just (a, rc)) = Just (a, rc + 1) + +deref :: Store a -> Id -> Store a +deref (Store vm fs us) i = + maybe (error $ "GCStore.deref on nonexistent id " ++ show i) + (\(a, rc) -> if rc == 1 + then Store (Map.delete i vm) (Set.insert i fs) (Set.delete i us) + else Store (Map.insert i (a, rc - 1) vm) fs us) + (Map.lookup i vm) diff --git a/hs/Interpreter.hs b/hs/Interpreter.hs new file mode 100644 index 0000000..46c7d8e --- /dev/null +++ b/hs/Interpreter.hs @@ -0,0 +1,481 @@ +{-# LANGUAGE DeriveFunctor, GeneralizedNewtypeDeriving, BangPatterns #-} +module Interpreter(interpret) where + +import Control.Monad.Except +import Control.Monad.State.Strict +import Control.Monad.Writer.Strict +import Data.List +import Data.Maybe +import qualified Data.Map.Strict as Map +import qualified Data.Set as Set + +-- import Debug.Trace + +import AST +import qualified GCStore as GCS + + +interpret :: Program -> (Maybe String, String, VM) -- (Maybe error, output, vm) +interpret prog = + let res = evaluateProgram prog >> liftM show get >>= tellLine :: ExMonad () + m1 = unExMonad res :: ExceptT String (WriterT String (State VM)) () + m2 = runExceptT m1 :: WriterT String (State VM) (Either String ()) + m3 = runWriterT m2 :: State VM (Either String (), String) + m4 = runState m3 makeVM :: ((Either String (), String), VM) + vm = snd m4 :: VM + merr = either Just (const Nothing) (fst (fst m4)) + output = snd (fst m4) + in (merr, output, vm) + + +type Scope = Map.Map Name GCS.Id + +data Value + = VNum Double + | VStr String + | VBlock BlockType ArgList Block + | VNil + deriving (Show) + +type ObjectStore = GCS.Store Value + +data VM = VM {scopeStack :: [Scope], + objStore :: ObjectStore, + tempValue :: Int} + deriving (Show) + +newtype ExMonad a = ExContext {unExMonad :: ExceptT String (WriterT String (State VM)) a} + deriving (Functor, Applicative, Monad, MonadState VM, MonadWriter String, MonadError String) + +typeNameOf :: Value -> String +typeNameOf (VNum _) = "Number" +typeNameOf (VStr _) = "String" +typeNameOf (VBlock _ _ _) = "Block" +typeNameOf VNil = "Nil" + +niceThrowError :: String -> ExMonad a +niceThrowError s = tellLine s >> throwError s + +getTopScope :: String -> ExMonad Scope +getTopScope mname = get >>= \(VM stk _ _) -> case stk of + [] -> niceThrowError $ mname ++ " on empty scope stack" + (sc:_) -> return sc + +modifyScopeStack :: ([Scope] -> [Scope]) -> ExMonad () +modifyScopeStack f = modify $ \vm@(VM stk _ _) -> vm {scopeStack = f stk} + +putScopeStack :: [Scope] -> ExMonad () +putScopeStack = modifyScopeStack . const + +modifyObjStore :: (ObjectStore -> ObjectStore) -> ExMonad () +modifyObjStore f = modify $ \vm@(VM _ os _) -> vm {objStore = f os} + +putObjStore :: ObjectStore -> ExMonad () +putObjStore = modifyObjStore . const + +modifyTempValue :: (Int -> Int) -> ExMonad () +modifyTempValue func = modify $ \vm -> vm {tempValue = func (tempValue vm)} + +getTempValue :: ExMonad Int +getTempValue = liftM tempValue get + +getRefCount :: GCS.Id -> ExMonad Int +getRefCount gcsid = get >>= \vm -> return (GCS.refcount (objStore vm) gcsid) + +derefTell :: GCS.Id -> ExMonad () +derefTell gcsid = do + get >>= \vm -> return (GCS.deref (objStore vm) gcsid) + >>= putObjStore + rc <- getRefCount gcsid + tellLine $ "GCS deref " ++ show gcsid ++ " -> rc=" ++ show rc + +cleanupScope :: Scope -> ExMonad () +cleanupScope sc = do + tellLine $ "## cleanupScope: " ++ show sc + mapM_ cleanupGcsid (Map.elems sc) + +cleanupGcsid :: GCS.Id -> ExMonad () +cleanupGcsid gcsid = do + vm <- get + case GCS.retrieve (objStore vm) gcsid of + Nothing -> niceThrowError $ "cleanupScope: gcsid " ++ show gcsid ++ " doesn't exist" + Just (VBlock _ _ b) -> cleanupBlock b + _ -> return () + derefTell gcsid + +cleanupBlock :: Block -> ExMonad () +cleanupBlock block = do + let idset = collectBlock block + mapM_ derefTell idset + +collectBlock :: Block -> Set.Set GCS.Id +collectBlock (Block sts) = foldl Set.union $ map collectStatement sts + +collectStatement :: Statement -> Set.Set GCS.Id +collectStatement (Declaration _ e) = collectExpression e +collectStatement (Assignment _ e) = collectExpression e +collectStatement (Condition e b1 b2) = + foldl Set.union [collectExpression e, collectBlock b1, collectBlock b2] +collectStatement (Dive _ es b) = + Set.union (foldl Set.union (map collectExpression es)) (collectBlock b) +collectStatement (Expr e) = collectExpression e + +collectExpression :: Expression -> Set.Set GCS.Id +collectExpression (EBin _ e1 e2) = Set.union (collectExpression e1) (collectExpression e2) +collectExpression (EUn _ e) = collectExpression e +collectExpression (ELit li) = collectLiteral li + +collectLiteral :: Literal -> Set.Set GCS.Id +collectLiteral (LBlock _ _ b) = collectBlock b +collectLiteral (LGCSId gcsid') = cleanupGcsid gcsid' +collectLiteral _ = return () + +cleanupValue :: Value -> Set.Set GCS.Id +cleanupValue (VBlock _ _ b) = cleanupBlock b +cleanupValue _ = return () + +pushScope :: ExMonad () +pushScope = tellLine "pushScope" >> modifyScopeStack (Map.empty :) + +popScope :: ExMonad () +popScope = do + vm <- get + case scopeStack vm of + [] -> niceThrowError $ "popScope on empty scope stack" + (sc:rest) -> do + cleanupScope sc + putScopeStack rest + tellLine "popScope" + +findVar :: Name -> ExMonad (Maybe (Int, GCS.Id, Value)) +findVar n = do + (VM stk os _) <- get + let mbs = map (\sc -> Map.lookup n sc) stk + dr = dropWhile isNothing mbs + gcsid = fromJust (head dr) -- not evaluated if dr == [] + if null dr + then return Nothing + else maybe (niceThrowError $ "findVar: gcsid " ++ show gcsid ++ " doesn't exist") return + (GCS.retrieve os gcsid) + >>= \value -> return (Just (length mbs - length dr, gcsid, value)) + +createVarInScope :: Scope -> ObjectStore -> Name -> Value -> ExMonad (Scope, ObjectStore) +createVarInScope sc os n val = + let (gcsid, os') = GCS.store os val + sc' = Map.insert n gcsid sc + in tellLine ("GCS store in " ++ show gcsid ++ " value " ++ show val) >> + if isNothing (Map.lookup n sc) + then return (sc', os') + else error $ "Var " ++ n ++ " already exists in createVarInScope" + +updateVarInScope :: Scope -> ObjectStore -> Name -> Value -> ExMonad ObjectStore +updateVarInScope sc os n val = do + let gcsid = maybe (error $ "Var " ++ n ++ " not found in updateVarInScope") id (Map.lookup n sc) + prev = maybe (error "Retrieve=Nothing in updateVarInScope") id (GCS.retrieve os gcsid) + cleanupValue prev + tellLine ("GCS update " ++ show gcsid ++ " to value " ++ show val) + return (GCS.update os gcsid val) + +createVarLocal :: Name -> Value -> ExMonad () +createVarLocal n val = do + vm <- get + let (VM (sc:rest) os _) = vm + (sc', os') <- createVarInScope sc os n val + put $ vm {scopeStack = sc' : rest, objStore = os'} + +updateVarAt :: Int -> Name -> Value -> ExMonad () +updateVarAt idx n val = do + vm <- get + let (VM stk os _) = vm + updateVarInScope (stk !! idx) os n val >>= putObjStore + +tellLine :: String -> ExMonad () +tellLine s = get >>= \vm -> + let lvl = length (scopeStack vm) + ind = if lvl >= 1 then take (4 * (lvl - 1)) (cycle "| ") else error "ZERO LEVEL" + in tell $ ind ++ replace "\n" ('\n' : ind) s ++ "\n" + +tellLineStandout :: String -> ExMonad () +tellLineStandout s = tell $ "\x1B[1m" ++ s ++ "\x1B[0m\n" + +replace :: String -> String -> String -> String +replace _ _ "" = "" +replace a b subj = + if take (length a) subj == a + then b ++ replace a b (drop (length a) subj) + else head subj : replace a b (tail subj) + + +makeVM :: VM +makeVM = VM [Map.empty] GCS.empty 0 + +evaluateProgram :: Program -> ExMonad () +evaluateProgram (Program (Block sts)) = mapM_ evStatement sts + +evStatement :: Statement -> ExMonad () +-- evStatement a | traceShow a False = unreachable +evStatement a = tellLine ("-# evStatement: " ++ astPretty a) >> evStatement' a + +evStatement' :: Statement -> ExMonad () +evStatement' (Declaration n e) = + getTopScope "evStatement" >>= + maybe (evExpression e >>= createVarLocal n) + (const $ niceThrowError $ "Variable " ++ n ++ " already exists in scope") + . Map.lookup n +evStatement' (Assignment n e) = + findVar n >>= + maybe (niceThrowError $ "Variable " ++ n ++ " assigned to but not found") + (\(idx, _, _) -> evExpression e >>= updateVarAt idx n) +evStatement' (Condition cond b1 b2) = + evExpression cond >>= truthValue >>= \bool -> evBlock $ if bool then b1 else b2 +evStatement' (Dive "print" al b) = do + (show <$> mapM evExpression al) >>= tellLineStandout + evBlock b +evStatement' (Dive n al b) = + findVar n >>= + maybe (niceThrowError $ "Variable " ++ n ++ " dived into but not found") + (\(_, _, value) -> case value of + (VBlock BT2 val vb) + | length al == length val -> do + pushScope + evBlockNoScope $ Block [Declaration dn de | (dn, de) <- zip val al] + evBlockNoScope vb + evBlockNoScope b + popScope + | otherwise -> + niceThrowError $ "Invalid number of arguments to dived-in block " ++ n + _ -> niceThrowError $ "Cannot dive into " ++ n ++ " of invalid type " ++ typeNameOf value) +evStatement' (Expr e) = evExpression e >>= cleanupValue + +evExpression :: Expression -> ExMonad Value +-- evExpression a | traceShow a False = unreachable +evExpression a = tellLine ("-# evExpression: " ++ astPretty a) >> evExpression' a + +evExpression' :: Expression -> ExMonad Value +evExpression' (EBin bo e1 e2) = evBO bo e1 e2 +evExpression' (EUn uo e) = evExpression e >>= evUO uo +evExpression' (ELit li) = evLiteral li + +evBlock :: Block -> ExMonad () +-- evBlock a | traceShow a False = unreachable +evBlock bl = do + pushScope + evBlockNoScope bl + popScope + +evBlockNoScope :: Block -> ExMonad () +evBlockNoScope a = tellLine ("-# evBlockNoScope: " ++ astPretty a) >> evBlockNoScope' a + +evBlockNoScope' :: Block -> ExMonad () +evBlockNoScope' (Block sts) = mapM_ evStatement sts + +evLiteral :: Literal -> ExMonad Value +evLiteral (LNum m) = return $ VNum m +evLiteral (LStr s) = return $ VStr s +evLiteral (LVar n) = + findVar n >>= maybe (niceThrowError $ "Variable " ++ n ++ " referenced but not found") (return . thrd) +evLiteral (LBlock BT0 al bl) + | length al == 0 = evBlock bl >> return VNil + | otherwise = niceThrowError $ "Immediately invoked block literal cannot have parameters" +evLiteral (LBlock bt al bl) = liftM (VBlock bt al) $ processBlock bl +evLiteral (LGCSId gcsid) = get >>= \(VM _ os _) -> maybe (niceThrowError $ "evLiteral: gcsid " ++ show gcsid ++ " doesn't exist") return (GCS.retrieve os gcsid) +evLiteral LNil = return VNil + +evUO :: UnaryOp -> Value -> ExMonad Value +evUO UONeg (VNum m) = return $ VNum (-m) +evUO UONeg value = niceThrowError $ "Operator '(-)' does not take a value of type " ++ typeNameOf value +evUO UONot value = (bool2VNum . not) <$> truthValue value + +classifyBO :: BinaryOp -> (Bool, Bool, Bool) +classifyBO bo = case bo of + BOPlus -> (True, f, f) + BOMinus -> (True, f, f) + BOMul -> (True, f, f) + BODiv -> (True, f, f) + BOMod -> (True, f, f) + BOPow -> (True, f, f) + BOLess -> (f, True, f) + BOGreater -> (f, True, f) + BOEqual -> (f, True, f) + BOLEq -> (f, True, f) + BOGEq -> (f, True, f) + BOBoolAnd -> (f, f, True) + BOBoolOr -> (f, f, True) + where f = False + +isArithBO, isCompBO {-, isBoolBO-} :: BinaryOp -> Bool +isArithBO bo = let (r, _, _) = classifyBO bo in r +isCompBO bo = let (_, r, _) = classifyBO bo in r +-- isBoolBO bo = let (_, _, r) = classifyBO bo in r + +evArithBO :: BinaryOp -> Double -> Double -> Double +evArithBO BOPlus = (+) +evArithBO BOMinus = (-) +evArithBO BOMul = (*) +evArithBO BODiv = (/) +evArithBO BOMod = \a b -> a - fromIntegral (floor (a / b) :: Integer) * b +evArithBO BOPow = (**) +evArithBO _ = unreachable + +evOrderingBO :: Ord a => BinaryOp -> a -> a -> Value +evOrderingBO bo a b = + let c = compare a b + in bool2VNum $ case bo of + BOLess -> c == LT + BOGreater -> c == GT + BOEqual -> c == EQ + BOLEq -> c == LT || c == EQ + BOGEq -> c == GT || c == EQ + _ -> unreachable + +evBO :: BinaryOp -> Expression -> Expression -> ExMonad Value +evBO bo e1 e2 + | isArithBO bo = evExpression e1 >>= \v1 -> evExpression e2 >>= \v2 -> case (v1, v2) of + (VNum m1, VNum m2) -> return $ VNum $ evArithBO bo m1 m2 + (_, _) -> niceThrowError $ "Operator '" ++ astPretty bo ++ "' does not take types " ++ + typeNameOf v1 ++ " and " ++ typeNameOf v2 + | isCompBO bo = evExpression e1 >>= \v1 -> evExpression e2 >>= \v2 -> case (v1, v2) of + (VNum m1, VNum m2) -> return $ evOrderingBO bo m1 m2 + (VStr s1, VStr s2) -> return $ evOrderingBO bo s1 s2 + (_, _) -> niceThrowError $ "Operator '" ++ astPretty bo ++ "' does not take types " ++ + typeNameOf v1 ++ " and " ++ typeNameOf v2 + | bo == BOBoolAnd = + evExpression e1 >>= truthValue >>= \v1 -> + if not v1 then return (VNum 0) + else evExpression e2 >>= truthValue >>= return . bool2VNum + | bo == BOBoolOr = + evExpression e1 >>= truthValue >>= \v1 -> + if v1 then return (VNum 1) + else evExpression e2 >>= truthValue >>= return . bool2VNum + | otherwise = unreachable + + +truthValue :: Value -> ExMonad Bool +truthValue (VNum 0) = return False +truthValue (VNum _) = return True +truthValue (VStr "") = return False +truthValue (VStr _) = return True +truthValue (VBlock _ _ _) = niceThrowError "Block not valid as truth value" +truthValue VNil = return False + +bool2VNum :: Bool -> Value +bool2VNum True = VNum 1 +bool2VNum False = VNum 0 + + +data ProcessState = ProcessState {psStack :: [Set.Set Name], psSet :: Set.Set GCS.Id} + +newtype ProcessMonad a = ProcessMonad {unProcessMonad :: State ProcessState a} + deriving (Functor, Applicative, Monad, MonadState ProcessState) + +pmModifyStack :: ([Set.Set Name] -> [Set.Set Name]) -> ProcessMonad () +pmModifyStack f = modify $ \ps@(ProcessState s _) -> ps {psStack = f s} + +pmModifyStackTop :: (Set.Set Name -> Set.Set Name) -> ProcessMonad () +pmModifyStackTop f = modify $ \ps@(ProcessState (s:ss) _) -> ps {psStack = f s : ss} + +pmModifySet :: (Set.Set GCS.Id -> Set.Set GCS.Id) -> ProcessMonad () +pmModifySet f = modify $ \ps@(ProcessState _ s) -> ps {psSet = f s} + +processBlockCollect :: [Scope] -> Block -> ProcessMonad Block +processBlockCollect gStack = goBlock + where + goBlock :: Block -> ProcessMonad Block + goBlock (Block sts) = do + pmModifyStack (Set.empty :) + b <- Block <$> mapM goStatement sts + pmModifyStack tail + return b + + goStatement :: Statement -> ProcessMonad Statement + goStatement (Declaration n e) = do + d <- Declaration n <$> goExpression e + pmModifyStackTop (Set.insert n) + return d + goStatement (Assignment n e) = Assignment n <$> goExpression e + goStatement (Condition e b1 b2) = Condition <$> goExpression e <*> goBlock b1 <*> goBlock b2 + goStatement (Dive n al b) = Dive n <$> mapM goExpression al <*> goBlock b + goStatement (Expr e) = Expr <$> goExpression e + + goExpression :: Expression -> ProcessMonad Expression + goExpression (EBin bo e1 e2) = EBin bo <$> goExpression e1 <*> goExpression e2 + goExpression (EUn uo e) = EUn uo <$> goExpression e + goExpression (ELit l) = ELit <$> goLiteral l + + goLiteral :: Literal -> ProcessMonad Literal + goLiteral (LVar name) = do + (ProcessState st _) <- get + let midx1 = findIndex (Set.member name) st + midx2 = findIndex (Map.member name) gStack + case (midx1, midx2) of + (Nothing, Nothing) -> return (LVar name) + (Just _, _) -> return (LVar name) + (Nothing, Just idx) -> + let gcsid = fromJust $ Map.lookup name (gStack !! idx) + in pmModifySet (Set.insert gcsid) >> return (LGCSId gcsid) + goLiteral (LBlock bt al bl) = LBlock bt al <$> goBlock bl + goLiteral (LGCSId gcsid) = do + pmModifySet (Set.insert gcsid) + return (LGCSId gcsid) + goLiteral l = return l + +processBlock :: Block -> ExMonad Block +processBlock block = do + tellLine ("## processBlock: " ++ astPretty block) + (VM stk os _) <- get + let (block', ProcessState _ psset) = + runState (unProcessMonad $ processBlockCollect stk block) + (ProcessState [] Set.empty) + let refitems = Set.toList psset + os' = foldl GCS.ref os psset + mapM_ (\gcsid -> tellLine ("GCS ref " ++ show gcsid)) refitems + putObjStore os' + return block' + +-- processBlock :: Block -> ExMonad Block +-- processBlock b = tellLine ("## processBlock: " ++ show b) >> modifyTempValue (const 0) >> goBlock b +-- where +-- goStatement :: Statement -> ExMonad Statement +-- goStatement (Declaration n e) = do +-- d <- Declaration n <$> goExpression e +-- createVarLocal n VNil +-- return d +-- goStatement (Assignment n e) = Assignment n <$> goExpression e +-- goStatement (Condition e b1 b2) = Condition <$> goExpression e <*> goBlock b1 <*> goBlock b2 +-- goStatement (Dive n al b') = Dive n <$> mapM goExpression al <*> goBlock b' +-- goStatement (Expr e) = Expr <$> goExpression e + +-- goBlock :: Block -> ExMonad Block +-- goBlock (Block sts) = do +-- pushScope +-- modifyTempValue succ +-- b' <- Block <$> mapM goStatement sts +-- modifyTempValue pred +-- popScope +-- return b' + +-- goExpression :: Expression -> ExMonad Expression +-- goExpression (EBin bo e1 e2) = EBin bo <$> goExpression e1 <*> goExpression e2 +-- goExpression (EUn uo e) = EUn uo <$> goExpression e +-- goExpression (ELit l) = ELit <$> goLiteral l + +-- goLiteral :: Literal -> ExMonad Literal +-- goLiteral (LVar name) = do +-- tv <- getTempValue +-- findVar name >>= +-- maybe (niceThrowError $ "Unknown variable " ++ name ++ " while processing block") +-- (\(idx, gcsid, _) -> +-- if idx >= tv +-- then modifyObjStore (\os -> GCS.ref os gcsid) +-- >> tellLine ("GCS ref " ++ show gcsid) +-- >> return (LGCSId gcsid) +-- else return (LVar name)) +-- goLiteral (LBlock bt al bl) = LBlock bt al <$> goBlock bl +-- goLiteral l = return l + + +thrd :: (a, b, c) -> c +thrd (_, _, c) = c + +unreachable :: a +unreachable = error "Unreachable" diff --git a/hs/Main.hs b/hs/Main.hs new file mode 100644 index 0000000..5db97ec --- /dev/null +++ b/hs/Main.hs @@ -0,0 +1,26 @@ +module Main where + +import Control.Monad +import System.Environment +import System.Exit + +-- import AST +import Interpreter +import Parser + + +main :: IO () +main = do + args <- getArgs + when (length args == 0) $ die "Pass source file as parameter" + let fname = head args + src <- readFile fname + let eprog = parseProgram (Just fname) src + prog <- either (die . show) return eprog + -- print prog + -- putStrLn $ astPretty prog + let (merr, output, _) = interpret prog + + maybe (putStrLn "[No errors]") (putStrLn . ("ERROR: " ++)) merr + putStrLn "OUTPUT:" + putStrLn output diff --git a/hs/Parser.hs b/hs/Parser.hs new file mode 100644 index 0000000..d37f1cd --- /dev/null +++ b/hs/Parser.hs @@ -0,0 +1,163 @@ +module Parser(parseProgram) where + +import Control.Monad +import Data.Char +import Text.Parsec +import qualified Text.Parsec.Expr as E + +import AST + + +type Parser = Parsec String () + + +(<<) :: (Monad m) => m a -> m b -> m a +(<<) = (<*) + +parseProgram :: Maybe String -> String -> Either ParseError Program +parseProgram fname src = parse pProgram (maybe "" id fname) src + +pProgram :: Parser Program +pProgram = (pWhiteComment >> ((Program . Block) <$> pStatement `sepBy` pWhiteComment)) << eof + +pStatement :: Parser Statement +pStatement = pCondition <|> pDeclarationAssignment <|> pDive <|> pExpressionStatement <?> "statement" + +pDeclarationAssignment :: Parser Statement +pDeclarationAssignment = (do + (n, constr) <- try $ do -- after we've seen the assignment operator, there's no turning back + n' <- pName + constr' <- (symbol ":=" >> return Declaration) <|> (symbol "=" >> return Assignment) + return (n', constr') + + e <- pExpression + symbol ";" <|> void (lookAhead (char '}')) + return $ constr n e) <?> "variable declaration or assignment" + +pCondition :: Parser Statement +pCondition = do + symbol "if" + cond <- pExpression + e1 <- pBlock + e2 <- (symbol "else" >> pBlock) <|> return (Block []) + return $ Condition cond e1 e2 + +pExpressionStatement :: Parser Statement +pExpressionStatement = (Expr <$> pExpression) << symbol ";" + +pDive :: Parser Statement +pDive = do + n <- try $ do + n' <- pName + void $ lookAhead (oneOf "({") + return n' + + al <- option [] $ between (symbol "(") (symbol ")") $ pExpression `sepBy` symbol "," + (symbol ";" >> return (Dive n al (Block []))) <|> (Dive n al <$> pBlock) + + +pExpression :: Parser Expression +pExpression = E.buildExpressionParser table pExpressionTerm + where + table = [[E.Prefix (symbol "-" >> return (EUn UONeg)), + E.Prefix (symbol "!" >> return (EUn UONot))], + [E.Infix (symbol "**" >> return (EBin BOPow)) E.AssocRight], + [E.Infix (symbol "*" >> return (EBin BOMul)) E.AssocLeft, + E.Infix (symbol "/" >> return (EBin BODiv)) E.AssocLeft, + E.Infix (symbol "%" >> return (EBin BOMod)) E.AssocLeft], + [E.Infix (symbol "+" >> return (EBin BOPlus)) E.AssocLeft, + E.Infix (symbol "-" >> return (EBin BOMinus)) E.AssocLeft], + [E.Infix (symbol "<=" >> return (EBin BOLEq)) E.AssocNone, + E.Infix (symbol ">=" >> return (EBin BOGEq)) E.AssocNone, + E.Infix (symbol "==" >> return (EBin BOEqual)) E.AssocNone, + E.Infix (symbol "<" >> return (EBin BOLess)) E.AssocNone, + E.Infix (symbol ">" >> return (EBin BOGreater)) E.AssocNone], + [E.Infix (symbol "&&" >> return (EBin BOBoolAnd)) E.AssocLeft, + E.Infix (symbol "||" >> return (EBin BOBoolOr)) E.AssocLeft]] + + pExpressionTerm :: Parser Expression + pExpressionTerm = pParenExpression <|> (ELit <$> pLiteral) + +pBlock :: Parser Block +pBlock = Block <$> between (symbol "{") (symbol "}") (many pStatement) + +pParenExpression :: Parser Expression +pParenExpression = between (symbol "(") (symbol ")") pExpression + +pLiteral :: Parser Literal +pLiteral = (pLNil <|> pLStr <|> pLNum <|> pLBlock <|> (LVar <$> pName) + <?> "literal") << pWhiteComment + +pLNil :: Parser Literal +pLNil = symbol "nil" >> return LNil + +pLBlock :: Parser Literal +pLBlock = (LBlock BT0 [] <$> pBlock) <|> do + symbol "??" + al <- option [] $ between (symbol "(") (symbol ")") $ pName `sepBy` symbol "," + b <- pBlock + return $ LBlock BT2 al b + +pLNum :: Parser Literal +pLNum = pDecimal <|> pHexa + where + pDecimal = do + pre <- many1 digit <|> (lookAhead (char '.') >> return "") + post <- ((:) <$> char '.' <*> many1 digit) <|> return "" + ex <- pExponent <|> return "" + return $ LNum $ read $ pre ++ post ++ ex + + pHexa = do + void $ string "0x" + pre <- many1 hexDigit + return $ LNum $ read $ "0x" ++ pre + + pExponent = do + void $ char 'e' + sgn <- (char '+' >> return "") <|> string "-" <|> return "" + dig <- many1 digit + return $ 'e' : sgn ++ dig + +pLStr :: Parser Literal +pLStr = LStr <$> between (char '"') (char '"') pStrContents + where + pStrContents = many pStrChar + pStrChar = (char '\\' >> pEscape) <|> noneOf "\"" + pEscape = (char 'n' >> return '\n') <|> + (char 'r' >> return '\r') <|> + (char 't' >> return '\t') <|> + char '"' <|> char '\\' + + +pName :: Parser Name +pName = do + c <- satisfy (isAlpha .||. (== '_')) + rest <- many (satisfy (isAlphaNum .||. (== '_'))) + pWhiteComment + return $ c : rest + + +pWhiteComment :: Parser () +pWhiteComment = void $ pWhite `sepBy` pComment + +pWhite :: Parser () +pWhite = void $ many (oneOf " \t\n") + +pComment :: Parser () +pComment = pLineComment <|> pBlockComment + +pLineComment :: Parser () +pLineComment = void $ try (string "//") >> manyTill anyChar (void (char '\n') <|> eof) + +pBlockComment :: Parser () +pBlockComment = void $ try (string "/*") >> manyTill anyChar (try (string "*/")) + +symbol :: String -> Parser () +symbol s = do + void $ try (string s) + when (not (null s) && isAlphaNum (last s)) $ notFollowedBy alphaNum + pWhiteComment + +infixr 2 .||. +(.||.) :: (a -> Bool) -> (a -> Bool) -> a -> Bool +f .||. g = \x -> f x || g x diff --git a/hs/ding.txt b/hs/ding.txt new file mode 100644 index 0000000..72ecd45 --- /dev/null +++ b/hs/ding.txt @@ -0,0 +1,237 @@ +VM +{ scopeStack = + [ fromList + [ ( "list_get" + , VBlock + BT2 + ["list", "idx"] + (Block + [ Condition + (EBin BOLess (ELit (LVar "idx")) (ELit (LNum 0.0))) + (Block + [ Dive + "throw_error" + [ELit (LStr "Negative index in 'list_get'")] + (Block []) + ]) + (Block []) + , Declaration "y" (ELit LNil) + , Dive + "list" + [] + (Block + [ Dive + "get_helper" + [ELit (LVar "front"), ELit (LVar "idx")] + (Block [Assignment "y" (ELit (LVar "x"))]) + ]) + , Declaration "x" (ELit (LVar "y")) + ])) + , ( "list_new" + , VBlock + BT2 + [] + (Block + [ Declaration + "x" + (ELit + (LBlock + BT0 + [] + (Block + [ Declaration "front" (ELit LNil) + , Declaration "back" (ELit LNil) + ]))) + ])) + , ( "list_pop_back" + , VBlock + BT2 + ["list"] + (Block + [ Declaration "x" (ELit LNil) + , Dive + "list" + [] + (Block + [ Condition + (EBin BOEqual (ELit (LVar "back")) (ELit LNil)) + (Block + [ Dive + "throw_error" + [ ELit + (LStr + "Call to 'list_pop_back' on empty list") + ] + (Block []) + ]) + (Block []) + , Dive + "back" + [] + (Block + [ Assignment "x" (ELit (LVar "value")) + , Assignment "back" (ELit (LVar "prev")) + ]) + , Condition + (EBin BOEqual (ELit (LVar "back")) (ELit LNil)) + (Block [Assignment "front" (ELit LNil)]) + (Block []) + ]) + ])) + , ( "list_pop_front" + , VBlock + BT2 + ["list"] + (Block + [ Declaration "x" (ELit LNil) + , Dive + "list" + [] + (Block + [ Condition + (EBin BOEqual (ELit (LVar "front")) (ELit LNil)) + (Block + [ Dive + "throw_error" + [ ELit + (LStr + "Call to 'list_pop_front' on empty list") + ] + (Block []) + ]) + (Block []) + , Dive + "front" + [] + (Block + [ Assignment "x" (ELit (LVar "value")) + , Assignment "front" (ELit (LVar "next")) + ]) + , Condition + (EBin BOEqual (ELit (LVar "front")) (ELit LNil)) + (Block [Assignment "back" (ELit LNil)]) + (Block []) + ]) + ])) + , ( "list_push_back" + , VBlock + BT2 + ["list", "item"] + (Block + [ Dive + "list" + [] + (Block + [ Condition + (EBin BOEqual (ELit (LVar "back")) (ELit LNil)) + (Block + [ Assignment + "front" + (ELit + (LBlock + BT0 + [] + (Block + [ Declaration + "value" + (ELit (LVar "item")) + , Declaration "next" (ELit LNil) + , Declaration "prev" (ELit LNil) + ]))) + , Assignment "back" (ELit (LVar "front")) + ]) + (Block + [ Assignment + "back" + (ELit + (LBlock + BT0 + [] + (Block + [ Declaration + "value" + (ELit (LVar "item")) + , Declaration "next" (ELit LNil) + , Declaration + "prev" + (ELit (LVar "back")) + ]))) + ]) + ]) + ])) + , ( "list_push_front" + , VBlock + BT2 + ["list", "item"] + (Block + [ Dive + "list" + [] + (Block + [ Condition + (EBin BOEqual (ELit (LVar "front")) (ELit LNil)) + (Block + [ Assignment + "front" + (ELit + (LBlock + BT0 + [] + (Block + [ Declaration + "value" + (ELit (LVar "item")) + , Declaration "next" (ELit LNil) + , Declaration "prev" (ELit LNil) + ]))) + , Assignment "back" (ELit (LVar "front")) + ]) + (Block + [ Assignment + "front" + (ELit + (LBlock + BT0 + [] + (Block + [ Declaration + "value" + (ELit (LVar "item")) + , Declaration + "next" + (ELit (LVar "front")) + , Declaration "prev" (ELit LNil) + ]))) + ]) + ]) + ])) + , ( "list_set" + , VBlock + BT2 + ["list", "idx", "val"] + (Block + [ Condition + (EBin BOLess (ELit (LVar "idx")) (ELit (LNum 0.0))) + (Block + [ Dive + "throw_error" + [ELit (LStr "Negative index in 'list_set'")] + (Block []) + ]) + (Block []) + , Dive + "list" + [] + (Block + [ Dive + "set_helper" + [ ELit (LVar "front") + , ELit (LVar "idx") + , ELit (LVar "val") + ] + (Block []) + ]) + ])) + ] + ] +} diff --git a/hs/file.squig b/hs/file.squig new file mode 100644 index 0000000..9de0d64 --- /dev/null +++ b/hs/file.squig @@ -0,0 +1,7 @@ +a := 2 * 3; +b := 4 / 5; +if a == 6 { + b = "yes"; +} else { + b = "no"; +} diff --git a/hs/list.squig b/hs/list.squig new file mode 100644 index 0000000..c5f468c --- /dev/null +++ b/hs/list.squig @@ -0,0 +1,132 @@ +list_new := ??{ + x := { + front := nil; + back := nil; + }; +}; + +list_push_front := ??(list, item){ + list { + if front == nil { + front = { + value := item; + next := nil; + prev := nil; + }; + back = front; + } else { + front = { + value := item; + next := front; + prev := nil; + }; + } + } +}; + +list_push_back := ??(list, item){ + list { + if back == nil { + front = { + value := item; + next := nil; + prev := nil; + }; + back = front; + } else { + back = { + value := item; + next := nil; + prev := back; + }; + } + } +}; + +list_pop_front := ??(list){ + x := nil; + list { + if front == nil { + throw_error("Call to 'list_pop_front' on empty list"); + } + front { + x = value; + front = next; + } + if front == nil { + back = nil; + } + } +}; + +list_pop_back := ??(list){ + x := nil; + list { + if back == nil { + throw_error("Call to 'list_pop_back' on empty list"); + } + back { + x = value; + back = prev; + } + if back == nil { + front = nil; + } + } +}; + +list_get := nil; +{ + get_helper := ??(front, idx){ + if front == nil { + throw_error("Index past end of list in 'list_get'"); + } + y := nil; + if idx == 0 { + front { + y = value; + } + } else { + front { + get_helper(next, idx - 1) {y = x;} + } + } + x := y; + }; + list_get = ??(list, idx){ + if idx < 0 { + throw_error("Negative index in 'list_get'"); + } + y := nil; + list { + get_helper(front, idx) {y = x;} + } + x := y; + }; +}; + +list_set := nil; +{ + set_helper := ??(front, idx, val){ + if front == nil { + throw_error("Index past end of list in 'list_set'"); + } + if idx == 0 { + front { + value = val; + } + } else { + front { + set_helper(next, idx - 1, val); + } + } + }; + list_set = ??(list, idx, val){ + if idx < 0 { + throw_error("Negative index in 'list_set'"); + } + list { + set_helper(front, idx, val); + } + }; +}; diff --git a/hs/notes.txt b/hs/notes.txt new file mode 100644 index 0000000..e935e44 --- /dev/null +++ b/hs/notes.txt @@ -0,0 +1,47 @@ +// { +// f := nil; +// { +// a := 1; +// f = ??{ +// print(a); +// }; +// f(); // print 1 +// a = 3; +// f(); // print 3 +// }; +// f(); // print 3 +// a := 2; +// f(); // print 3 +// }; // deref and delete f and a +// print("done"); + + +// -- new snippet + + +// f := ??{ +// print(a); // error: undefined variable 'a' +// }; +// a := 1; +// f(); + + +// -- new snippet + + +{ + a := 10; // 1 + f := nil; // 2 + { + a := 20; // 3 + f = ??{ + print(a); + g := ??{ + print(a); + }; + g(); + }; + f(); // -> 20 20 NOTE: the g is stored in 5 while 4 is available! + }; + f(); // -> 20 20 of 20 10? +}; diff --git a/hs/test.txt b/hs/test.txt new file mode 100644 index 0000000..1a2f551 --- /dev/null +++ b/hs/test.txt @@ -0,0 +1,11 @@ +{ + a := 10; + f := ??{ + print(a); + g := ??{ + print(a); + }; + // g(); + }; + f(); +}; |