summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--hs/.gitignore3
-rw-r--r--hs/AST.hs121
-rw-r--r--hs/GCStore.hs49
-rw-r--r--hs/Interpreter.hs481
-rw-r--r--hs/Main.hs26
-rw-r--r--hs/Parser.hs163
-rw-r--r--hs/ding.txt237
-rw-r--r--hs/file.squig7
-rw-r--r--hs/list.squig132
-rw-r--r--hs/notes.txt47
-rw-r--r--hs/test.txt11
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();
+};