diff --git a/Egison.hs b/Egison.hs --- a/Egison.hs +++ b/Egison.hs @@ -11,7 +11,7 @@ import Paths_egison welcomeMsg :: String -welcomeMsg = "Egison, version 1.1.1 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" +welcomeMsg = "Egison, version 1.2.0 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" byebyeMsg :: String byebyeMsg = "\nLeaving Egison.\nByebye. See you again! (^^)/\n" @@ -217,12 +217,13 @@ | CollectionExp [InnerExp] | WildCardExp | PatVarExp String [Expression] + | PatVarOmitExp Expression | CutPatExp Expression | AndPatExp [Expression] | OrPatExp [Expression] | PredPatExp String [Expression] | FunctionExp FunPat Expression - | MacroExp FunPat Expression + | MacroExp [String] Expression | DoExp Bind Expression | LetExp RecursiveBind Expression | LoopExp Expression Expression Expression Expression Expression @@ -277,7 +278,7 @@ | OrPat [ObjectRef] | Function Environment FunPat Expression | Expression Expression - | Macro FunPat Expression + | Macro [String] Expression | Loop String String ObjectRef Expression Expression | Type Frame | DestructorFunction DestructInfo @@ -620,6 +621,10 @@ ws <- word nums <- parseIndexNums return (PatVarExp ws nums)) + <|> do try (do char '$' + char '~' + expr <- parseExpression + return (PatVarOmitExp expr)) <|> do try (do char '#' ws <- word nums <- parseIndexNums @@ -666,7 +671,11 @@ return (FunctionExp args body) <|> do try (do string "macro" spaces1) - args <- parseFunPat + args <-brackets (do args2 <- sepEndBy (do char '$' + name <- word + return name) + spaces + return args2) spaces body <- parseExpression spaces @@ -871,12 +880,15 @@ showExpression (StringExp s) = "\"" ++ show s ++ "\"" showExpression (IntegerExp n) = show n showExpression (VariableExp name nums) = name ++ unwordsNums nums +showExpression (SymbolExp name nums) = "#" ++ name ++ unwordsNums nums +showExpression (OmitExp expr) = "~" ++ showExpression expr showExpression (InductiveDataExp s []) = "<" ++ s ++ ">" showExpression (InductiveDataExp s vs) = "<" ++ s ++ " " ++ unwordsList vs ++ ">" showExpression (TupleExp vs) = "[" ++ unwordsList vs ++ "]" showExpression (CollectionExp vs) = "{" ++ unwordsList vs ++ "}" showExpression WildCardExp = "_" showExpression (PatVarExp name nums) = "$" ++ name ++ unwordsNums nums +showExpression (PatVarOmitExp expr) = "$~" ++ showExpression expr showExpression (CutPatExp p) = "!" ++ show p showExpression (AndPatExp ps) = "(& " ++ unwordsList ps ++ ")" showExpression (OrPatExp ps) = "(| " ++ unwordsList ps ++ ")" @@ -1122,6 +1134,11 @@ eval1 env (PatVarExp name numExprs) = do numVals <- evalList env numExprs return (PatVar name (integerValListToIntegerList numVals)) +eval1 env (PatVarOmitExp expr) = do + val <- eval1 env expr + case val of + Symbol name nums -> return (PatVar name nums) + _ -> throwError (Default "argument of omit is not symbol") eval1 env (PredPatExp name exprs) = do objRefs <- liftIO (makeClosureList env exprs) return (PredPat name objRefs) @@ -1145,7 +1162,7 @@ frame <- makeRecursiveFrame env bind objRef <- liftIO (newIORef (Closure (frame:env) body)) cEval1 objRef -eval1 env expr@(LoopExp (PatVarExp var1 []) (PatVarExp var2 []) rangeExpr expr1 expr2) = do +eval1 env (LoopExp (PatVarExp var1 []) (PatVarExp var2 []) rangeExpr expr1 expr2) = do range <- liftIO (makeClosure env rangeExpr) eval1Loop env (Loop var1 var2 range expr1 expr2) eval1 env (TypeExp bind) = do @@ -1182,14 +1199,66 @@ frame <- makeFrame fpat arg objRef <- liftIO (makeClosure (frame:funEnv) body) cEval1 objRef - Macro fpat body -> do argsObjRefs <- liftIO (makeExpressionList argsExps) - arg <- liftIO (newIORef (Value (Tuple argsObjRefs))) - frame <- makeFrame fpat arg - objRef <- liftIO (makeClosure (frame:env) body) - cEval1 objRef + Macro vars body -> let body2 = expandMacro (zip vars argsExps) body in + eval1 env body2 _ -> throwError (WithExpression "applying non-functional object" expr) +type MFrame = [(String, Expression)] +searchMFrame :: MFrame -> String -> Maybe Expression +searchMFrame [] _ = Nothing +searchMFrame ((name,expr):rest) varName = if name == varName + then Just expr + else searchMFrame rest varName + +expandMacro :: MFrame -> Expression -> Expression +expandMacro mf (VariableExp name []) = + case searchMFrame mf name of + Nothing -> VariableExp name [] + Just expr -> expr +expandMacro mf (VariableExp name numExprs) = VariableExp name (mapExpandMacro mf numExprs) +expandMacro mf (SymbolExp name numExprs) = SymbolExp name (mapExpandMacro mf numExprs) +expandMacro mf (OmitExp expr) = OmitExp (expandMacro mf expr) +expandMacro mf (InductiveDataExp cons exprs) = InductiveDataExp cons (mapExpandMacro mf exprs) +expandMacro mf (TupleExp innerExprs) = TupleExp (mapExpandMacroInnerExp mf innerExprs) +expandMacro mf (CollectionExp innerExprs) = CollectionExp (mapExpandMacroInnerExp mf innerExprs) +expandMacro mf (PatVarExp name numExprs) = PatVarExp name (mapExpandMacro mf numExprs) +expandMacro mf (PatVarOmitExp expr) = PatVarOmitExp (expandMacro mf expr) +expandMacro mf (CutPatExp expr) = CutPatExp (expandMacro mf expr) +expandMacro mf (AndPatExp exprs) = AndPatExp (mapExpandMacro mf exprs) +expandMacro mf (OrPatExp exprs) = OrPatExp (mapExpandMacro mf exprs) +expandMacro mf (PredPatExp name exprs) = PredPatExp name (mapExpandMacro mf exprs) +expandMacro mf (FunctionExp fpat body) = FunctionExp fpat (expandMacro mf body) +expandMacro mf (MacroExp vars body) = MacroExp vars (expandMacro mf body) +expandMacro mf (DoExp bind body) = undefined +expandMacro mf (LetExp bind body) = undefined +expandMacro mf (LoopExp lVar iVar rangeExp inExp outExp) = + LoopExp (expandMacro mf lVar) (expandMacro mf iVar) (expandMacro mf rangeExp) (expandMacro mf inExp) (expandMacro mf outExp) +expandMacro mf (TypeExp bind) = undefined +expandMacro mf (TypeRefExp tExp name) = TypeRefExp (expandMacro mf tExp) name +expandMacro mf (DestructorExp deconsInfo) = undefined +expandMacro mf (MatchExp tgtExp typExp clsExps) = MatchExp (expandMacro mf tgtExp) (expandMacro mf typExp) (mapExpandMacroMatchClause mf clsExps) +expandMacro mf (MatchAllExp tgtExp typExp clsExp) = MatchAllExp (expandMacro mf tgtExp) (expandMacro mf typExp) (expandMacroMatchClause mf clsExp) +expandMacro mf (ApplyExp fnExp argsExp) = ApplyExp (expandMacro mf fnExp) (expandMacro mf argsExp) +expandMacro mf (ApplyListExp fnExp argsExps) = ApplyListExp (expandMacro mf fnExp) (mapExpandMacro mf argsExps) +expandMacro _ expr = expr + +mapExpandMacro :: MFrame -> [Expression] -> [Expression] +mapExpandMacro mf exprs = map (\expr -> expandMacro mf expr) exprs + +expandMacroMatchClause :: MFrame -> MatchClause -> MatchClause +expandMacroMatchClause mf (MatchClause patExp body) = MatchClause (expandMacro mf patExp) (expandMacro mf body) + +mapExpandMacroMatchClause :: MFrame -> [MatchClause] -> [MatchClause] +mapExpandMacroMatchClause mf mClss = map (\mCls -> expandMacroMatchClause mf mCls) mClss + +mapExpandMacroInnerExp :: MFrame -> [InnerExp] -> [InnerExp] +mapExpandMacroInnerExp mf innerExps = map (\innerExp -> expandMacroInnerExp mf innerExp) innerExps + +expandMacroInnerExp :: MFrame -> InnerExp -> InnerExp +expandMacroInnerExp mf (ElementExp expr) = ElementExp (expandMacro mf expr) +expandMacroInnerExp mf (SubCollectionExp expr) = SubCollectionExp (expandMacro mf expr) + eval :: Environment -> Expression -> IOThrowsError Value eval env expr = do objRef <- liftIO (makeClosure env expr) @@ -1323,9 +1392,7 @@ Value (Tuple pats) -> do tgts <- tupleToObjRefList tgtObjRef typs <- tupleToObjRefList typObjRef - if length3 pats tgts typs - then patternMatch1 ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states) - else throwError (Default "patternMatch1: the number of pats, tgts, and typs are different of Tuple") + patternMatch1 ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states) Value (InductiveData con pats) -> do typVal <- cEval1 typObjRef case typVal of @@ -1342,14 +1409,9 @@ do inTypObjRefs <- tupleToObjRefList nTypObjRef inTgtsRefs <- collectionObjToObjRefList nTgtsObjRef inTgtObjRefss <- tupleObjRefListToListOfList inTgtsRefs - patternMatch ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) - pats inTgtObjRefs inTypObjRefs) ++ atoms))) - inTgtObjRefss) ++ states) --- if length3 pats inTgtsRefs inTypObjRefs --- then patternMatch1 ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) --- pats inTgtObjRefs inTypObjRefs) ++ atoms))) --- inTgtObjRefss) ++ states) --- else throwError (Default "patternMatch1: the number of pats, tgts, and typs are different of InductiveData") + patternMatch1 ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) + pats inTgtObjRefs inTypObjRefs) ++ atoms))) + inTgtObjRefss) ++ states) _ -> throwError (Default "patternMatch1: inductive-match is not destructor") Value (PredPat predName pats) -> do typVal <- cEval1 typObjRef @@ -1413,9 +1475,7 @@ Value (Tuple pats) -> do tgts <- tupleToObjRefList tgtObjRef typs <- tupleToObjRefList typObjRef - if length3 pats tgts typs - then patternMatch ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states) - else throwError (Default "patternMatch: the number of pats, tgts, and typs are different") + patternMatch ((MState frame ((map3 (\(pat,tgt,typ) -> (MAtom (PClosure bf pat) tgt typ)) pats tgts typs) ++ atoms)):states) Value (InductiveData con pats) -> do typVal <- cEval1 typObjRef case typVal of @@ -1433,13 +1493,8 @@ inTgtsRefs <- collectionObjToObjRefList nTgtsObjRef inTgtObjRefss <- tupleObjRefListToListOfList inTgtsRefs patternMatch ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) - pats inTgtObjRefs inTypObjRefs) ++ atoms))) - inTgtObjRefss) ++ states) --- if length3 pats inTgtsRefs inTgtsRefs --- then patternMatch ((map (\inTgtObjRefs -> (MState frame ((map3 (\(pat,inTgtObjRef,inTypObjRef) -> (MAtom (PClosure bf pat) inTgtObjRef inTypObjRef)) --- pats inTgtObjRefs inTypObjRefs) ++ atoms))) --- inTgtObjRefss) ++ states) --- else throwError (Default "patternMatch: the number of pats, tgts, and typs are different") + pats inTgtObjRefs inTypObjRefs) ++ atoms))) + inTgtObjRefss) ++ states) _ -> throwError (Default "patternMatch: inductive-match is not destructor") Value (PredPat predName pats) -> do typVal <- cEval1 typObjRef @@ -1483,12 +1538,6 @@ return retVal _ -> throwError (Default "cApply: not a function") - -length3 :: [a] -> [b] -> [c] -> Bool -length3 [] [] [] = True -length3 (_:xs) (_:ys) (_:zs) = length3 xs ys zs -length3 _ _ _ = False - map3 :: ((a,b,c) -> d) -> [a] -> [b] -> [c] -> [d] map3 fn [] [] [] = [] map3 fn (x:xs) (y:ys) (z:zs) = (fn (x,y,z)):(map3 fn xs ys zs) diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 1.1.1 +Version: 1.2.0 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison