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.0.7 : http://hagi.is.s.u-tokyo.ac.jp/~egi/egison/\nWelcome to Egison Interpreter!\n" +welcomeMsg = "Egison, version 1.1.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" @@ -264,7 +264,7 @@ | Function Environment FunPat Expression | Expression Expression | Macro FunPat Expression - | Loop String String Integer Integer Expression Expression + | Loop String String ObjectRef Expression Expression | Type Frame | DestructorFunction DestructInfo | BuiltinFunction ([Value] -> IOThrowsError Value) @@ -989,7 +989,7 @@ showValue (PredPat _ _) = return "#" showValue (Function _ _ _) = do return "#" -showValue (Loop _ _ _ _ _ _) = return "#" +showValue (Loop _ _ _ _ _) = return "#" showValue (Type _) = do return "#" showValue (DestructorFunction _) = do @@ -1052,7 +1052,7 @@ case maybeObjRef of Just objRef -> do val <- cEval1 objRef case val of - Loop _ _ _ _ _ _ -> eval1Loop env val + Loop _ _ _ _ _ -> eval1Loop env val Expression expr -> do liftIO $ putStrLn "here" eval1 env expr _ -> return val @@ -1100,13 +1100,8 @@ objRef <- liftIO (newIORef (Closure (frame:env) body)) cEval1 objRef eval1 env expr@(LoopExp (PatVarExp var1 []) (PatVarExp var2 []) rangeExpr expr1 expr2) = do - range <- eval env rangeExpr - case range of - Tuple [mObjRef,nObjRef] -> - do m <- objectRefToInteger mObjRef - n <- objectRefToInteger nObjRef - eval1Loop env (Loop var1 var2 m n expr1 expr2) - _ -> throwError (WithExpression "third arg of loop is not a range" expr) + range <- liftIO (makeClosure env rangeExpr) + eval1Loop env (Loop var1 var2 range expr1 expr2) eval1 env (TypeExp bind) = do frame <- makeRecursiveFrame env bind return (Type frame) @@ -1201,12 +1196,14 @@ evalValue val = return val eval1Loop :: Environment -> Value -> IOThrowsError Value -eval1Loop env (Loop var1 var2 m n expr1 expr2) = do - mObjRef <- liftIO (newIORef (Value (Integer m))) - if m > n - then do eval1 (([((var2,[]),mObjRef)]):env) expr2 - else do loopObjRef <- liftIO (newIORef (Value (Loop var1 var2 (m + 1) n expr1 expr2))) - eval1 ([((var1,[]),loopObjRef),((var2,[]),mObjRef)]:env) expr1 +eval1Loop env (Loop var1 var2 range expr1 expr2) = do + rVal <- cEval1 range + b <- isEmptyCollection rVal + if b + then do eval1 env expr2 + else do (carObjRef,cdrObjRef) <- consDestruct rVal + loopObjRef <- liftIO (newIORef (Value (Loop var1 var2 cdrObjRef expr1 expr2))) + eval1 ([((var1,[]),loopObjRef),((var2,[]),carObjRef)]:env) expr1 eval1Loop _ _ = throwError (Default "eval1Loop") evalInnerVals :: [InnerValue] -> IOThrowsError () @@ -1587,6 +1584,8 @@ "print" -> Just builtinPrint "read-char" -> Just builtinReadChar "write-char" -> Just builtinWriteChar + "=c" -> Just builtinEqualCharacter + "compare-character" -> Just builtinCompareCharacter "int-to-float" -> Just builtinIntToFloat "ceiling" -> Just builtinCeiling "floor" -> Just builtinFloor @@ -1659,6 +1658,21 @@ liftIO (putChar c) return (World ((Write (Character c)):actions)) builtinWriteChar _ = throwError (Default "invalid args to write-char") + + +builtinEqualCharacter :: [Value] -> IOThrowsError Value +builtinEqualCharacter [(Character c1), (Character c2)] = if (c1 == c2) + then return (InductiveData "true" []) + else return (InductiveData "false" []) +builtinEqualCharacter _ = throwError (Default "invalid args to =c") + +builtinCompareCharacter :: [Value] -> IOThrowsError Value +builtinCompareCharacter [(Character c1), (Character c2)] = if (c1 == c2) + then return (InductiveData "equal" []) + else if (c1 < c2) + then return (InductiveData "less" []) + else return (InductiveData "greater" []) +builtinCompareCharacter _ = throwError (Default "invalid args to compare-character") builtinIntToFloat :: [Value] -> IOThrowsError Value 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.0.7 +Version: 1.1.0 -- A short (one-line) description of the package. Synopsis: An Interpreter for the Programming Language Egison diff --git a/etc/lib/graph.egi b/etc/lib/graph.egi --- a/etc/lib/graph.egi +++ b/etc/lib/graph.egi @@ -20,12 +20,12 @@ (let {[$n (size g)]} (match-all g Graph [ _> - (loop $l $i [3 n] + (loop $l $i (between 3 n) _> l> _> _>)> - [@(loop $l $i [1 n] {a_i @l} {})] + [@(loop $l $i (between 1 n) {a_i @l} {})] ])))) (define $hamilton-path @@ -33,11 +33,11 @@ (let {[$n (size g)]} (match-all g Graph [ _> - (loop $l $i [3 n] + (loop $l $i (between 3 n) _> l> >)> - [@(loop $l $i [1 n] {a_i @l} {})] + [@(loop $l $i (between 1 n) {a_i @l} {})] ])))) diff --git a/etc/lib/number.egi b/etc/lib/number.egi --- a/etc/lib/number.egi +++ b/etc/lib/number.egi @@ -21,3 +21,9 @@ {[ {(- tgt 1)}] [_ {}]})]}]})] [$equal? (lambda [$val $tgt] (= val tgt))]})) + +(define $between + (lambda [$m $n] + (match (compare-integer m n) Order + {[ {m @(between (+ m 1) n)}] + [ {n}]}))) diff --git a/etc/sample/graph-test.egi b/etc/sample/graph-test.egi --- a/etc/sample/graph-test.egi +++ b/etc/sample/graph-test.egi @@ -10,7 +10,6 @@ }) - (test (match-all g Graph [ _> _> @@ -35,7 +34,6 @@ >>>>> [n1 n2 n3 n4 n5]])) - (test (hamilton-cycle g2))