diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -31,8 +31,10 @@ - Hash tables, as specified by [SRFI 69](http://srfi.schemers.org/srfi-69/srfi-69.html) -husk scheme is available under the [MIT license](http://www.opensource.org/licenses/mit-license.php). +And the following R7RS draft features: +- Nested block comments using `#|` and `|#` + Installation ------------ husk may be easily installed using [cabal](http://www.haskell.org/cabal/) - just run the following command: @@ -97,6 +99,11 @@ The `examples` directory contains example scheme programs. Patches are welcome; please send via pull request on github. + +License +------- + +husk scheme is available under the [MIT license](http://www.opensource.org/licenses/mit-license.php). Credits ------- diff --git a/hs-src/Language/Scheme/Core.hs b/hs-src/Language/Scheme/Core.hs --- a/hs-src/Language/Scheme/Core.hs +++ b/hs-src/Language/Scheme/Core.hs @@ -148,7 +148,11 @@ eval env cont val@(Number _) = continueEval env cont val eval env cont val@(Bool _) = continueEval env cont val eval env cont val@(HashTable _) = continueEval env cont val -eval env cont val@(Vector _) = continueEval env cont val +eval env cont val@(Vector _) = do + -- TODO: Issue #35 - not good enough to just return, need to ensure only constants (?) are part + -- of the vector + continueEval env cont val +-- throwError $ Default $ "Illegal expression (should be quoted): " ++ show val eval env cont (Atom a) = continueEval env cont =<< getVar env a -- Quote an expression by simply passing along the value @@ -262,49 +266,6 @@ case result of Bool True -> macroEval e conseq >>= eval e c _ -> continueEval e c $ Nil "" -- Unspecified return value per R5RS - -{- OBSOLETE: --- TODO: convert cond to a derived form (scheme macro) --- TODO: is the 'bound' code below good enough? need to test w/else redefined. --- if not good enough, may just need to go all the way and rewrite all of this as a macro! -eval env cont args@(List (Atom "cond" : clauses)) = do - bound <- liftIO $ isBound env "cond" - if bound - then prepareApply env cont args -- if is bound to a variable in this scope; call into it - else if length clauses == 0 - then throwError $ BadSpecialForm "No matching clause" $ String "cond" - else do - case (clauses !! 0) of - List [test, Atom "=>", expr] -> eval env (makeCPSWArgs env cont cpsAlt [test]) expr - List (Atom "else" : _) -> eval env (makeCPSWArgs env cont cpsResult clauses) $ Bool True - List (cond : _) -> eval env (makeCPSWArgs env cont cpsResult clauses) cond - badType -> throwError $ TypeMismatch "clause" badType - where - { - If a condition is true, evaluate that condition's expressions. - Otherwise just pick up at the next condition... - } - cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsResult e cnt result (Just (c : cs)) = - case result of - Bool True -> evalCond e cnt c - _ -> eval env cnt $ List $ (Atom "cond" : cs) - cpsResult _ _ _ _ = throwError $ Default "Unexpected error in cond" - - -- Helper function for evaluating 'cond' - evalCond :: Env -> LispVal -> LispVal -> IOThrowsError LispVal - evalCond e c (List [_, expr]) = eval e c expr - evalCond e c (List (_ : expr)) = eval e c $ List (Atom "begin" : expr) - evalCond _ _ badForm = throwError $ BadSpecialForm "evalCond: Unrecognized special form" badForm - - -- Alternate "=>" form: expr was evaluated, now eval test - cpsAlt :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsAlt e c expr (Just [test]) = eval e (makeCPSWArgs e c cpsAltEvaled [expr]) test - cpsAlt _ _ _ _ = throwError $ Default "Unexpected error in cond" - - -- Alternate "=>" form: both test/expr are evaluated, now eval the form itself - cpsAltEvaled :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsAltEvaled _ c test (Just [expr]) = apply c expr [test] - cpsAltEvaled _ _ _ _ = throwError $ Default "Unexpected error in cond" --} eval env cont fargs@(List (Atom "begin" : funcs)) = do bound <- liftIO $ isBound env "begin" diff --git a/hs-src/Language/Scheme/Macro.hs b/hs-src/Language/Scheme/Macro.hs --- a/hs-src/Language/Scheme/Macro.hs +++ b/hs-src/Language/Scheme/Macro.hs @@ -41,7 +41,7 @@ import Language.Scheme.Variables import Control.Monad.Error import Data.Array -import Debug.Trace -- Only req'd to support trace, can be disabled at any time... +--import Debug.Trace -- Only req'd to support trace, can be disabled at any time... {- Nice FAQ regarding macro's, points out some of the limitations of current implementation http://community.schemewiki.org/?scheme-faq-macros -} diff --git a/hs-src/Language/Scheme/Parser.hs b/hs-src/Language/Scheme/Parser.hs --- a/hs-src/Language/Scheme/Parser.hs +++ b/hs-src/Language/Scheme/Parser.hs @@ -23,18 +23,36 @@ import Numeric import Ratio import Text.ParserCombinators.Parsec hiding (spaces) +import Text.Parsec.Language +import qualified Text.Parsec.Token as P -symbol :: Parser Char -symbol = oneOf "!$%&|*+-/:<=>?@^_~" +lispDef :: LanguageDef () +lispDef + = emptyDef + { P.commentStart = "#|" + , P.commentEnd = "|#" + , P.commentLine = ";" + , P.nestedComments = True + , P.identStart = letter <|> symbol + , P.identLetter = letter <|> digit <|> symbol + , P.reservedNames = [] + , P.caseSensitive = True + } -spaces :: Parser () -spaces = skipMany1 space +lexer = P.makeTokenParser lispDef +dot = P.dot lexer +parens = P.parens lexer +identifier = P.identifier lexer +-- TODO: typedef. starting point was: whiteSpace :: CharParser () +whiteSpace = P.whiteSpace lexer +lexeme = P.lexeme lexer +symbol :: Parser Char +symbol = oneOf "!$%&|*+-/:<=>?@^_~." + parseAtom :: Parser LispVal parseAtom = do - first <- letter <|> symbol <|> (oneOf ".") - rest <- many (letter <|> digit <|> symbol <|> (oneOf ".")) - let atom = first : rest + atom <- identifier if atom == "." then pzero -- Do not match this form else return $ Atom atom @@ -109,7 +127,7 @@ - -} parseRealNumber :: Parser LispVal parseRealNumber = do - sign <- many (oneOf "-") + sign <- many (oneOf "-+") num <- many1 (digit) _ <- char '.' frac <- many1 (digit) @@ -126,7 +144,12 @@ -- 'e' -> return $ Float $ numbr _ -> return $ Float $ numbr return $ Float $ fst $ Numeric.readFloat dec !! 0 -} - 1 -> return $ Float $ (*) (-1.0) $ fst $ Numeric.readFloat dec !! 0 + +-- TODO: this is a hack, but need to support the + sign as well as the minus. + + 1 -> if sign == "-" + then return $ Float $ (*) (-1.0) $ fst $ Numeric.readFloat dec !! 0 + else return $ Float $ fst $ Numeric.readFloat dec !! 0 _ -> pzero parseRationalNumber :: Parser LispVal @@ -180,86 +203,80 @@ parseVector :: Parser LispVal parseVector = do - vals <- sepBy parseExpr spaces + vals <- sepBy parseExpr whiteSpace return $ Vector (listArray (0, (length vals - 1)) vals) parseList :: Parser LispVal -parseList = liftM List $ sepBy parseExpr spaces +parseList = liftM List $ sepBy parseExpr whiteSpace +-- TODO: wanted to use endBy (or a variant) above, but it causes an error such that dotted lists are not parsed parseDottedList :: Parser LispVal parseDottedList = do - phead <- endBy parseExpr spaces - ptail <- char '.' >> spaces >> parseExpr + phead <- endBy parseExpr whiteSpace + ptail <- dot >> parseExpr --char '.' >> whiteSpace >> parseExpr return $ DottedList phead ptail parseQuoted :: Parser LispVal parseQuoted = do - _ <- char '\'' + _ <- lexeme $ char '\'' x <- parseExpr return $ List [Atom "quote", x] parseQuasiQuoted :: Parser LispVal parseQuasiQuoted = do - _ <- char '`' + _ <- lexeme $ char '`' x <- parseExpr return $ List [Atom "quasiquote", x] parseUnquoted :: Parser LispVal parseUnquoted = do - _ <- try (char ',') + _ <- try (lexeme $ char ',') x <- parseExpr return $ List [Atom "unquote", x] parseUnquoteSpliced :: Parser LispVal parseUnquoteSpliced = do - _ <- try (string ",@") + _ <- try (lexeme $ string ",@") x <- parseExpr return $ List [Atom "unquote-splicing", x] - -{- Comment parser -FUTURE: this is a hack, it should really not return anything... -a better solution might be to use a tokenizer as a -parser instead; need to investigate eventually. -} -parseComment :: Parser LispVal -parseComment = do - _ <- char ';' - _ <- many (noneOf ("\n")) - return $ Nil "" - - parseExpr :: Parser LispVal parseExpr = - try (parseComplexNumber) - <|> try (parseRationalNumber) - <|> parseComment - <|> try (parseRealNumber) - <|> try (parseNumber) - <|> parseChar + try (lexeme parseComplexNumber) + <|> try (lexeme parseRationalNumber) + <|> try (lexeme parseRealNumber) + <|> try (lexeme parseNumber) + <|> lexeme parseChar <|> parseUnquoteSpliced - <|> do _ <- try (string "#(") + <|> do _ <- try (lexeme $ string "#(") x <- parseVector - _ <- char ')' + _ <- lexeme $ char ')' return x <|> try (parseAtom) - <|> parseString - <|> parseBool + <|> lexeme parseString + <|> lexeme parseBool <|> parseQuoted <|> parseQuasiQuoted <|> parseUnquoted - <|> do _ <- char '(' - x <- try parseList <|> parseDottedList - _ <- char ')' - return x + <|> try (parens parseList) + <|> parens parseDottedList "Expression" +mainParser :: Parser LispVal +mainParser = do + _ <- whiteSpace + x <- parseExpr +-- FUTURE? (seemed to break test cases, but is supposed to be best practice?) eof + return x + readOrThrow :: Parser a -> String -> ThrowsError a readOrThrow parser input = case parse parser "lisp" input of Left err -> throwError $ Parser err Right val -> return val readExpr :: String -> ThrowsError LispVal -readExpr = readOrThrow parseExpr +readExpr = readOrThrow mainParser readExprList :: String -> ThrowsError [LispVal] -readExprList = readOrThrow (endBy parseExpr spaces) +readExprList = readOrThrow (endBy mainParser whiteSpace) + diff --git a/hs-src/shell.hs b/hs-src/shell.hs --- a/hs-src/shell.hs +++ b/hs-src/shell.hs @@ -67,7 +67,7 @@ putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ " putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| " putStrLn " " - putStrLn " husk Scheme Interpreter Version 3.1 " + putStrLn " husk Scheme Interpreter Version 3.2 " putStrLn " (c) 2010-2011 Justin Ethier github.com/justinethier/husk-scheme " putStrLn " " diff --git a/husk-scheme.cabal b/husk-scheme.cabal --- a/husk-scheme.cabal +++ b/husk-scheme.cabal @@ -1,5 +1,5 @@ Name: husk-scheme -Version: 3.1 +Version: 3.2 Synopsis: R5RS Scheme interpreter program and library. Description: A dialect of R5RS Scheme written in Haskell. Provides advanced features including continuations, non-hygienic macros, a Haskell FFI, diff --git a/stdlib.scm b/stdlib.scm --- a/stdlib.scm +++ b/stdlib.scm @@ -327,7 +327,7 @@ (define hash-table-walk (lambda (ht proc) (map - (lambda (kv) (proc (car kv) (cdr kv))) + (lambda (kv) (proc (car kv) (car (reverse kv)))) (hash-table->alist ht)))) (define (hash-table-update! hash-table key function) @@ -349,10 +349,11 @@ lst) ht)) - -; FUTURE: Issue #11: hash-table-fold -;(define (hash-table-fold hash-table f init-value) -; TBD) +(define (hash-table-fold hash-table f acc-in) + (let ((acc acc-in)) + (hash-table-walk hash-table + (lambda (key value) (set! acc (f key value acc)))) + acc)) ; FUTURE: Issue #10: from numeric section -