Merge ../scheme

test.sh

@@ -0,0 +1,38 @@
+#!/usr/bin/env zsh
+
+typeset -a listfic
+if (($#==0)); then
+    listfic=( tests/*(.N) )
+else
+    for arg in $@; do
+        listfic=( $listfic tests/$arg )
+    done
+fi
+
+tmpfic=tests/tmp
+for input in $listfic; do
+    sed 's/\\/\\\\/g' $input > $tmpfic
+    # set 3 as the file descriptor for the file $tmpfic
+    exec 3< $tmpfic
+    done=0
+    num=1
+    until ((done == 1)); do
+        read <&3 program
+        (($?!=0)) && {done=1;continue}
+        read <&3 expected
+        (($?!=0)) && {done=1;continue}
+        result="$(runghc y.hs "$program")"
+        printf "%18s (line %3d): " ${input:t} $num
+        if [[ $expected == $result ]]; then
+            print -- "OK"
+        else
+	        print -- "ERROR"
+            print -- "   program: '$program'"
+            print -- "  expected: '$expected'"
+            print -- "       got: '$result'"
+            print -- ""
+        fi
+        ((num+=2))
+    done
+done
+\rm -f $tmpfic

tests/binarynumber

@@ -0,0 +1,6 @@
+32
+32
+#x012
+18
+#b001010
+10

tests/char

@@ -0,0 +1,2 @@
+#\a
+'a'

tests/float

@@ -0,0 +1,2 @@
+3.14
+3.14

tests/number

@@ -0,0 +1,2 @@
+32
+32

tests/string

@@ -0,0 +1,6 @@
+"This is a simple string"
+"This is a simple string"
+"A tab ->\t<- Here"
+"A tab ->	<- Here"
+"\S\o\m\e\ \pr\ot\e\ct\e\d\ \w\it\h\ \\"
+"Some protected with \"

y.hs

@@ -0,0 +1,185 @@
+module Main where
+
+import Control.Monad (liftM)
+import Data.List (foldl')
+import Text.ParserCombinators.Parsec hiding (spaces)
+import System.Environment   (getArgs)
+
+-- The possible LISP values
+data LispVal = Atom         String
+             | List         [LispVal]
+             | DottedList   [LispVal] LispVal
+             | Float        Float
+             | Number       Integer
+             | Character    Char
+             | String       String
+             | Bool         Bool
+
+-- The program (in IO)
+-- execute the arguments given in parameters
+main :: IO ()
+main = getArgs >>= print . eval . readExpr . head
+
+-- ReadExpr will take a program as input
+-- and will return the result of a parseExpr
+readExpr :: String -> LispVal
+readExpr input = case parse parseExpr "lisp" input of
+                    Left  err -> String $ "No match: " ++ show err
+                    Right val -> val
+
+showVal :: LispVal -> String
+showVal (String contents) = "\"" ++ contents ++ "\""
+showVal (Atom name) = name
+showVal (Number contents) = show contents
+showVal (Float contents) = show contents
+showVal (Character c) = '\'':c:'\'':[]
+showVal (Bool True) = "#t"
+showVal (Bool False) = "#f"
+showVal (List contents) = "(" ++ unwordsList contents ++ ")"
+showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
+
+unwordsList :: [LispVal] -> String
+unwordsList = unwords . map showVal
+
+instance Show LispVal where show = showVal
+
+-- parseExpr will parse the Expression
+parseExpr :: Parser LispVal
+parseExpr = parseString
+        <|> try parseChar   -- #\a #\b etc...
+        <|> try parseFloat  -- 3.1415
+        <|> parseNumber     -- 3, #b011001, #o070, #d930, #xFF3
+        <|> parseAtom       -- symbol-323
+        <|> parseQuoted
+        <|> do
+                char '('
+                x <- try parseList <|> parseDottedList
+                char ')'
+                return x
+
+symbol :: Parser Char
+symbol = oneOf "!#$%&|*+-/:<=>?@^_~"
+
+spaces :: Parser ()
+spaces = skipMany1 space
+
+parseChar :: Parser LispVal
+parseChar = do
+    string "#\\"
+    c <- anyChar
+    return $ Character c
+
+parseString :: Parser LispVal
+parseString = do
+    char '"'
+    x <- many $ strSpecialChar <|> noneOf "\""
+    char '"'
+    return $ String x
+    where
+        strSpecialChar = char '\\' >> do
+            x <- anyChar
+            case x of
+                'n' -> return '\n'
+                't' -> return '\t'
+                'r' -> return '\r'
+                _   -> return x
+
+parseAtom :: Parser LispVal
+parseAtom = do
+    first <- letter <|> symbol
+    rest <- many (letter <|> digit <|> symbol)
+    let atom = first:rest
+    return $ case atom of
+                "#vrai" -> Bool True
+                "#faux" -> Bool False
+                _       -> Atom atom
+
+numFromBase n str = foldl' traiteNombre 0 str
+    where
+        traiteNombre acc v = acc*n + chiffre
+            where chiffre = case v of
+                            '0' -> 0
+                            '1' -> 1
+                            '2' -> 2
+                            '3' -> 3
+                            '4' -> 4
+                            '5' -> 5
+                            '6' -> 6
+                            '7' -> 7
+                            '8' -> 8
+                            '9' -> 9
+                            'A' -> 10
+                            'B' -> 11
+                            'C' -> 12
+                            'D' -> 13
+                            'E' -> 14
+                            'F' -> 15
+                            'a' -> 10
+                            'b' -> 11
+                            'c' -> 12
+                            'd' -> 13
+                            'e' -> 14
+                            'f' -> 15
+
+parseBaseSpecifiedNumber :: Parser Integer
+parseBaseSpecifiedNumber = do
+    _ <- char '#'
+    numtype <- oneOf "bdox"
+    (base,str) <- case numtype of
+                    'b' -> do
+                        numstr <- many1 (oneOf "01")
+                        return (2,numstr)
+                    'o' -> do
+                        numstr <- many1 (oneOf "01234567")
+                        return (8,numstr)
+                    'd' -> do
+                        numstr <- many1 (oneOf "0123456789")
+                        return (10,numstr)
+                    'x' -> do
+                        numstr <- many1 (oneOf "0123456789ABCDEFabcdef")
+                        return (16,numstr)
+    return $ numFromBase base str
+
+parseSimpleNumber :: Parser Integer
+parseSimpleNumber = do
+    numStr <- many1 digit
+    return (read numStr)
+
+parseFloat :: Parser LispVal
+parseFloat = do
+    numBeforeDot <- many1 digit
+    char '.'
+    numAfterDot <- many1 digit
+    return $ Float (read (numBeforeDot ++ "." ++ numAfterDot))
+
+parseNumber :: Parser LispVal
+parseNumber = do
+    number <-     parseSimpleNumber
+              <|> parseBaseSpecifiedNumber
+    return (Number number)
+
+-- Recursive Parsers
+
+parseList :: Parser LispVal
+parseList = liftM List $ sepBy parseExpr spaces
+
+parseDottedList :: Parser LispVal
+parseDottedList = do
+    head <- endBy parseExpr spaces
+    tail <- char '.' >> spaces >> parseExpr
+    return $ DottedList head tail
+
+parseQuoted :: Parser LispVal
+parseQuoted = do
+    char '\''
+    x <- parseExpr
+    return $ List [Atom "quote", x]
+
+-- Evaluation
+eval :: LispVal -> LispVal
+eval val@(Character _) = val
+eval val@(String _) = val
+eval val@(Number _) = val
+eval val@(Float _) = val
+eval val@(Bool _) = val
+eval (List [Atom "quote", val]) = val