diff --git a/egison.cabal b/egison.cabal --- a/egison.cabal +++ b/egison.cabal @@ -1,5 +1,5 @@ Name: egison -Version: 2.1.8 +Version: 2.1.9 Synopsis: An Interpreter for the Programming Language Egison Description: An interpreter for the programming language Egison. A feature of Egison is the strong pattern match facility. diff --git a/hs-src/Language/Egison/Core.hs b/hs-src/Language/Egison/Core.hs --- a/hs-src/Language/Egison/Core.hs +++ b/hs-src/Language/Egison/Core.hs @@ -709,7 +709,7 @@ case obj of Intermidiate (ITuple innerRefs) -> innerRefsToObjRefList innerRefs Value (Tuple innerVals) -> innerValsToObjRefList innerVals - _ -> throwError $ Default "tupleToObjRefList: not tuple" + _ -> return [objRef] innerRefsToObjRefList :: [InnerValRef] -> IOThrowsError [ObjectRef] innerRefsToObjRefList [] = return [] @@ -828,6 +828,9 @@ ("gt-f?", floatBoolBinop (>)), ("gte-f?", floatBoolBinop (>=)), + ("eq-c?", charBoolBinop (==)), + ("eq-s?", strBoolBinop (==)), + ("&&", boolBinop (&&)), ("||", boolBinop (||))] diff --git a/hs-src/Language/Egison/Numerical.hs b/hs-src/Language/Egison/Numerical.hs --- a/hs-src/Language/Egison/Numerical.hs +++ b/hs-src/Language/Egison/Numerical.hs @@ -1,30 +1,5 @@ -module Language.Egison.Numerical ( - boolBinop - , numericSglop - , floatSglop - , floatNumSglop - , numericBinop - , floatBinop - , numBoolBinop - , floatBoolBinop --- , foldlM --- , foldl1M - , floatFloor - , floatCeiling - , floatTruncate - , floatRound - , numExpt - , numSqrt - , numExp - , numLog --- , numToString --- , floatToString - , unpackBool - , unpackNum - , unpackFloat -) where +module Language.Egison.Numerical where import Language.Egison.Types - import Control.Monad.Error --import Data.Char hiding (isNumber) --import Data.Fixed @@ -55,13 +30,24 @@ floatBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal floatBinop op aparams = mapM unpackFloat aparams >>= return . Float . foldl1 op +charBoolBinop :: (Char -> Char -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal +charBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal +charBoolBinop op aparams = mapM unpackChar aparams >>= doOp + where doOp [a, b] = return $ Bool $ op a b + doOp _ = throwError $ Default "Unexpected error in numCharBinop" + +strBoolBinop :: (String -> String -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal +strBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal +strBoolBinop op aparams = mapM unpackString aparams >>= doOp + where doOp [a, b] = return $ Bool $ op a b + doOp _ = throwError $ Default "Unexpected error in numCharBinop" + numBoolBinop :: (Integer -> Integer -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal numBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal numBoolBinop op aparams = mapM unpackNum aparams >>= doOp where doOp [a, b] = return $ Bool $ op a b doOp _ = throwError $ Default "Unexpected error in numBoolBinop" - floatBoolBinop :: (Double -> Double -> Bool) -> [EgisonVal] -> ThrowsError EgisonVal floatBoolBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal floatBoolBinop op aparams = mapM unpackFloat aparams >>= doOp @@ -137,11 +123,23 @@ -- - end Numeric operations section --- |Extract an integer from the given value, throwing a type error if +-- |Extract an bool from the given value, throwing a type error if -- the wrong type is passed. unpackBool :: EgisonVal -> ThrowsError Bool unpackBool (Bool b) = return b unpackBool notBool = throwError $ TypeMismatch "bool" notBool + +-- |Extract an char from the given value, throwing a type error if +-- the wrong type is passed. +unpackChar :: EgisonVal -> ThrowsError Char +unpackChar (Char c) = return c +unpackChar notChar = throwError $ TypeMismatch "char" notChar + +-- |Extract an char from the given value, throwing a type error if +-- the wrong type is passed. +unpackString :: EgisonVal -> ThrowsError String +unpackString (String str) = return str +unpackString notString = throwError $ TypeMismatch "string" notString -- |Extract an integer from the given value, throwing a type error if -- the wrong type is passed. diff --git a/lib/core/base.egi b/lib/core/base.egi --- a/lib/core/base.egi +++ b/lib/core/base.egi @@ -26,22 +26,32 @@ (define $or (lambda [$b1 $b2] - (if b1 - #t - b2))) + (match b1 Bool + {[ #t] + [ b2]}))) (define $and (lambda [$b1 $b2] - (if b1 - b2 - #f))) + (match b1 Bool + {[ b2] + [ #f]}))) (define $not (lambda [$b] - (if b - #f - #t))) + (match b Bool + {[ #f] + [ #t]}))) +(define $Char + (type + {[$var-match (lambda [$tgt] {tgt})] + [$= eq-c?]})) + +(define $String + (type + {[$var-match (lambda [$tgt] {tgt})] + [$= eq-s?]})) + (define $Order (type {[$var-match (lambda [$tgt] {tgt})] @@ -63,4 +73,3 @@ [[ ] #t] [[ ] #t] [[_ _] #f]}))]})) - diff --git a/lib/core/number.egi b/lib/core/number.egi --- a/lib/core/number.egi +++ b/lib/core/number.egi @@ -16,6 +16,14 @@ {[$var-match (lambda [$tgt] {tgt})] [$= (lambda [$val $tgt] (eq-f? val tgt))]})) +(define $compare-float + (lambda [$d1 $d2] + (if (lt-f? d1 d2) + + (if (eq-f? d1 d2) + + )))) + (define $Nat (type {[$var-match (lambda [$tgt] {tgt})] @@ -24,7 +32,7 @@ {[o [] {[0 {[]}] [_ {}]}] - [s [Nat] + [s Nat {[$tgt (match (compare-integer tgt 0) Order {[ {(- tgt 1)}] [_ {}]})]}]})] @@ -56,6 +64,18 @@ (match (compare-integer n r) Order {[ n] [_ r]}))]}))) + +(define $min&max + (lambda [$ns] + (match ns (List Integer) + {[> [n n]] + [ + (let {[[$min-n $max-n] (min&max rs)]} + (match (compare-integer n min-n) Order + {[ [n max-n]] + [_ (match (compare-integer n max-n) Order + {[ [min-n n]] + [_ [min-n max-n]]})]}))]}))) (define $gcd (lambda [$ns] diff --git a/sample/io-test.egi b/sample/io-test.egi --- a/sample/io-test.egi +++ b/sample/io-test.egi @@ -12,7 +12,8 @@ (define $main (lambda [$: $argv] (do {[[$: $p] (open-output-file : "hello.txt")] - [$: (print-to-port : p "Hello world!")]} + [$: (print-to-port : p "Hello world!")] + [$: (close-output-port : p)]} :))) (define $main diff --git a/sample/number-test.egi b/sample/number-test.egi --- a/sample/number-test.egi +++ b/sample/number-test.egi @@ -9,7 +9,7 @@ (define $fact (lambda [$n] - (match n Nat + (match n [Nat] {[ 1] [ (* n (fact n1))]})))