diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -22,8 +22,15 @@ - Full numeric tower - includes support for parsing/storing types (exact, inexact, etc), support for operations on these types as well as mixing types, other constraints from spec. - Hash tables, as specified by [SRFI 69](http://srfi.schemers.org/srfi-69/srfi-69.html) - Hygenic Macros: High-level macros via define-syntax - *Note this is still a heavy work in progress* and while it works well enough that many derived forms are implemented in our standard library, you may still run into problems when defining your own macros. +- Continuations - call/cc and first-class continuations are partially implemented, however this functionality is extremely limited and in an alpha state. See the change log (release notes) for more information. husk scheme is available under the [MIT license](http://www.opensource.org/licenses/mit-license.php). + +Installation +------------ +husk may be easily installed using [cabal](http://www.haskell.org/cabal/) - just run the following command: + + cabal install husk-scheme Usage ----- diff --git a/hs-src/Scheme/Core.hs b/hs-src/Scheme/Core.hs --- a/hs-src/Scheme/Core.hs +++ b/hs-src/Scheme/Core.hs @@ -37,6 +37,7 @@ import Maybe import List import IO hiding (try) +--import Debug.Trace {-| Evaluate a string containing Scheme code. @@ -56,38 +57,164 @@ @ -} evalString :: Env -> String -> IO String -evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= macroEval env >>= eval env +evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= macroEval env >>= (eval env (makeNullContinuation env)) -- |Evaluate a string and print results to console evalAndPrint :: Env -> String -> IO () -evalAndPrint env expr = evalString env expr >>= putStrLn +evalAndPrint env expr = evalString env expr >>= putStrLn --TODO: cont parameter -- |Evaluate lisp code that has already been loaded into haskell -- -- TODO: code example for this, via ghci and/or a custom program. evalLisp :: Env -> LispVal -> IOThrowsError LispVal -evalLisp env lisp = macroEval env lisp >>= eval env +evalLisp env lisp = macroEval env lisp >>= (eval env (makeNullContinuation env)) + +{- Changes will be required to eval to support continuations. According to original wiki book: + - TBD + - + - + - Need to rethink below and come up with a clear, top-level design approach. Some starting points + - for this are: + - http://c2.com/cgi/wiki?ContinuationImplementation + - http://c2.com/cgi/wiki?CallWithCurrentContinuation (the link to this book may be helpful as well: http://c2.com/cgi/wiki?EssentialsOfProgrammingLanguages - apparently if the interpreter is written using CPS, then call/cc is free) + - http://tech.phillipwright.com/2010/05/23/continuations-in-scheme/ + - http://community.schemewiki.org/?call-with-current-continuation + - + - ALSO, consider the following quote: + - "CPS is a programming style where no function is ever allowed to return." + - So, this would mean that when evaluating a simple integer, string, etc eval should call into + - the continuation instead of just returning. + - Need to think about how this will be handled, how functions will be called using CPS, and what + - the continuation data type needs to contain. + - + - + - + - + - + - Some of my notes: + - as simple as using CPS to evaluate lists of "lines" (body)? Then could pass the next part of the CPS as the cont arg to eval. Or is this too simple to work? need to think about this - http://en.wikipedia.org/wiki/Continuation-passing_style + - + - Possible design approach: + - + - * thread cont through eval + - * instead of returning, call into next eval using CPS style, with the cont parameter. + - this replaces code in evalBody (possibly other places?) that uses local CPS to execute a function + - * parameter will consist of a lisp function + - * eval will call into another function to deal with details of manipulating the cont prior to next call + - need to work out details of exactly how that would work, but could for example just go to the next line + - of body. + - * To continue above point, where is eval'd value returned to? May want to refer to R5RS section that describes call/cc: + - A common use of call-with-current-continuation is for structured, non-local exits from loops or procedure bodies, but in fact call-with-current-continuation is extremely useful for implementing a wide variety of advanced control structures. + - + - Whenever a Scheme expression is evaluated there is a continuation wanting the result of the expression. The continuation represents an entire (default) future for the computation. If the expression is evaluated at top level, for example, then the continuation might take the result, print it on the screen, prompt for the next input, evaluate it, and so on forever. Most of the time the continuation includes actions specified by user code, as in a continuation that will take the result, multiply it by the value stored in a local variable, add seven, and give the answer to the top level continuation to be printed. Normally these ubiquitous continuations are hidden behind the scenes and programmers do not think much about them. On rare occasions, however, a programmer may need to deal with continuations explicitly. Call-with-current-continuation allows Scheme programmers to do that by creating a procedure that acts just like the current continuation. + - + - Most programming languages incorporate one or more special-purpose escape constructs with names like exit, return, or even goto. In 1965, however, Peter Landin [16] invented a general purpose escape operator called the J-operator. John Reynolds [24] described a simpler but equally powerful construct in 1972. The catch special form described by Sussman and Steele in the 1975 report on Scheme is exactly the same as Reynolds's construct, though its name came from a less general construct in MacLisp. Several Scheme implementors noticed that the full power of the catch construct could be provided by a procedure instead of by a special syntactic construct, and the name call-with-current-continuation was coined in 1982. This name is descriptive, but opinions differ on the merits of such a long name, and some people use the name call/cc instead. + - + - * need to consider what would be passed when evaluating via a REPL, at top-level, via haskell entry points, etc... + - + - -} + +{- + - Transformed eval section into CPS by calling into this instead of returning from eval. + - This function uses the cont argument to determine whether to keep going or to + - finally return a result. + - -} +continueEval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal +continueEval _ (Continuation cEnv cBody cCont Nothing Nothing) val = do + case cBody of +-- case (trace ("cBody => " ++ show cBody ++ " val => " ++ show val) cBody) of + [] -> do + case cCont of + Continuation nEnv _ _ _ _ -> continueEval nEnv cCont val + _ -> return val + [lv] -> eval cEnv (Continuation cEnv [] cCont Nothing Nothing) lv --val +-- [lv] -> eval cEnv (Continuation cEnv [] cCont) (trace ("clv => " ++ show lv) lv) --val + (lv : lvs) -> eval cEnv (Continuation cEnv lvs cCont Nothing Nothing) lv +-- (lv : lvs) -> eval cEnv (Continuation cEnv (trace ("clvs => " ++ show lvs) lvs) cCont) (trace ("lv:lvs, (lv) => " ++ show lv) lv) + +{- Alpha code for next version... +continueEval _ cont@(Continuation cEnv cBody cCont cFunc Nothing) _ = do + -- This section is called when we are evaluating a function call + -- First the function needs to be eval'd. Then once that is done, + -- We will drop into the section below to eval each argument. + -- Once all that is done, the function can be called. + -- + -- Notes: function needs to eval'd, then args + -- need to call back into the cont later on, probably after + -- calling one of the makefunc variants? need to make sure + -- changing those calls does not break anything else + case cBody of + [] -> eval cEnv (Continuation cEnv [Nil ""] cCont (Just $ Nil "") (Just (trace ("calling function:" ++ show (fromJust cFunc)) []))) (fromJust cFunc) + other -> eval cEnv (Continuation cEnv cBody cCont (Just $ Nil "") (Just (trace ("calling function:" ++ show (fromJust cFunc)) []))) (fromJust cFunc) + + +-- Something to think about: +-- Hack: attempting to "protect" last func/arg params by placing them within +-- an inner Continuation object. If this works it will (hopefully) be more of +-- a 1.0 solution than a permanent one. A better approach might be using some form +-- of currying to evaluate a function, however have not thought through exactly +-- how that would be implemented, and whether it would require transformation +-- of the Scheme AST itself... + +-- TODO: beginning to wonder if this approach will ever work (?) +-- think about this - can we use haskell lambda functions to +-- achieve the same goal? +-- +-- alternatively, maybe shelf this for now and just get this branch good enough for a release?? +-- TCO is the missing component + +continueEval _ cont@(Continuation cEnv cBody cCont (Just cFunc) (Just cArgs)) val = do +-- if length cArgs == 0 && cFunc == (Nil "") + case cFunc of + Nil _ -> do + case (trace ("cBody1: " ++ show cBody) cBody) of +-- case cBody of + [] -> continueEval cEnv cCont =<< apply cCont cFunc [] -- TODO: ContinueEval is a temporary stopgap, here and in below (apply) + [Nil ""] -> continueEval cEnv cCont =<< apply cCont val [] -- TODO: ContinueEval is a temporary stopgap, here and in below (apply) + [arg] -> do -- Eval the arg, but keep in mind val contains the function + eval cEnv (Continuation cEnv [Nil ""] cCont (Just val) (Just cArgs)) arg + (arg : args) -> do -- Peel off next arg and evaluate it, saving function + eval cEnv (Continuation cEnv args cCont (Just val) (Just cArgs)) arg + o -> case (trace ("cBody2: " ++ show cBody) cBody) of + [] -> continueEval cEnv cCont =<< apply cCont cFunc (trace ("args: " ++ show (cArgs) ++ " func: " ++ show cFunc) (cArgs)) -- No more arguments, call the function + -- Nil value indicates that all args have been processed + [Nil ""] -> continueEval cEnv cCont =<< apply cCont cFunc (trace ("args (Nil): " ++ show (cArgs ++ [val]) ++ " func: " ++ show cFunc) (cArgs ++ [val])) -- No more arguments, call the function +-- o -> case cBody of +-- [] -> apply cCont cFunc (cArgs ++ [val]) -- No more arguments, call the function + [arg] -> do -- Evaluate the last arg + eval cEnv (Continuation cEnv [Nil ""] cCont (Just cFunc) (Just $ cArgs ++ [val])) arg + (arg : args) -> do -- Peel off next arg and evaluate it + eval cEnv (Continuation cEnv args cCont (Just cFunc) (Just $ cArgs ++ [val])) arg +-} + +continueEval _ _ _ = throwError $ Default "Internal error in continueEval" + -- |Core eval function -- -- NOTE: This function does not include macro support and should not be called directly. Instead, use 'evalLisp' -eval :: Env -> LispVal -> IOThrowsError LispVal -eval _ val@(Nil _) = return val -eval _ val@(String _) = return val -eval _ val@(Char _) = return val -eval _ val@(Complex _) = return val -eval _ val@(Float _) = return val -eval _ val@(Rational _) = return val -eval _ val@(Number _) = return val -eval _ val@(Bool _) = return val -eval _ val@(HashTable _) = return val -eval env (Atom a) = getVar env a -eval _ (List [Atom "quote", val]) = return val -eval envi (List [Atom "quasiquote", value]) = doUnQuote envi value +eval :: Env -> LispVal -> LispVal -> IOThrowsError LispVal +eval env cont val@(Nil _) = continueEval env cont val +eval env cont val@(String _) = continueEval env cont val +eval env cont val@(Char _) = continueEval env cont val +eval env cont val@(Complex _) = continueEval env cont val +eval env cont val@(Float _) = continueEval env cont val +eval env cont val@(Rational _) = continueEval env cont val +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 (Atom a) = continueEval env cont =<< getVar env a +eval env cont (List [Atom "quote", val]) = continueEval env cont val + +-- The way it is written now, quasiquotation does not support +-- being part of a continuation, so we use the null continuation +-- within it for right now +eval envi cont (List [Atom "quasiquote", value]) = continueEval envi cont =<< doUnQuote envi value where doUnQuote :: Env -> LispVal -> IOThrowsError LispVal doUnQuote env val = do case val of - List [Atom "unquote", val] -> eval env val + List [Atom "unquote", vval] -> eval env (makeNullContinuation env) vval List (x : xs) -> unquoteListM env (x:xs) >>= return . List DottedList xs x -> do rxs <- unquoteListM env xs >>= return @@ -101,15 +228,15 @@ let len = length (elems vec) vList <- unquoteListM env $ elems vec >>= return return $ Vector $ listArray (0, len) vList - _ -> eval env (List [Atom "quote", val]) -- Behave like quote if there is nothing to "unquote"... + _ -> eval env (makeNullContinuation env) (List [Atom "quote", val]) -- Behave like quote if there is nothing to "unquote"... unquoteListM env lst = foldlM (unquoteListFld env) ([]) lst unquoteListFld env (acc) val = do case val of - List [Atom "unquote-splicing", val] -> do - value <- eval env val - case value of + List [Atom "unquote-splicing", vvar] -> do + evalue <- eval env (makeNullContinuation env) vvar + case evalue of List v -> return $ (acc ++ v) - -- Question: In which cases should I generate a type error if value is not a list? + -- Question: In which cases should I generate a type error if evalue is not a list? -- -- csi reports an error for this: `(1 ,@(+ 1 2) 4) -- but allows cases such as: `,@2 @@ -117,221 +244,298 @@ -- least we will not allow anything invalid to be returned. -- -- Old code that we might build on if this changes down the road: otherwise -> return $ (acc ++ [v]) - _ -> throwError $ TypeMismatch "proper list" value + _ -> throwError $ TypeMismatch "proper list" evalue _ -> do result <- doUnQuote env val return $ (acc ++ [result]) -eval env (List [Atom "if", pred, conseq, alt]) = - do result <- eval env pred +eval env cont (List [Atom "if", predic, conseq, alt]) = + do result <- eval env cont predic case result of - Bool False -> eval env alt - otherwise -> eval env conseq + Bool False -> eval env cont alt + _ -> eval env cont conseq -eval env (List [Atom "if", pred, conseq]) = - do result <- eval env pred +eval env cont (List [Atom "if", predic, conseq]) = + do result <- eval env cont predic case result of - Bool True -> eval env conseq - otherwise -> eval env $ List [] + Bool True -> eval env cont conseq + _ -> eval env cont $ List [] -eval env (List (Atom "cond" : clauses)) = +eval env cont (List (Atom "cond" : clauses)) = if length clauses == 0 then throwError $ BadSpecialForm "No matching clause" $ String "cond" else do let c = clauses !! 0 -- First clause let cs = tail clauses -- other clauses test <- case c of - List (Atom "else" : expr) -> eval env $ Bool True - List (cond : expr) -> eval env cond + List (Atom "else" : _) -> eval env cont $ Bool True + List (cond : _) -> eval env cont cond badType -> throwError $ TypeMismatch "clause" badType case test of - Bool True -> evalCond env c - otherwise -> eval env $ List $ (Atom "cond" : cs) + Bool True -> evalCond env cont c + _ -> eval env cont $ List $ (Atom "cond" : cs) -eval env (List (Atom "case" : keyAndClauses)) = +eval env cont (List (Atom "case" : keyAndClauses)) = do let key = keyAndClauses !! 0 let cls = tail keyAndClauses - ekey <- eval env key - evalCase env $ List $ (ekey : cls) + ekey <- eval env cont key + evalCase env cont $ List $ (ekey : cls) -eval env (List (Atom "begin" : funcs)) = +eval env cont (List (Atom "begin" : funcs)) = if length funcs == 0 - then eval env $ Nil "" + then eval env cont $ Nil "" else if length funcs == 1 - then eval env (head funcs) + then eval env cont (head funcs) else do let fs = tail funcs - eval env (head funcs) - eval env (List (Atom "begin" : fs)) - -eval env (List [Atom "load", String filename]) = - load filename >>= liftM last . mapM (evaluate env) - where evaluate env val = macroEval env val >>= eval env + eval env cont (head funcs) + eval env cont (List (Atom "begin" : fs)) -eval env (List [Atom "set!", Atom var, form]) = - eval env form >>= setVar env var +eval env cont (List [Atom "load", String filename]) = do +-- load filename >>= liftM last . mapM (evaluate env cont) + result <- load filename >>= liftM last . mapM (evaluate env (makeNullContinuation env)) + continueEval env cont result + where evaluate env2 cont2 val2 = macroEval env2 val2 >>= eval env2 cont2 -eval env (List [Atom "define", Atom var, form]) = - eval env form >>= defineVar env var +eval env cont (List [Atom "set!", Atom var, form]) = do +-- eval env cont form >>= setVar env var + result <- eval env (makeNullContinuation env) form >>= setVar env var + continueEval env cont result -eval env (List (Atom "define" : List (Atom var : params) : body )) = - makeNormalFunc env params body >>= defineVar env var -eval env (List (Atom "define" : DottedList (Atom var : params) varargs : body)) = - makeVarargs varargs env params body >>= defineVar env var -eval env (List (Atom "lambda" : List params : body)) = - makeNormalFunc env params body -eval env (List (Atom "lambda" : DottedList params varargs : body)) = - makeVarargs varargs env params body -eval env (List (Atom "lambda" : varargs@(Atom _) : body)) = - makeVarargs varargs env [] body +eval env cont (List [Atom "define", Atom var, form]) = do +-- eval env cont form >>= defineVar env var + result <- eval env (makeNullContinuation env) form >>= defineVar env var + continueEval env cont result -eval env (List [Atom "string-fill!", Atom var, character]) = do - str <- eval env =<< getVar env var - chr <- eval env character - (eval env $ fillStr(str, chr)) >>= setVar env var - where fillStr (String str, Char chr) = doFillStr (String "", Char chr, length str) - - doFillStr (String str, Char chr, left) = do - if left == 0 - then String str - else doFillStr(String $ chr : str, Char chr, left - 1) +eval env cont (List (Atom "define" : List (Atom var : fparams) : fbody )) = do + result <- (makeNormalFunc env fparams fbody >>= defineVar env var) + continueEval env cont result +eval env cont (List (Atom "define" : DottedList (Atom var : fparams) varargs : fbody)) = do + result <- (makeVarargs varargs env fparams fbody >>= defineVar env var) + continueEval env cont result +eval env cont (List (Atom "lambda" : List fparams : fbody)) = do + result <- makeNormalFunc env fparams fbody + continueEval env cont result +eval env cont (List (Atom "lambda" : DottedList fparams varargs : fbody)) = do + result <- makeVarargs varargs env fparams fbody + continueEval env cont result +eval env cont (List (Atom "lambda" : varargs@(Atom _) : fbody)) = do + result <- makeVarargs varargs env [] fbody + continueEval env cont result -eval env (List [Atom "string-set!", Atom var, index, character]) = do - idx <- eval env index - str <- eval env =<< getVar env var - (eval env $ substr(str, character, idx)) >>= setVar env var - where substr (String str, Char char, Number index) = do - String $ (take (fromInteger index) . drop 0) str ++ +eval env cont (List [Atom "string-fill!", Atom var, character]) = do + str <- eval env (makeNullContinuation env) =<< getVar env var + echr <- eval env (makeNullContinuation env) character + result <- ((eval env (makeNullContinuation env) =<< fillStr(str, echr))) >>= setVar env var + continueEval env cont result + where fillStr (String str, Char achr) = doFillStr (String "", Char achr, length str) + fillStr (String _, c) = throwError $ TypeMismatch "character" c + fillStr (s, _) = throwError $ TypeMismatch "string" s + doFillStr (String str, Char achr, left) = do + if left == 0 + then return $ String str + else doFillStr(String $ achr : str, Char achr, left - 1) + doFillStr (String _, c, _) = throwError $ TypeMismatch "character" c + doFillStr (s, Char _, _) = throwError $ TypeMismatch "string" s + doFillStr (_, _, _) = throwError $ BadSpecialForm "Unexpected error in string-fill!" $ List [] +eval env cont (List [Atom "string-set!", Atom var, i, character]) = do + idx <- eval env (makeNullContinuation env) i + str <- eval env (makeNullContinuation env) =<< getVar env var + result <- ((eval env (makeNullContinuation env) =<< substr(str, character, idx))) >>= setVar env var + continueEval env cont result + where substr (String str, Char char, Number ii) = do + return $ String $ (take (fromInteger ii) . drop 0) str ++ [char] ++ - (take (length str) . drop (fromInteger index + 1)) str - -- TODO: error handler - -eval env val@(Vector _) = return val + (take (length str) . drop (fromInteger ii + 1)) str +{- TODO: + - also need to add unit tests for this...-} + substr (String _, Char _, n) = throwError $ TypeMismatch "number" n + substr (String _, c, _) = throwError $ TypeMismatch "character" c + substr (s, _, _) = throwError $ TypeMismatch "string" s -eval env (List [Atom "vector-set!", Atom var, index, object]) = do - idx <- eval env index - obj <- eval env object - vec <- eval env =<< getVar env var - (eval env $ (updateVector vec idx obj)) >>= setVar env var - where updateVector (Vector vec) (Number idx) obj = Vector $ vec//[(fromInteger idx, obj)] - -- TODO: error handler? --- TODO: error handler? - eval env (List [Atom "vector-set!", args]) = throwError $ NumArgs 2 args +eval env cont (List [Atom "vector-set!", Atom var, i, object]) = do + idx <- eval env (makeNullContinuation env) i + obj <- eval env (makeNullContinuation env) object + vec <- eval env (makeNullContinuation env) =<< getVar env var + result <- ((eval env (makeNullContinuation env) =<< (updateVector vec idx obj))) >>= setVar env var + continueEval env cont result + where updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal + updateVector (Vector vec) (Number idx) obj = return $ Vector $ vec//[(fromInteger idx, obj)] + updateVector v _ _ = throwError $ TypeMismatch "vector" v -eval env (List [Atom "vector-fill!", Atom var, object]) = do - obj <- eval env object - vec <- eval env =<< getVar env var - (eval env $ (fillVector vec obj)) >>= setVar env var - where fillVector (Vector vec) obj = do +eval env cont (List [Atom "vector-fill!", Atom var, object]) = do + obj <- eval env (makeNullContinuation env) object + vec <- eval env (makeNullContinuation env) =<< getVar env var + result <- ((eval env (makeNullContinuation env) =<< (fillVector vec obj))) >>= setVar env var + continueEval env cont result + where fillVector :: LispVal -> LispVal -> IOThrowsError LispVal + fillVector (Vector vec) obj = do let l = replicate (lenVector vec) obj - Vector $ (listArray (0, length l - 1)) l + return $ Vector $ (listArray (0, length l - 1)) l + fillVector v _ = throwError $ TypeMismatch "vector" v lenVector v = length (elems v) - -- TODO: error handler? --- TODO: error handler? - eval env (List [Atom "vector-fill!", args]) = throwError $ NumArgs 2 args -eval env (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do - key <- eval env rkey - value <- eval env rvalue - h <- eval env =<< getVar env var +eval env cont (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do + key <- eval env (makeNullContinuation env) rkey + value <- eval env (makeNullContinuation env) rvalue + h <- eval env (makeNullContinuation env) =<< getVar env var case h of - HashTable ht -> (eval env $ HashTable $ Data.Map.insert key value ht) >>= setVar env var + HashTable ht -> do + result <- (eval env (makeNullContinuation env) $ HashTable $ Data.Map.insert key value ht) >>= setVar env var + continueEval env cont result other -> throwError $ TypeMismatch "hash-table" other -eval env (List [Atom "hash-table-delete!", Atom var, rkey]) = do - key <- eval env rkey - h <- eval env =<< getVar env var +eval env cont (List [Atom "hash-table-delete!", Atom var, rkey]) = do + key <- eval env (makeNullContinuation env) rkey + h <- eval env (makeNullContinuation env) =<< getVar env var case h of - HashTable ht -> (eval env $ HashTable $ Data.Map.delete key ht) >>= setVar env var + HashTable ht -> do + result <- (eval env (makeNullContinuation env) $ HashTable $ Data.Map.delete key ht) >>= setVar env var + continueEval env cont result other -> throwError $ TypeMismatch "hash-table" other -- TODO: -- hash-table-merge! -eval env (List (function : args)) = do - func <- eval env function - argVals <- mapM (eval env) args - apply func argVals ---Obsolete (?) - eval env (List (Atom func : args)) = mapM (eval env) args >>= liftThrows . apply func -eval env badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm +-- TODO: for CPS form, need to be able to pass a continuation to a function +-- need to work through this implementation. +-- +-- See http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_sec_6.6 +-- for test cases that are required to ensure apply is not broken by this change. Need +-- it intact prior to proceeding with CPS and functions +eval _ _ (List [Atom "apply"]) = throwError $ BadSpecialForm "apply" $ String "Function not specified" +eval _ _ (List [Atom "apply", _]) = throwError $ BadSpecialForm "apply" $ String "Arguments not specified" +eval env cont (List (Atom "apply" : args)) = do + -- FUTURE: verify length of list? + -- TODO: for all Continuations below, will almost certainly need to pull each into this continuation + proc <- eval env (makeNullContinuation env) $ head $ args + lst <- eval env (makeNullContinuation env) $ head $ reverse args + argVals <- mapM (eval env (makeNullContinuation env)) $ tail $ reverse $ tail (reverse args) + case lst of + List l -> apply cont proc (argVals ++ l) + other -> throwError $ TypeMismatch "list" other +eval env cont (List (Atom "call-with-current-continuation" : args)) = + eval env cont (List (Atom "call/cc" : args)) +eval _ _ (List [Atom "call/cc"]) = throwError $ Default "Procedure not specified" +eval env cont (List [Atom "call/cc", proc]) = do + func <- eval env (makeNullContinuation env) proc + case func of + PrimitiveFunc f -> liftThrows $ f [cont] + Func aparams _ _ _ _ -> + if (toInteger $ length aparams) == 1 + then apply cont func [cont] + else throwError $ NumArgs (toInteger $ length aparams) [cont] + other -> throwError $ TypeMismatch "procedure" other + + +eval env cont (List (function : args)) = do +-- Alpha code for next version: continueEval env (Continuation env (args) cont (Just function) Nothing) $ Nil "" +-- { - TODO: obsolete code, delete once above is working + func <- eval env (makeNullContinuation env) function -- TODO: almost certainly need to pull this into the continuation + argVals <- mapM (eval env (makeNullContinuation env)) args -- TODO: almost certainly need to pull this into the continuation + apply cont func argVals +-- } + +--Obsolete (?) - eval env cont (List (Atom func : args)) = mapM (eval env) args >>= liftThrows . apply func +eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm + -- Helper function for evaluating 'case' -- TODO: still need to handle case where nothing matches key -- (same problem exists with cond, if) -evalCase :: Env -> LispVal -> IOThrowsError LispVal -evalCase env (List (key : cases)) = do +evalCase :: Env -> LispVal -> LispVal -> IOThrowsError LispVal +evalCase envOuter cont (List (key : cases)) = do let c = cases !! 0 - ekey <- eval env key + ekey <- eval envOuter cont key case c of - List (Atom "else" : exprs) -> last $ map (eval env) exprs - List (List cond : exprs) -> do test <- checkEq env ekey (List cond) + List (Atom "else" : exprs) -> last $ map (eval envOuter cont) exprs + List (List cond : exprs) -> do test <- checkEq envOuter ekey (List cond) case test of - Bool True -> last $ map (eval env) exprs - _ -> evalCase env $ List $ ekey : tail cases + Bool True -> last $ map (eval envOuter cont) exprs + _ -> evalCase envOuter cont $ List $ ekey : tail cases badForm -> throwError $ BadSpecialForm "Unrecognized special form in case" badForm where checkEq env ekey (List (x : xs)) = do - test <- eval env $ List [Atom "eqv?", ekey, x] + test <- eval env cont $ List [Atom "eqv?", ekey, x] case test of - Bool True -> eval env $ Bool True + Bool True -> eval env cont $ Bool True _ -> checkEq env ekey (List xs) checkEq env ekey val = case val of - List [] -> eval env $ Bool False -- If nothing else is left, then nothing matched key + List [] -> eval env cont $ Bool False -- If nothing else is left, then nothing matched key _ -> do - test <- eval env $ List [Atom "eqv?", ekey, val] + test <- eval env cont $ List [Atom "eqv?", ekey, val] case test of - Bool True -> eval env $ Bool True - _ -> eval env $ Bool False + Bool True -> eval env cont $ Bool True + _ -> eval env cont $ Bool False -evalCase _ badForm = throwError $ BadSpecialForm "case: Unrecognized special form" badForm +evalCase _ _ badForm = throwError $ BadSpecialForm "case: Unrecognized special form" badForm -- Helper function for evaluating 'cond' -evalCond :: Env -> LispVal -> IOThrowsError LispVal -evalCond env (List [_, expr]) = eval env expr -evalCond env (List (_ : expr)) = last $ map (eval env) expr -- TODO: all expr's need to be evaluated, not sure happening right now -evalCond _ badForm = throwError $ BadSpecialForm "evalCond: Unrecognized special form" badForm +evalCond :: Env -> LispVal -> LispVal -> IOThrowsError LispVal +evalCond env cont (List [_, expr]) = eval env cont expr +evalCond env cont (List (_ : expr)) = last $ map (eval env cont) expr -- TODO: all expr's need to be evaluated, not sure happening right now +evalCond _ _ badForm = throwError $ BadSpecialForm "evalCond: Unrecognized special form" badForm ---makeFunc :: forall (m :: * -> *).(Monad m) => Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal -makeFunc varargs env params body = return $ Func (map showVal params) varargs body env False -{-makeNormalFunc :: Env +makeFunc :: --forall (m :: * -> *). + (Monad m) => + Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal +makeFunc varargs env fparams fbody = return $ Func (map showVal fparams) varargs fbody env False +makeNormalFunc :: (Monad m) => Env -> [LispVal] -> [LispVal] - -> m LispVal-} + -> m LispVal makeNormalFunc = makeFunc Nothing -{-makeVarargs :: LispVal -> Env +makeVarargs :: (Monad m) => LispVal -> Env -> [LispVal] -> [LispVal] - -> m LispVal-} + -> m LispVal makeVarargs = makeFunc . Just . showVal -apply :: LispVal -> [LispVal] -> IOThrowsError LispVal -apply (IOFunc func) args = func args -apply (PrimitiveFunc func) args = liftThrows $ func args -apply (Func aparams avarargs abody aclosure _) args = +apply :: LispVal -> LispVal -> [LispVal] -> IOThrowsError LispVal +apply _ c@(Continuation env _ _ _ _) args = do + if (toInteger $ length args) /= 1 + then throwError $ NumArgs 1 args + else continueEval env c $ head args -- may not be correct, what happens if call/cc is an inner part of a list? +-- else continueEval env (trace ("continueEval => " ++ show cont) c) $ head args -- may not be correct, what happens if call/cc is an inner part of a list? + -- TODO: + -- this is not good enough. is it correct if we take c and replace the "outer" continuation with it?? + -- + -- this would work for return and other simple examples +apply _ (IOFunc func) args = func args +apply _ (PrimitiveFunc func) args = liftThrows $ func args +apply cont (Func aparams avarargs abody aclosure _) args = if num aparams /= num args && avarargs == Nothing then throwError $ NumArgs (num aparams) args else (liftIO $ extendEnv aclosure $ zip (map ((,) varNamespace) aparams) args) >>= bindVarArgs avarargs >>= (evalBody abody) --- else (liftIO $ bindVars closure $ zip (map ((,) varNamespace) params) args) >>= bindVarArgs varargs >>= (evalBody body) where remainingArgs = drop (length aparams) args num = toInteger . length - evalBody restBody env = do - -- Iterate through, executing each member of the body - -- Interestingly, this seems to handle Scheme tail recursion just fine. Need to analyze this - -- a bit more, but the trampoline itself may be unnecessary (which makes sense as Haskell has TCO) + -- + -- Continue evaluation within the body, preserving the outer continuation. + -- + -- This link was helpful for implementing this, and has a *lot* of other useful information: + -- http://icem-www.folkwang-hochschule.de/~finnendahl/cm_kurse/doc/schintro/schintro_73.html#SEC80 + -- + -- What we are doing now is simply not saving a continuation for tail calls. For now this may + -- be good enough, although it may need to be enhanced in the future in order to properly + -- detect all tail calls. See: http://icem-www.folkwang-hochschule.de/~finnendahl/cm_kurse/doc/schintro/schintro_142.html#SEC294 + -- + evalBody evBody env = case cont of + Continuation _ cBody cCont _ _ -> if length cBody == 0 + then continueWithContinuation env evBody cCont + else continueWithContinuation env evBody cont + _ -> continueWithContinuation env evBody cont --- Old code, which will overflow stack: liftM last $ mapM (eval env) restBody + -- Shortcut for calling continueEval + continueWithContinuation cwcEnv cwcBody cwcCont = + continueEval cwcEnv (Continuation cwcEnv cwcBody cwcCont Nothing Nothing) $ Nil "" - case restBody of - [lv] -> eval env lv - (lv : lvs) -> do - eval env lv - evalBody lvs env bindVarArgs arg env = case arg of Just argName -> liftIO $ extendEnv env [((varNamespace, argName), List $ remainingArgs)] --- Just argName -> liftIO $ bindVars env [((varNamespace, argName), List $ remainingArgs)] Nothing -> return env -apply func args = throwError $ BadSpecialForm "Unable to evaluate form" $ List (func : args) +apply _ func args = throwError $ BadSpecialForm "Unable to evaluate form" $ List (func : args) -- |Environment containing the primitive forms that are built into the Scheme language. Note that this only includes -- forms that are implemented in Haskell; derived forms implemented in Scheme (such as let, list, etc) are available @@ -342,8 +546,7 @@ where domakeFunc constructor (var, func) = ((varNamespace, var), constructor func) ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)] -ioPrimitives = [("apply", applyProc), - ("open-input-file", makePort ReadMode), +ioPrimitives = [("open-input-file", makePort ReadMode), ("open-output-file", makePort WriteMode), ("close-input-port", closePort), ("close-output-port", closePort), @@ -352,13 +555,10 @@ ("read-contents", readContents), ("read-all", readAll)] -applyProc :: [LispVal] -> IOThrowsError LispVal -applyProc [func, List args] = apply func args -applyProc (func : args) = apply func args -applyProc [] = throwError $ BadSpecialForm "applyProc" $ String "Function not specified" - makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode +makePort _ [] = throwError $ NumArgs 1 [] +makePort _ args@(_ : _) = throwError $ NumArgs 1 args closePort :: [LispVal] -> IOThrowsError LispVal closePort [Port port] = liftIO $ hClose port >> (return $ Bool True) @@ -367,19 +567,28 @@ readProc :: [LispVal] -> IOThrowsError LispVal readProc [] = readProc [Port stdin] readProc [Port port] = (liftIO $ hGetLine port) >>= liftThrows . readExpr +readProc args@(_ : _) = throwError $ BadSpecialForm "" $ List args writeProc :: [LispVal] -> IOThrowsError LispVal writeProc [obj] = writeProc [obj, Port stdout] writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Nil "") +writeProc other = if length other == 2 + then throwError $ TypeMismatch "(value port)" $ List other + else throwError $ NumArgs 2 other readContents :: [LispVal] -> IOThrowsError LispVal readContents [String filename] = liftM String $ liftIO $ readFile filename +readContents [] = throwError $ NumArgs 1 [] +readContents args@(_ : _) = throwError $ NumArgs 1 args load :: String -> IOThrowsError [LispVal] load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList +-- TODO: load should not crash interpreter if file does not exist readAll :: [LispVal] -> IOThrowsError LispVal readAll [String filename] = liftM List $ load filename +readAll [] = throwError $ NumArgs 1 [] +readAll args@(_ : _) = throwError $ NumArgs 1 args primitives :: [(String, [LispVal] -> ThrowsError LispVal)] primitives = [("+", numAdd), @@ -526,6 +735,9 @@ unaryOp :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal unaryOp f [v] = f v +unaryOp _ [] = throwError $ NumArgs 1 [] +unaryOp _ args@(_ : _) = throwError $ NumArgs 1 args + --numBoolBinop :: (Integer -> Integer -> Bool) -> [LispVal] -> ThrowsError LispVal --numBoolBinop = boolBinop unpackNum strBoolBinop :: (String -> String -> Bool) -> [LispVal] -> ThrowsError LispVal @@ -620,6 +832,8 @@ case Data.Map.lookup key ht of Just _ -> return $ Bool True Nothing -> return $ Bool False +hashTblExists [] = throwError $ NumArgs 2 [] +hashTblExists args@(_ : _) = throwError $ NumArgs 2 args hashTblRef [(HashTable ht), key@(_)] = do case Data.Map.lookup key ht of @@ -753,6 +967,8 @@ listToString [(List [])] = return $ String "" listToString [(List l)] = buildString l listToString [badType] = throwError $ TypeMismatch "list" badType +listToString [] = throwError $ NumArgs 1 [] +listToString args@(_ : _) = throwError $ NumArgs 1 args stringCopy :: [LispVal] -> ThrowsError LispVal stringCopy [String s] = return $ String s @@ -764,6 +980,7 @@ isDottedList _ = return $ Bool False isProcedure :: [LispVal] -> ThrowsError LispVal +isProcedure ([Continuation _ _ _ _ _]) = return $ Bool True isProcedure ([PrimitiveFunc _]) = return $ Bool True isProcedure ([Func _ _ _ _ _]) = return $ Bool True isProcedure ([IOFunc _]) = return $ Bool True @@ -786,10 +1003,14 @@ symbol2String :: [LispVal] -> ThrowsError LispVal symbol2String ([Atom a]) = return $ String a symbol2String [notAtom] = throwError $ TypeMismatch "symbol" notAtom +symbol2String [] = throwError $ NumArgs 1 [] +symbol2String args@(_ : _) = throwError $ NumArgs 1 args string2Symbol :: [LispVal] -> ThrowsError LispVal string2Symbol ([String s]) = return $ Atom s +string2Symbol [] = throwError $ NumArgs 1 [] string2Symbol [notString] = throwError $ TypeMismatch "string" notString +string2Symbol args@(_ : _) = throwError $ NumArgs 1 args isChar :: [LispVal] -> ThrowsError LispVal isChar ([Char _]) = return $ Bool True diff --git a/hs-src/Scheme/Macro.hs b/hs-src/Scheme/Macro.hs --- a/hs-src/Scheme/Macro.hs +++ b/hs-src/Scheme/Macro.hs @@ -1,4 +1,4 @@ -{- +{- - husk scheme - Macro - @author Justin Ethier @@ -35,9 +35,8 @@ ) where import Scheme.Types import Scheme.Variables -import Control.Monad import Control.Monad.Error -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 @@ -45,12 +44,12 @@ -- Search for macro's in the AST, and transform any that are found. -- There is also a special case (define-syntax) that loads new rules. macroEval :: Env -> LispVal -> IOThrowsError LispVal -macroEval env (List [Atom "define-syntax", Atom keyword, syntaxRules@(List (Atom "syntax-rules" : (List identifiers : rules)))]) = do +macroEval env (List [Atom "define-syntax", Atom keyword, syntaxRules@(List (Atom "syntax-rules" : (List _ : _)))]) = do -- TODO: there really ought to be some error checking of the syntax rules, since they could be malformed... -- As it stands now, there is no checking until the code attempts to perform a macro transformation. defineNamespacedVar env macroNamespace keyword syntaxRules return $ Nil "" -- Sentinal value -macroEval env lisp@(List (x@(List _) : xs)) = do +macroEval env (List (x@(List _) : xs)) = do first <- macroEval env x rest <- mapM (macroEval env) xs return $ List $ first : rest @@ -60,7 +59,7 @@ isDefined <- liftIO $ isNamespacedBound env macroNamespace x if isDefined then do - syntaxRules@(List (Atom "syntax-rules" : (List identifiers : rules))) <- getNamespacedVar env macroNamespace x + (List (Atom "syntax-rules" : (List identifiers : rules))) <- getNamespacedVar env macroNamespace x -- Transform the input and then call macroEval again, since a macro may be contained within... macroEval env =<< macroTransform env (List identifiers) rules lisp else do @@ -78,45 +77,44 @@ -- rules - pattern/transform pairs to compare to input -- input - Code from the scheme application macroTransform :: Env -> LispVal -> [LispVal] -> LispVal -> IOThrowsError LispVal -macroTransform env identifiers rules@(rule@(List r) : rs) input = do +macroTransform env identifiers (rule@(List _) : rs) input = do localEnv <- liftIO $ nullEnv -- Local environment used just for this invocation result <- matchRule env identifiers localEnv rule input case result of Nil _ -> macroTransform env identifiers rs input - otherwise -> return result + _ -> return result -- Ran out of rules to match... macroTransform _ _ _ input = throwError $ BadSpecialForm "Input does not match a macro pattern" input -- Determine if the next element in a list matches 0-to-n times due to an ellipsis macroElementMatchesMany :: LispVal -> Bool -macroElementMatchesMany (List (p:ps)) = do +macroElementMatchesMany (List (_:ps)) = do if not (null ps) then case (head ps) of Atom "..." -> True - otherwise -> False + _ -> False else False macroElementMatchesMany _ = False -- Given input, determine if that input matches any rules -- @return Transformed code, or Nil if no rules match matchRule :: Env -> LispVal -> Env -> LispVal -> LispVal -> IOThrowsError LispVal ---matchRule env identifiers localEnv (List [p@(List patternVar), template@(List _)]) (List inputVar) = do -matchRule env identifiers localEnv (List [pattern, template]) (List inputVar) = do +matchRule _ identifiers localEnv (List [pattern, template]) (List inputVar) = do let is = tail inputVar let p = case pattern of DottedList ds d -> case ds of (Atom l : ls) -> List [Atom l, DottedList ls d] - otherwise -> pattern - otherwise -> pattern + _ -> pattern + _ -> pattern case p of List (Atom _ : ps) -> do match <- loadLocal localEnv identifiers (List ps) (List is) False False case match of Bool False -> return $ Nil "" - otherwise -> transformRule localEnv 0 (List []) template (List []) - otherwise -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" p + _ -> transformRule localEnv 0 (List []) template (List []) + _ -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" p -matchRule _ identifiers _ rule input = do +matchRule _ _ _ rule input = do throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ List [Atom "rule: ", rule, Atom "input: ", input] -- @@ -132,39 +130,38 @@ result <- loadLocal localEnv identifiers (List ps) (List is) False outerHasEllipsis case result of Bool True -> loadLocal localEnv identifiers p i False outerHasEllipsis - otherwise -> return $ Bool False + _ -> return $ Bool False (List (p:ps), List (i:is)) -> do -- check first input against first pattern, recurse... - let hasEllipsis = macroElementMatchesMany pattern + let localHasEllipsis = macroElementMatchesMany pattern -- TODO: error if ... detected when there is an outer ... ???? -- no, this should (eventually) be allowed. See scheme-faq-macros - status <- checkLocal localEnv identifiers (hasEllipsis || outerHasEllipsis) p i + status <- checkLocal localEnv identifiers (localHasEllipsis || outerHasEllipsis) p i case status of -- No match - Bool False -> if hasEllipsis + Bool False -> if localHasEllipsis -- No match, must be finished with ... -- Move past it, but keep the same input. then do loadLocal localEnv identifiers (List $ tail ps) (List (i:is)) False outerHasEllipsis else return $ Bool False -- There was a match - otherwise -> if hasEllipsis - then loadLocal localEnv identifiers pattern (List is) True outerHasEllipsis - else loadLocal localEnv identifiers (List ps) (List is) False outerHasEllipsis + _ -> if localHasEllipsis + then loadLocal localEnv identifiers pattern (List is) True outerHasEllipsis + else loadLocal localEnv identifiers (List ps) (List is) False outerHasEllipsis -- Base case - All data processed (List [], List []) -> return $ Bool True -- Ran out of input to process - (List (p:ps), List []) -> do + (List (_:ps), List []) -> do -- Ensure any patterns that are not present in the input still -- have their variables initialized so they are ready during trans. initializePatternVars localEnv "list" identifiers pattern - let hasEllipsis = macroElementMatchesMany pattern - if hasEllipsis && ((length ps) == 1) + if (macroElementMatchesMany pattern) && ((length ps) == 1) then return $ Bool True else return $ Bool False @@ -182,11 +179,11 @@ -- @param pattern - Pattern to match -- @param input - Input to be matched checkLocal :: Env -> LispVal -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal -checkLocal localEnv identifiers hasEllipsis (Bool pattern) (Bool input) = return $ Bool $ pattern == input -checkLocal localEnv identifiers hasEllipsis (Number pattern) (Number input) = return $ Bool $ pattern == input -checkLocal localEnv identifiers hasEllipsis (Float pattern) (Float input) = return $ Bool $ pattern == input -checkLocal localEnv identifiers hasEllipsis (String pattern) (String input) = return $ Bool $ pattern == input -checkLocal localEnv identifiers hasEllipsis (Char pattern) (Char input) = return $ Bool $ pattern == input +checkLocal _ _ _ (Bool pattern) (Bool input) = return $ Bool $ pattern == input +checkLocal _ _ _ (Number pattern) (Number input) = return $ Bool $ pattern == input +checkLocal _ _ _ (Float pattern) (Float input) = return $ Bool $ pattern == input +checkLocal _ _ _ (String pattern) (String input) = return $ Bool $ pattern == input +checkLocal _ _ _ (Char pattern) (Char input) = return $ Bool $ pattern == input checkLocal localEnv identifiers hasEllipsis (Atom pattern) input = do if hasEllipsis -- Var is part of a 0-to-many match, store up in a list... @@ -195,12 +192,13 @@ found <- findAtom (Atom pattern) identifiers let val = case found of (Bool True) -> Atom pattern - otherwise -> input + _ -> input -- Set variable in the local environment if isDefined then do v <- getVar localEnv pattern case v of (List vs) -> setVar localEnv pattern (List $ vs ++ [val]) + _ -> throwError $ Default "Unexpected error in checkLocal (Atom)" else defineVar localEnv pattern (List [val]) -- Simple var, load up into macro env else defineVar localEnv pattern input @@ -210,7 +208,7 @@ -- TODO, load into localEnv in some (all?) cases?: eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2 -- TODO: eqv [(Vector arg1), (Vector arg2)] = eqv [List $ (elems arg1), List $ (elems arg2)] -- -checkLocal localEnv identifiers hasEllipsis pattern@(DottedList ps p) input@(DottedList is i) = +checkLocal localEnv identifiers hasEllipsis pattern@(DottedList _ _) input@(DottedList _ _) = loadLocal localEnv identifiers pattern input False hasEllipsis -- throwError $ BadSpecialForm "Test" input checkLocal localEnv identifiers hasEllipsis pattern@(DottedList ps p) input@(List (i : is)) = do @@ -224,7 +222,7 @@ checkLocal localEnv identifiers hasEllipsis pattern@(List _) input@(List _) = loadLocal localEnv identifiers pattern input False hasEllipsis -checkLocal localEnv identifiers hasEllipsis _ _ = return $ Bool False +checkLocal _ _ _ _ _ = return $ Bool False -- Transform input by walking the tranform structure and creating a new structure -- with the same form, replacing identifiers in the tranform with those bound in localEnv @@ -253,31 +251,25 @@ -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..." else transformRule localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List []) -- Dotted list transform returned during processing... - List [Nil _, List elst] -> if ellipsisIndex == 0 + List [Nil _, List _] -> if ellipsisIndex == 0 -- First time through and no match ("zero" case). Use tail to move past the "..." then transformRule localEnv 0 (List $ result) (List $ tail ts) (List []) -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..." else transformRule localEnv 0 (List $ result) (List $ tail ts) (List []) - List t -> transformRule localEnv (ellipsisIndex + 1) (List $ result ++ [curT]) transform (List ellipsisList) + List _ -> transformRule localEnv (ellipsisIndex + 1) (List $ result ++ [curT]) transform (List ellipsisList) + _ -> throwError $ Default "Unexpected error" else do lst <- transformRule localEnv ellipsisIndex (List []) (List l) (List ellipsisList) case lst of - List [Nil _, l] -> return lst + List [Nil _, _] -> return lst List _ -> transformRule localEnv ellipsisIndex (List $ result ++ [lst]) (List ts) (List ellipsisList) Nil _ -> return lst - otherwise -> throwError $ BadSpecialForm "Macro transform error" $ List [lst, (List l), Number $ toInteger ellipsisIndex] - - where lastElementIsNil l = case (last l) of - Nil _ -> True - otherwise -> False - getListAtTail l = case (last l) of - List lst -> lst - + _ -> throwError $ BadSpecialForm "Macro transform error" $ List [lst, (List l), Number $ toInteger ellipsisIndex] -- TODO: vector transform (and taking vectors into account in other cases as well???) -transformRule localEnv ellipsisIndex (List result) transform@(List (dl@(DottedList ds d) : ts)) (List ellipsisList) = do +transformRule localEnv ellipsisIndex (List result) transform@(List (dl@(DottedList _ _) : ts)) (List ellipsisList) = do if macroElementMatchesMany transform then do -- Idea here is that we need to handle case where you have (pair ...) - EG: ((var . step) ...) @@ -290,46 +282,20 @@ else transformRule localEnv 0 (List $ ellipsisList ++ result) (List $ tail ts) (List []) -- This case is here because we need to process individual components of the pair to determine -- whether we are done with the match. It is similar to above but not exact... - List [Nil _, List elst] -> if ellipsisIndex == 0 + List [Nil _, List _] -> if ellipsisIndex == 0 -- First time through and no match ("zero" case). Use tail to move past the "..." then transformRule localEnv 0 (List $ result) (List $ tail ts) (List []) -- Done with zero-or-more match, append intermediate results (ellipsisList) and move past the "..." else transformRule localEnv 0 (List $ result) (List $ tail ts) (List []) List t -> transformRule localEnv (ellipsisIndex + 1) (List $ result ++ t) transform (List ellipsisList) + _ -> throwError $ Default "Unexpected error in transformRule" else do lst <- transformDottedList localEnv ellipsisIndex (List []) (List [dl]) (List ellipsisList) case lst of - List [Nil _, List l] -> return lst + List [Nil _, List _] -> return lst List l -> transformRule localEnv ellipsisIndex (List $ result ++ l) (List ts) (List ellipsisList) - Nil n -> return lst - otherwise -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [dl]), Number $ toInteger ellipsisIndex] + Nil _ -> return lst + _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [dl]), Number $ toInteger ellipsisIndex] - where transformDottedList :: Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal - transformDottedList localEnv ellipsisIndex (List result) transform@(List (DottedList ds d : ts)) (List ellipsisList) = do - lsto <- transformRule localEnv ellipsisIndex (List []) (List ds) (List ellipsisList) - case lsto of - List lst -> do - r <- transformRule localEnv ellipsisIndex (List []) (List [d]) (List ellipsisList) - case r of - -- Trailing symbol in the pattern may be neglected in the transform, so skip it... - List [List []] -> transformRule localEnv ellipsisIndex (List $ result ++ [List lst]) (List ts) (List ellipsisList) - -- TODO: the transform needs to be as follows: - -- - transform into a list if original input was a list - code is below but commented-out - -- - transform into a dotted list if original input was a dotted list - -- - -- Could implement this by calling a new function on input (ds?) that goes through it and - -- looks up each atom that it finds, looking for its src. The src (or Nil?) would then be returned - -- and used here to determine what type of transform is used. - -- --- List [rst] -> transformRule localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList) --- List [rst] -> transformRule localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList) - List [rst] -> do - src <- lookupPatternVarSrc localEnv $ List ds - case src of - String "pair" -> transformRule localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList) - otherwise -> transformRule localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList) - otherwise -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d - Nil _ -> return $ List [Nil "", List ellipsisList] - otherwise -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d -- Transform an atom by attempting to look it up as a var... transformRule localEnv ellipsisIndex (List result) transform@(List (Atom a : ts)) unused = do @@ -354,31 +320,62 @@ List v -> if (length v) > (ellipsisIndex - 1) then return $ v !! (ellipsisIndex - 1) else return $ Nil "" + _ -> throwError $ Default "Unexpected error in transformRule" else return var else return $ Atom a case t of Nil _ -> return t - otherwise -> transformRule localEnv ellipsisIndex (List $ result ++ [t]) (List ts) unused + _ -> transformRule localEnv ellipsisIndex (List $ result ++ [t]) (List ts) unused -- Transform anything else as itself... -transformRule localEnv ellipsisIndex (List result) transform@(List (t : ts)) (List ellipsisList) = do +transformRule localEnv ellipsisIndex (List result) (List (t : ts)) (List ellipsisList) = do transformRule localEnv ellipsisIndex (List $ result ++ [t]) (List ts) (List ellipsisList) -- Base case - empty transform -transformRule localEnv ellipsisIndex result@(List _) transform@(List []) unused = do +transformRule _ _ result@(List _) (List []) _ = do return result -transformRule localEnv ellipsisIndex result transform unused = do +transformRule _ ellipsisIndex result transform unused = do throwError $ BadSpecialForm "An error occurred during macro transform" $ List [(Number $ toInteger ellipsisIndex), result, transform, unused] +transformDottedList :: Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal +transformDottedList localEnv ellipsisIndex (List result) (List (DottedList ds d : ts)) (List ellipsisList) = do + lsto <- transformRule localEnv ellipsisIndex (List []) (List ds) (List ellipsisList) + case lsto of + List lst -> do + r <- transformRule localEnv ellipsisIndex (List []) (List [d]) (List ellipsisList) + case r of + -- Trailing symbol in the pattern may be neglected in the transform, so skip it... + List [List []] -> transformRule localEnv ellipsisIndex (List $ result ++ [List lst]) (List ts) (List ellipsisList) + -- TODO: the transform needs to be as follows: + -- - transform into a list if original input was a list - code is below but commented-out + -- - transform into a dotted list if original input was a dotted list + -- + -- Could implement this by calling a new function on input (ds?) that goes through it and + -- looks up each atom that it finds, looking for its src. The src (or Nil?) would then be returned + -- and used here to determine what type of transform is used. + -- +-- List [rst] -> transformRule localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList) +-- List [rst] -> transformRule localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList) + List [rst] -> do + src <- lookupPatternVarSrc localEnv $ List ds + case src of + String "pair" -> transformRule localEnv ellipsisIndex (List $ result ++ [DottedList lst rst]) (List ts) (List ellipsisList) + _ -> transformRule localEnv ellipsisIndex (List $ result ++ [List $ lst ++ [rst]]) (List ts) (List ellipsisList) + _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d + Nil _ -> return $ List [Nil "", List ellipsisList] + _ -> throwError $ BadSpecialForm "Macro transform error processing pair" $ DottedList ds d + +transformDottedList _ _ _ _ _ = throwError $ Default "Unexpected error in transformDottedList" + -- Find an atom in a list; non-recursive (IE, a sub-list will not be inspected) findAtom :: LispVal -> LispVal -> IOThrowsError LispVal findAtom (Atom target) (List (Atom a:as)) = do if target == a then return $ Bool True else findAtom (Atom target) (List as) -findAtom target (List (badtype : _)) = throwError $ TypeMismatch "symbol" badtype -- TODO: test this, non-atoms should throw err -findAtom target _ = return $ Bool False +findAtom _ (List (badtype : _)) = throwError $ TypeMismatch "symbol" badtype -- TODO: test this, non-atoms should throw err +findAtom _ _ = return $ Bool False -- Initialize any pattern variables as an empty list. -- That way a zero-match case can be identified later during transformation. @@ -395,8 +392,9 @@ List (p:ps) -> do initializePatternVars localEnv src identifiers p initializePatternVars localEnv src identifiers $ List ps List [] -> return $ Bool True + _ -> return $ Bool True -initializePatternVars localEnv src identifiers pattern@(DottedList ps p) = do +initializePatternVars localEnv src identifiers (DottedList ps p) = do initializePatternVars localEnv src identifiers $ List ps initializePatternVars localEnv src identifiers p @@ -417,9 +415,9 @@ else do return $ Bool True -- Ignore identifiers since they are just passed along as-is - otherwise -> return $ Bool True + _ -> return $ Bool True -initializePatternVars localEnv src identifiers pattern = +initializePatternVars _ _ _ _ = return $ Bool True -- Find the first pattern var that reports being from a src, or False if none @@ -429,14 +427,15 @@ List (p:ps) -> do result <- lookupPatternVarSrc localEnv p case result of Bool False -> lookupPatternVarSrc localEnv $ List ps - otherwise -> return result + _ -> return result List [] -> return $ Bool False + _ -> return $ Bool False -lookupPatternVarSrc localEnv pattern@(DottedList ps p) = do +lookupPatternVarSrc localEnv (DottedList ps p) = do result <- lookupPatternVarSrc localEnv $ List ps case result of Bool False -> lookupPatternVarSrc localEnv p - otherwise -> return result + _ -> return result -- TODO: vector @@ -445,5 +444,5 @@ if isDefined then getNamespacedVar localEnv "src" pattern else return $ Bool False -lookupPatternVarSrc localEnv pattern = +lookupPatternVarSrc _ _ = return $ Bool False diff --git a/hs-src/Scheme/Numerical.hs b/hs-src/Scheme/Numerical.hs --- a/hs-src/Scheme/Numerical.hs +++ b/hs-src/Scheme/Numerical.hs @@ -5,21 +5,19 @@ - Numerical tower functionality - - @author Justin Ethier - - + - - -} module Scheme.Numerical where import Scheme.Types -import Scheme.Variables import Complex import Control.Monad.Error -import Numeric import Ratio import Text.Printf numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal -numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal -numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op +numericBinop _ singleVal@[_] = throwError $ NumArgs 2 singleVal +numericBinop op aparams = mapM unpackNum aparams >>= return . Number . foldl1 op --- Begin GenUtil - http://repetae.net/computer/haskell/GenUtil.hs foldlM :: Monad m => (a -> b -> m a) -> a -> [b] -> m a @@ -28,7 +26,7 @@ foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a foldl1M f (x:xs) = foldlM f x xs -foldl1M _ _ = error "foldl1M" +foldl1M _ _ = error "Unexpected error in foldl1M" -- end GenUtil @@ -36,34 +34,41 @@ -- TODO: move all of this out into its own file numAdd, numSub, numMul, numDiv :: [LispVal] -> ThrowsError LispVal -numAdd params = do - foldl1M (\a b -> doAdd =<< (numCast [a, b])) params +numAdd [] = throwError $ NumArgs 1 [] +numAdd aparams = do + foldl1M (\a b -> doAdd =<< (numCast [a, b])) aparams where doAdd (List [(Number a), (Number b)]) = return $ Number $ a + b doAdd (List [(Float a), (Float b)]) = return $ Float $ a + b doAdd (List [(Rational a), (Rational b)]) = return $ Rational $ a + b doAdd (List [(Complex a), (Complex b)]) = return $ Complex $ a + b + doAdd _ = throwError $ Default "Unexpected error in +" +numSub [] = throwError $ NumArgs 1 [] numSub [Number n] = return $ Number $ -1 * n numSub [Float n] = return $ Float $ -1 * n numSub [Rational n] = return $ Rational $ -1 * n numSub [Complex n] = return $ Complex $ -1 * n -numSub params = do - foldl1M (\a b -> doSub =<< (numCast [a, b])) params +numSub aparams = do + foldl1M (\a b -> doSub =<< (numCast [a, b])) aparams where doSub (List [(Number a), (Number b)]) = return $ Number $ a - b doSub (List [(Float a), (Float b)]) = return $ Float $ a - b doSub (List [(Rational a), (Rational b)]) = return $ Rational $ a - b doSub (List [(Complex a), (Complex b)]) = return $ Complex $ a - b -numMul params = do - foldl1M (\a b -> doMul =<< (numCast [a, b])) params + doSub _ = throwError $ Default "Unexpected error in -" +numMul [] = throwError $ NumArgs 1 [] +numMul aparams = do + foldl1M (\a b -> doMul =<< (numCast [a, b])) aparams where doMul (List [(Number a), (Number b)]) = return $ Number $ a * b doMul (List [(Float a), (Float b)]) = return $ Float $ a * b doMul (List [(Rational a), (Rational b)]) = return $ Rational $ a * b doMul (List [(Complex a), (Complex b)]) = return $ Complex $ a * b + doMul _ = throwError $ Default "Unexpected error in *" +numDiv [] = throwError $ NumArgs 1 [] numDiv [Number n] = return $ Rational $ 1 / (fromInteger n) numDiv [Float n] = return $ Float $ 1.0 / n numDiv [Rational n] = return $ Rational $ 1 / n numDiv [Complex n] = return $ Complex $ 1 / n -numDiv params = do -- TODO: for Number type, need to cast results to Rational, per R5RS spec - foldl1M (\a b -> doDiv =<< (numCast [a, b])) params +numDiv aparams = do -- TODO: for Number type, need to cast results to Rational, per R5RS spec + foldl1M (\a b -> doDiv =<< (numCast [a, b])) aparams where doDiv (List [(Number a), (Number b)]) = if b == 0 then throwError $ DivideByZero else return $ Number $ div a b @@ -76,42 +81,53 @@ doDiv (List [(Complex a), (Complex b)]) = if b == 0 then throwError $ DivideByZero else return $ Complex $ a / b + doDiv _ = throwError $ Default "Unexpected error in /" numBoolBinopEq :: [LispVal] -> ThrowsError LispVal -numBoolBinopEq params = do - foldl1M (\a b -> doOp =<< (numCast [a, b])) params +numBoolBinopEq [] = throwError $ NumArgs 0 [] +numBoolBinopEq aparams = do + foldl1M (\a b -> doOp =<< (numCast [a, b])) aparams where doOp (List [(Number a), (Number b)]) = return $ Bool $ a == b doOp (List [(Float a), (Float b)]) = return $ Bool $ a == b doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a == b doOp (List [(Complex a), (Complex b)]) = return $ Bool $ a == b + doOp _ = throwError $ Default "Unexpected error in =" numBoolBinopGt :: [LispVal] -> ThrowsError LispVal -numBoolBinopGt params = do - foldl1M (\a b -> doOp =<< (numCast [a, b])) params +numBoolBinopGt [] = throwError $ NumArgs 0 [] +numBoolBinopGt aparams = do + foldl1M (\a b -> doOp =<< (numCast [a, b])) aparams where doOp (List [(Number a), (Number b)]) = return $ Bool $ a > b doOp (List [(Float a), (Float b)]) = return $ Bool $ a > b doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a > b + doOp _ = throwError $ Default "Unexpected error in >" numBoolBinopGte :: [LispVal] -> ThrowsError LispVal -numBoolBinopGte params = do - foldl1M (\a b -> doOp =<< (numCast [a, b])) params +numBoolBinopGte [] = throwError $ NumArgs 0 [] +numBoolBinopGte aparams = do + foldl1M (\a b -> doOp =<< (numCast [a, b])) aparams where doOp (List [(Number a), (Number b)]) = return $ Bool $ a >= b doOp (List [(Float a), (Float b)]) = return $ Bool $ a >= b doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a >= b + doOp _ = throwError $ Default "Unexpected error in >=" numBoolBinopLt :: [LispVal] -> ThrowsError LispVal -numBoolBinopLt params = do - foldl1M (\a b -> doOp =<< (numCast [a, b])) params +numBoolBinopLt [] = throwError $ NumArgs 0 [] +numBoolBinopLt aparams = do + foldl1M (\a b -> doOp =<< (numCast [a, b])) aparams where doOp (List [(Number a), (Number b)]) = return $ Bool $ a < b doOp (List [(Float a), (Float b)]) = return $ Bool $ a < b doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a < b + doOp _ = throwError $ Default "Unexpected error in <" numBoolBinopLte :: [LispVal] -> ThrowsError LispVal -numBoolBinopLte params = do - foldl1M (\a b -> doOp =<< (numCast [a, b])) params +numBoolBinopLte [] = throwError $ NumArgs 0 [] +numBoolBinopLte aparams = do + foldl1M (\a b -> doOp =<< (numCast [a, b])) aparams where doOp (List [(Number a), (Number b)]) = return $ Bool $ a <= b doOp (List [(Float a), (Float b)]) = return $ Bool $ a <= b doOp (List [(Rational a), (Rational b)]) = return $ Bool $ a <= b + doOp _ = throwError $ Default "Unexpected error in <=" numCast :: [LispVal] -> ThrowsError LispVal numCast [a@(Number _), b@(Number _)] = return $ List [a, b] @@ -135,9 +151,9 @@ Float _ -> doThrowError b Rational _ -> doThrowError b Complex _ -> doThrowError b - otherwise -> doThrowError a - where doThrowError a = throwError $ TypeMismatch "number" a - + _ -> doThrowError a + where doThrowError num = throwError $ TypeMismatch "number" num +numCast _ = throwError $ Default "Unexpected error in numCast" numRound, numFloor, numCeiling, numTruncate :: [LispVal] -> ThrowsError LispVal numRound [n@(Number _)] = return n @@ -233,7 +249,7 @@ numExpt [(Rational n), (Number p)] = return $ Float $ (fromRational n) ^ p numExpt [(Float n), (Number p)] = return $ Float $ n ^ p numExpt [(Complex n), (Number p)] = return $ Complex $ n ^ p -numExpt [x, y] = throwError $ TypeMismatch "integer" y +numExpt [_, y] = throwError $ TypeMismatch "integer" y numExpt badArgList = throwError $ NumArgs 2 badArgList {-numExpt params = do @@ -305,11 +321,15 @@ numExact2Inexact [(Rational n)] = return $ Float $ fromRational n numExact2Inexact [n@(Float _)] = return n -- TODO: numExact2Inexact [(Complex n)] = return ?? +numExact2Inexact [badType] = throwError $ TypeMismatch "number" badType +numExact2Inexact badArgList = throwError $ NumArgs 1 badArgList numInexact2Exact [n@(Number _)] = return n numInexact2Exact [n@(Rational _)] = return n numInexact2Exact [(Float n)] = return $ Number $ round n -- TODO: numInexact2Exact [(Complex n)] = return ?? +numInexact2Exact [badType] = throwError $ TypeMismatch "number" badType +numInexact2Exact badArgList = throwError $ NumArgs 1 badArgList -- TODO: remember to support both forms: -- procedure: (number->string z) @@ -322,7 +342,7 @@ 8 -> return $ String $ printf "%o" n 10 -> return $ String $ printf "%d" n 16 -> return $ String $ printf "%x" n - otherwise -> throwError $ BadSpecialForm "Invalid radix value" $ Number radix + _ -> throwError $ BadSpecialForm "Invalid radix value" $ Number radix num2String [n@(Rational _)] = return $ String $ show n num2String [(Float n)] = return $ String $ show n num2String [n@(Complex _)] = return $ String $ show n @@ -333,8 +353,8 @@ -- and extend to support all of the tower... isNumber, isComplex, isReal, isRational, isInteger :: [LispVal] -> ThrowsError LispVal -isNumber ([Number n]) = return $ Bool True -isNumber ([Float f]) = return $ Bool True +isNumber ([Number _]) = return $ Bool True +isNumber ([Float _]) = return $ Bool True isNumber ([Complex _]) = return $ Bool True isNumber ([Rational _]) = return $ Bool True isNumber _ = return $ Bool False diff --git a/hs-src/Scheme/Parser.hs b/hs-src/Scheme/Parser.hs --- a/hs-src/Scheme/Parser.hs +++ b/hs-src/Scheme/Parser.hs @@ -38,14 +38,15 @@ return $ case x of 't' -> Bool True 'f' -> Bool False + _ -> Bool False parseChar :: Parser LispVal parseChar = do try (string "#\\") c <- anyChar r <- many(letter) - let chr = c:r - return $ case chr of + let pchr = c:r + return $ case pchr of "space" -> Char ' ' "newline" -> Char '\n' _ -> Char c {- TODO: err if invalid char -} @@ -57,7 +58,7 @@ num <- many1(oneOf "01234567") case (length sign) of 0 -> return $ Number $ fst $ Numeric.readOct num !! 0 - 1 -> return $ Number $ toInteger $ (*) (-1) $ fst $ Numeric.readOct num !! 0 + 1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ Numeric.readOct num !! 0 _ -> pzero parseBinaryNumber :: Parser LispVal @@ -67,7 +68,7 @@ num <- many1(oneOf "01") case (length sign) of 0 -> return $ Number $ fst $ Numeric.readInt 2 (`elem` "01") Char.digitToInt num !! 0 - 1 -> return $ Number $ toInteger $ (*) (-1) $ fst $ Numeric.readInt 2 (`elem` "01") Char.digitToInt num !! 0 + 1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ Numeric.readInt 2 (`elem` "01") Char.digitToInt num !! 0 _ -> pzero parseHexNumber :: Parser LispVal @@ -77,7 +78,7 @@ num <- many1(digit <|> oneOf "abcdefABCDEF") case (length sign) of 0 -> return $ Number $ fst $ Numeric.readHex num !! 0 - 1 -> return $ Number $ toInteger $ (*) (-1) $ fst $ Numeric.readHex num !! 0 + 1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ Numeric.readHex num !! 0 _ -> pzero -- |Parser for Integer, base 10 @@ -118,8 +119,8 @@ parseRationalNumber :: Parser LispVal parseRationalNumber = do - numerator <- parseDecimalNumber - case numerator of + pnumerator <- parseDecimalNumber + case pnumerator of Number n -> do char '/' sign <- many (oneOf "-") @@ -127,7 +128,7 @@ if (length sign) > 1 then pzero else return $ Rational $ n % (read $ sign ++ num) - otherwise -> pzero + _ -> pzero parseComplexNumber :: Parser LispVal parseComplexNumber = do @@ -135,14 +136,18 @@ let real = case lispreal of Number n -> fromInteger n Float f -> f + _ -> 0 char '+' lispimag <- (try(parseRealNumber) <|> parseDecimalNumber) let imag = case lispimag of Number n -> fromInteger n Float f -> f + _ -> 0 -- Case should never be reached char 'i' return $ Complex $ real :+ imag +parseEscapedChar :: forall st. + GenParser Char st Char parseEscapedChar = do char '\\' c <- anyChar @@ -170,9 +175,9 @@ parseDottedList :: Parser LispVal parseDottedList = do - head <- endBy parseExpr spaces - tail <- char '.' >> spaces >> parseExpr - return $ DottedList head tail + phead <- endBy parseExpr spaces + ptail <- char '.' >> spaces >> parseExpr + return $ DottedList phead ptail parseQuoted :: Parser LispVal parseQuoted = do @@ -238,6 +243,9 @@ Left err -> throwError $ Parser err Right val -> return val +readExpr :: String -> ThrowsError LispVal readExpr = readOrThrow parseExpr + +readExprList :: String -> ThrowsError [LispVal] readExprList = readOrThrow (endBy parseExpr spaces) diff --git a/hs-src/Scheme/Types.hs b/hs-src/Scheme/Types.hs --- a/hs-src/Scheme/Types.hs +++ b/hs-src/Scheme/Types.hs @@ -1,4 +1,4 @@ -{- +{-- - husk scheme - Types - @@ -11,14 +11,12 @@ - -} module Scheme.Types where import Complex -import Control.Monad import Control.Monad.Error import Data.Array import Data.IORef import qualified Data.Map import IO hiding (try) import Ratio -import System.Environment import Text.ParserCombinators.Parsec hiding (spaces) {- Environment management -} @@ -28,13 +26,15 @@ -- |An empty environment nullEnv :: IO Env -nullEnv = do bindings <- newIORef [] - return $ Environment Nothing bindings +nullEnv = do nullBindings <- newIORef [] + return $ Environment Nothing nullBindings -- Internal namespace for macros +macroNamespace :: [Char] macroNamespace = "m" -- Internal namespace for variables +varNamespace :: [Char] varNamespace = "v" -- |Types of errors that may occur when evaluating Scheme code @@ -60,6 +60,7 @@ showError (UnboundVar message varname) = message ++ ": " ++ varname showError (DivideByZero) = "Division by zero" showError (NotImplemented message) = "Not implemented: " ++ message +showError (Default message) = "Error: " ++ message instance Show LispError where show = showError instance Error LispError where @@ -68,10 +69,14 @@ type ThrowsError = Either LispError +trapError :: -- forall (m :: * -> *) e. + (MonadError e m, Show e) => + m String -> m String trapError action = catchError action (return . show) extractValue :: ThrowsError a -> a extractValue (Right val) = val +extractValue (Left _) = error "Unexpected error in extractValue; " type IOThrowsError = ErrorT LispError IO @@ -82,7 +87,6 @@ runIOThrows :: IOThrowsError String -> IO String runIOThrows action = runErrorT (trapError action) >>= return . extractValue - -- |Scheme data types data LispVal = Atom String -- ^Symbol @@ -114,16 +118,42 @@ vararg :: (Maybe String), body :: [LispVal], closure :: Env, - partialEval :: Bool - } -- TODO: continuation member? + partialEval :: Bool -- TODO: Obsolete, this member should be removed + } -- ^Function | IOFunc ([LispVal] -> IOThrowsError LispVal) -- ^ | Port Handle -- ^I/O port + | Continuation {closure :: Env, -- Environment of the continuation + body :: [LispVal], -- Code in the body of the continuation + continuation :: LispVal -- Code to resume after body of cont + , frameFunc :: (Maybe LispVal) +-- , frameRawArgs :: (Maybe [LispVal]) + , frameEvaledArgs :: (Maybe [LispVal]) + -- + --TODO: frame information + -- for evaluating a function (prior to calling) need: + -- - function obj + -- - list of args + -- + -- TODO: for TCO within a function, need: + -- - calling function name (or some unique ID, for lambda's) + -- - calling function arg values + -- may be able to have a single frame object take care of both + -- purposes. but before implementing this, do a bit more research + -- to verify the approach. + -- + -- + -- FUTURE: stack (for dynamic wind) + } + -- ^Continuation | Nil String -- ^Internal use only; do not use this type directly. +makeNullContinuation :: Env -> LispVal +makeNullContinuation env = Continuation env [] (Nil "") Nothing Nothing + instance Ord LispVal where compare (Bool a) (Bool b) = compare a b compare (Number a) (Number b) = compare a b @@ -155,7 +185,7 @@ eqv [(HashTable arg1), (HashTable arg2)] = eqv [List $ (map (\(x, y) -> List [x, y]) $ Data.Map.toAscList arg1), List $ (map (\(x, y) -> List [x, y]) $ Data.Map.toAscList arg2)] -eqv [l1@(List arg1), l2@(List arg2)] = eqvList eqv [l1, l2] +eqv [l1@(List _), l2@(List _)] = eqvList eqv [l1, l2] eqv [_, _] = return $ Bool False eqv badArgList = throwError $ NumArgs 2 badArgList @@ -163,15 +193,18 @@ eqvList eqvFunc [(List arg1), (List arg2)] = return $ Bool $ (length arg1 == length arg2) && (all eqvPair $ zip arg1 arg2) where eqvPair (x1, x2) = case eqvFunc [x1, x2] of - Left err -> False + Left _ -> False Right (Bool val) -> val + _ -> False -- OK? +eqvList _ _ = throwError $ Default "Unexpected error in eqvList" eqVal :: LispVal -> LispVal -> Bool eqVal a b = do let result = eqv [a, b] case result of - Left err -> False + Left _ -> False Right (Bool val) -> val + _ -> False -- Is this OK? instance Eq LispVal where x == y = eqVal x y @@ -191,9 +224,10 @@ showVal (Vector contents) = "#(" ++ (unwordsList $ Data.Array.elems contents) ++ ")" showVal (HashTable _) = "" showVal (List contents) = "(" ++ unwordsList contents ++ ")" -showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")" +showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")" showVal (PrimitiveFunc _) = "" -showVal (Func {params = args, vararg = varargs, body = body, closure = env}) = +showVal (Continuation {closure = _, body = _}) = "" +showVal (Func {params = args, vararg = varargs, body = _, closure = _}) = "(lambda (" ++ unwords (map show args) ++ (case varargs of Nothing -> "" diff --git a/hs-src/Scheme/Variables.hs b/hs-src/Scheme/Variables.hs --- a/hs-src/Scheme/Variables.hs +++ b/hs-src/Scheme/Variables.hs @@ -9,7 +9,6 @@ - -} module Scheme.Variables where import Scheme.Types -import Control.Monad import Control.Monad.Error import Data.IORef @@ -70,7 +69,7 @@ namespace var value = do env <- liftIO $ readIORef $ bindings envRef case lookup (namespace, var) env of - (Just a) -> do vprime <- liftIO $ readIORef a + (Just a) -> do --vprime <- liftIO $ readIORef a liftIO $ writeIORef a value return value Nothing -> case parentEnv envRef of diff --git a/hs-src/shell.hs b/hs-src/shell.hs --- a/hs-src/shell.hs +++ b/hs-src/shell.hs @@ -33,25 +33,26 @@ runOne :: [String] -> IO () runOne args = do env <- primitiveBindings >>= flip extendEnv [((varNamespace, "args"), List $ map String $ drop 1 args)] - (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)])) + (runIOThrows $ liftM show $ eval env (makeNullContinuation env) (List [Atom "load", String (args !! 0)])) -- TODO: replace with evalLisp >>= hPutStrLn stderr -- echo this or not?? -- Call into (main) if it exists... alreadyDefined <- liftIO $ isBound env "main" let argv = List $ map String $ args if alreadyDefined - then (runIOThrows $ liftM show $ eval env (List [Atom "main", List [Atom "quote", argv]])) >>= hPutStrLn stderr - else (runIOThrows $ liftM show $ eval env $ Nil "") >>= hPutStrLn stderr + -- TODO: replace eval's below with evalLisp + then (runIOThrows $ liftM show $ eval env (makeNullContinuation env) (List [Atom "main", List [Atom "quote", argv]])) >>= hPutStrLn stderr + else (runIOThrows $ liftM show $ eval env (makeNullContinuation env) $ Nil "") >>= hPutStrLn stderr showBanner :: IO () showBanner = do putStrLn " __ __ __ __ ______ __ __ " putStrLn "/\\ \\_\\ \\ /\\ \\/\\ \\ /\\ ___\\ /\\ \\/ / Scheme Interpreter " - putStrLn "\\ \\ __ \\ \\ \\ \\_\\ \\ \\ \\___ \\ \\ \\ _\\\"-. Version 1.2" + putStrLn "\\ \\ __ \\ \\ \\ \\_\\ \\ \\ \\___ \\ \\ \\ _\\\"-. Version 1.3" putStrLn " \\ \\_\\ \\_\\ \\ \\_____\\ \\/\\_____\\ \\ \\_\\ \\_\\ (c) 2010 Justin Ethier " putStrLn " \\/_/\\/_/ \\/_____/ \\/_____/ \\/_/\\/_/ github.com/justinethier/husk-scheme " putStrLn "" - + runRepl :: IO () runRepl = do stdlib <- getDataFileName "stdlib.scm" 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: 1.2 +Version: 1.3 Synopsis: R5RS Scheme interpreter program and library. Description: Husk is a dialect of Scheme written in Haskell that implements a subset of the R5RS standard. Husk is not intended to be a diff --git a/stdlib.scm b/stdlib.scm --- a/stdlib.scm +++ b/stdlib.scm @@ -222,7 +222,6 @@ (set! result-ready? #t) result)))))))) - ; Hash table derived forms (define hash-table-walk (lambda (ht proc)