diff --git a/README.markdown b/README.markdown --- a/README.markdown +++ b/README.markdown @@ -1,14 +1,14 @@ ![husk Scheme](https://github.com/justinethier/husk-scheme/raw/master/docs/husk-scheme.png) -husk is a dialect of Scheme written in Haskell that implements a subset of the [R5RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R5RS features are provided including continuations, hygienic macros, and a full numeric tower. +husk is a dialect of Scheme written in Haskell that implements a subset of the [R5RS standard](http://www.schemers.org/Documents/Standards/R5RS/HTML/). Advanced R5RS features are provided including continuations, hygienic macros, and a full numeric tower. -husk provides many features and is intended as a good choice for certain applications, however it is not a highly optimized version of Scheme. Rather, the goal of the project is to provide a tight integration between Haskell and Scheme while at the same time providing an opportunity for deeper understanding of both languages. In addition, by closely following the R5RS standard, the intent is to develop a Scheme that is as compatible as possible with other R5RS Schemes. +husk provides many features and is intended as a good choice for certain applications, however it is not a highly optimized version of Scheme. Rather, the goal of the project is to provide a tight integration between Haskell and Scheme while at the same time providing an opportunity for deeper understanding of both languages. In addition, by closely following the R5RS standard, the intent is to develop a Scheme that is as compatible as possible with other R5RS Schemes. Scheme is one of two main dialects of Lisp. Scheme follows a minimalist design philosophy: the core language consists of a small number of fundamental forms which may be used to implement the other built-in forms. Scheme is an excellent language for writing small, elegant programs, and may also be used to write scripts or embed scripting functionality within a larger application. Feature List ------------ -husk includes the following features from R5RS: +husk includes the following features from R5RS: - Primitive data types and their standard forms, including string, char, numbers (integer, rational, floating point, and complex), list, pair, vector, and symbols - Proper tail recursion @@ -23,7 +23,7 @@ - Basic IO functions - Standard library of Scheme functions - Read-Eval-Print-Loop (REPL) interpreter, with input driven by Haskeline to provide a rich user experience -- Full numeric tower: includes support for parsing/storing types (exact, inexact, etc), support for operations on these types as well as mixing types and other constraints from the R5RS specification. +- Full numeric tower: includes support for parsing/storing types (exact, inexact, etc), support for operations on these types as well as mixing types and other constraints from the R5RS specification. - Continuations: call/cc and first-class continuations. - Hygienic Macros: High-level macros via define-syntax - *Note this is still somewhat of a 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. @@ -55,8 +55,8 @@ A Haskell API is also provided to allow you to embed a Scheme interpreter within a Haskell program. The key API modules are: -- Scheme.Core - Contains functions to evaluate (execute) Scheme code. -- Scheme.Types - Contains Haskell data types used to represent Scheme primitives. +- Language.Scheme.Core - Contains functions to evaluate (execute) Scheme code. +- Language.Scheme.Types - Contains Haskell data types used to represent Scheme primitives. For more information, run `make doc` to generate API documentation from the source code. Also, see `shell.hs` for a quick example of how you might get started. diff --git a/hs-src/Language/Scheme/Core.hs b/hs-src/Language/Scheme/Core.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Scheme/Core.hs @@ -0,0 +1,1081 @@ +{- + - husk scheme interpreter + - + - A lightweight dialect of R5RS scheme. + - This file contains Core functionality, primarily Scheme expression evaluation. + - + - @author Justin Ethier + - + - -} + +module Language.Scheme.Core + ( + eval + , evalLisp + , evalString + , evalAndPrint + , primitiveBindings -- FUTURE: this may be a bad idea... + -- but there should be an interface to inject custom functions written in Haskell + ) where +import Language.Scheme.Macro +import Language.Scheme.Numerical +import Language.Scheme.Parser +import Language.Scheme.Types +import Language.Scheme.Variables +import Control.Monad.Error +import Char +import Data.Array +import qualified Data.Map +import Maybe +import List +import IO hiding (try) +import System.Directory (doesFileExist) +--import Debug.Trace + +{-| Evaluate a string containing Scheme code. + + For example: + +@ +env <- primitiveBindings + +evalString env "(+ x x x)" +"3" + +evalString env "(+ x x x (* 3 9))" +"30" + +evalString env "(* 3 9)" +"27" +@ +-} +evalString :: Env -> String -> IO String +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 + +-- |Evaluate lisp code that has already been loaded into haskell +-- +-- FUTURE: code example for this, via ghci and/or a custom Haskell program. +evalLisp :: Env -> LispVal -> IOThrowsError LispVal +evalLisp env lisp = macroEval env lisp >>= (eval env (makeNullContinuation env)) + + +{- continueEval is a support function for eval, below. + - + - 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 +-- Passing a higher-order function as the continuation; just evaluate it. This is +-- done to enable an 'eval' function to be broken up into multiple sub-functions, +-- so that any of the sub-functions can be passed around as a continuation. +-- +-- This perhaps shows cruft as we also pass cBody (scheme code) as a continuation. +-- We could probably just use higher-order functions instead, but both are used for +-- two different things. +continueEval _ (Continuation cEnv _ cCont funcArgs (Just func)) val = func cEnv cCont val funcArgs + +-- No higher order function, so: +-- +-- If there is Scheme code to evaluate in the function body, we continue to evaluate it. +-- +-- Otherwise, if all code in the function has been executed, we 'unwind' to an outer +-- continuation (if there is one), or we just return the result. Yes technically with +-- CPS you are supposed to keep calling into functions and never return, but eventually +-- when the computation is complete, you have to return something. +continueEval _ (Continuation cEnv cBody cCont Nothing Nothing) val = do + case cBody of + [] -> do + case cCont of + Continuation nEnv _ _ _ _ -> continueEval nEnv cCont val + _ -> return (val) + [lv] -> eval cEnv (Continuation cEnv [] cCont Nothing Nothing) (lv) + (lv : lvs) -> eval cEnv (Continuation cEnv lvs cCont Nothing Nothing) (lv) +continueEval _ _ _ = throwError $ Default "Internal error in continueEval" + +-- |Core eval function +-- Evaluate a scheme expression. +-- NOTE: This function does not include macro support and should not be called directly. Instead, use 'evalLisp' +-- +-- +-- Implementation Notes: +-- +-- Internally, this function is written in continuation passing style (CPS) to allow the Scheme language +-- itself to support first-class continuations. That is, at any point in the evaluation, call/cc may +-- be used to capture the current continuation. Thus this code must call into the next continuation point, eg: +-- +-- eval ... (makeCPS ...) +-- +-- Instead of calling eval directly from within the same function, eg: +-- +-- eval ... +-- eval ... +-- +-- This can make the code harder to follow, however some coding conventions have been established to make the +-- code easier to follow. Whenever a single function has been broken into multiple ones for the purpose of CPS, +-- those additional functions are defined locally using 'where', and each has been given a 'cps' prefix. +-- +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 + +-- Unquote an expression; unquoting is different than quoting in that +-- it may also be inter-spliced with code that is meant to be evaluated. +-- +-- +-- FUTURE: Issue #8 - https://github.com/justinethier/husk-scheme/issues/#issue/8 +-- need to take nesting of ` into account, as per spec: +-- +-- * Quasiquote forms may be nested. +-- * Substitutions are made only for unquoted components appearing at the +-- same nesting level as the outermost backquote. +-- * The nesting level increases by one inside each successive quasiquotation, +-- and decreases by one inside each unquotation. +-- +-- So the upshoot is that a new nesting level var needs to be threaded through, +-- and used to determine whether or not to evaluate an unquote. +-- +eval envi cont (List [Atom "quasiquote", value]) = cpsUnquote envi cont value Nothing + where cpsUnquote :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsUnquote e c val _ = do + case val of + List [Atom "unquote", vval] -> eval e c vval + List (_ : _) -> doCpsUnquoteList e c val + DottedList xs x -> do + doCpsUnquoteList e (makeCPSWArgs e c cpsUnquotePair $ [x] ) $ List xs + Vector vec -> do + let len = length (elems vec) + if len > 0 + then doCpsUnquoteList e (makeCPS e c cpsUnquoteVector) $ List $ elems vec + else continueEval e c $ Vector $ listArray (0, -1) [] + _ -> eval e c (List [Atom "quote", val]) -- Behave like quote if there is nothing to "unquote"... + + -- Unquote a pair + -- This must be started by unquoting the "left" hand side of the pair, + -- then pass a continuation to this function to unquote the right-hand side (RHS). + -- This function does the RHS and then calls into a continuation to finish the pair. + cpsUnquotePair :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsUnquotePair e c (List rxs) (Just [rx]) = do + cpsUnquote e (makeCPSWArgs e c cpsUnquotePairFinish $ [List rxs]) rx Nothing + cpsUnquotePair _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquotePair" + + -- Finish unquoting a pair by combining both of the unquoted left/right hand sides. + cpsUnquotePairFinish :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsUnquotePairFinish e c rx (Just [List rxs]) = do + case rx of + List [] -> continueEval e c $ List rxs + List rxlst -> continueEval e c $ List $ rxs ++ rxlst + DottedList rxlst rxlast -> continueEval e c $ DottedList (rxs ++ rxlst) rxlast + _ -> continueEval e c $ DottedList rxs rx + cpsUnquotePairFinish _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquotePairFinish" + + -- Unquote a vector + cpsUnquoteVector :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsUnquoteVector e c (List vList) _ = continueEval e c (Vector $ listArray (0, (length vList - 1)) vList) + cpsUnquoteVector _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteVector" + + -- Front-end to cpsUnquoteList, to encapsulate default values in the call + doCpsUnquoteList :: Env -> LispVal -> LispVal -> IOThrowsError LispVal + doCpsUnquoteList e c (List (x:xs)) = cpsUnquoteList e c x $ Just ([List xs, List []]) + doCpsUnquoteList _ _ _ = throwError $ InternalError "Unexpected parameters to doCpsUnquoteList" + + -- Unquote a list + cpsUnquoteList :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsUnquoteList e c val (Just ([List unEvaled, List acc])) = do + case val of + List [Atom "unquote-splicing", vvar] -> do + eval e (makeCPSWArgs e c cpsUnquoteSplicing $ [List unEvaled, List acc]) vvar + _ -> cpsUnquote e (makeCPSWArgs e c cpsUnquoteFld $ [List unEvaled, List acc]) val Nothing + cpsUnquoteList _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteList" + + -- Evaluate an expression instead of quoting it + cpsUnquoteSplicing :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsUnquoteSplicing e c val (Just ([List unEvaled, List acc])) = do + case val of + List v -> case unEvaled of + [] -> continueEval e c $ List $ acc ++ v + _ -> cpsUnquoteList e c (head unEvaled) (Just [List (tail unEvaled), List $ acc ++ v ]) + _ -> throwError $ TypeMismatch "proper list" val + cpsUnquoteSplicing _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteSplicing" + + -- Unquote processing for single field of a list + cpsUnquoteFld :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsUnquoteFld e c val (Just ([List unEvaled, List acc])) = do + case unEvaled of + [] -> continueEval e c $ List $ acc ++ [val] + _ -> cpsUnquoteList e c (head unEvaled) (Just [List (tail unEvaled), List $ acc ++ [val] ]) + cpsUnquoteFld _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteFld" + +eval env cont (List [Atom "if", predic, conseq, alt]) = do + eval env (makeCPS env cont cps) (predic) + where cps :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cps e c result _ = + case (result) of + Bool False -> eval e c alt + _ -> eval e c conseq + +eval env cont (List [Atom "if", predic, conseq]) = + eval env (makeCPS env cont cpsResult) predic + where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsResult e c result _ = + case result of + Bool True -> eval e c conseq + _ -> continueEval e c $ Atom "#unspecified" -- Unspecified return value per R5RS + +-- FUTURE: convert cond to a derived form (scheme macro) +eval env cont (List (Atom "cond" : clauses)) = + 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, evalue 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 (List (Atom "begin" : funcs)) = + if length funcs == 0 + then eval env cont $ Nil "" + else if length funcs == 1 + then eval env cont (head funcs) + else eval env (makeCPSWArgs env cont cpsRest $ tail funcs) (head funcs) + where cpsRest :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsRest e c _ args = + case args of + Just fArgs -> eval e c $ List (Atom "begin" : fArgs) + Nothing -> throwError $ Default "Unexpected error in begin" + + +eval env cont (List [Atom "load", String filename]) = do + 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 cont (List [Atom "set!", Atom var, form]) = do + eval env (makeCPS env cont cpsResult) form + where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsResult e c result _ = setVar e var result >>= continueEval e c + +eval env cont (List [Atom "define", Atom var, form]) = do + eval env (makeCPS env cont cpsResult) form + where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsResult e c result _ = defineVar e var result >>= continueEval e c + +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 cont (List [Atom "string-fill!", Atom var, character]) = do + eval env (makeCPS env cont cpsVar) =<< getVar env var + where cpsVar :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsVar e c result _ = eval e (makeCPSWArgs e c cpsChr $ [result]) $ character + + cpsChr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsChr e c result (Just [rVar]) = (fillStr(rVar, result) >>= setVar e var) >>= continueEval e c + cpsChr _ _ _ _ = throwError $ Default "Unexpected error in string-fill!" + + 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 + eval env (makeCPS env cont cpsStr) i + where + cpsStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsStr e c idx _ = eval e (makeCPSWArgs e c cpsSubStr $ [idx]) =<< getVar e var + + cpsSubStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsSubStr e c str (Just [idx]) = + substr(str, character, idx) >>= setVar e var >>= continueEval e c + cpsSubStr _ _ _ _ = throwError $ InternalError "Invalid argument to cpsSubStr" + + substr (String str, Char char, Number ii) = do + return $ String $ (take (fromInteger ii) . drop 0) str ++ + [char] ++ + (take (length str) . drop (fromInteger ii + 1)) str + substr (String _, Char _, n) = throwError $ TypeMismatch "number" n + substr (String _, c, _) = throwError $ TypeMismatch "character" c + substr (s, _, _) = throwError $ TypeMismatch "string" s + +eval env cont (List [Atom "set-cdr!", Atom var, argObj]) = do +-- eval env (makeCPS env cont cpsObj) =<< getVar env var + continueEval env (makeCPS env cont cpsObj) =<< getVar env var + where + cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsObj _ _ pair@(List []) _ = throwError $ TypeMismatch "pair" pair + cpsObj e c pair@(List (_:_)) _ = eval e (makeCPSWArgs e c cpsSet $ [pair]) argObj + cpsObj e c pair@(DottedList _ _) _ = eval e (makeCPSWArgs e c cpsSet $ [pair]) argObj + cpsObj _ _ pair _ = throwError $ TypeMismatch "pair" pair + + cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsSet e c obj (Just [List (l : _)]) = setVar e var (DottedList [l] obj) >>= continueEval e c + cpsSet e c obj (Just [DottedList (l : _) _]) = setVar e var (DottedList [l] obj) >>= continueEval e c + cpsSet _ _ _ _ = throwError $ InternalError "Unexpected argument to cpsSet" + +eval env cont (List [Atom "vector-set!", Atom var, i, object]) = do + eval env (makeCPS env cont cpsObj) i + where + cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsObj e c idx _ = eval e (makeCPSWArgs e c cpsVec $ [idx]) object + + cpsVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsVec e c obj (Just [idx]) = eval e (makeCPSWArgs e c cpsUpdateVec $ [idx, obj]) =<< getVar e var + cpsVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsVec" + + cpsUpdateVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsUpdateVec e c vec (Just [idx, obj]) = + updateVector vec idx obj >>= setVar e var >>= continueEval e c + cpsUpdateVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsUpdateVec" + + 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 cont (List [Atom "vector-fill!", Atom var, object]) = do + eval env (makeCPS env cont cpsVec) object + where + cpsVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsVec e c obj _ = eval e (makeCPSWArgs e c cpsFillVec $ [obj]) =<< getVar e var + + cpsFillVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsFillVec e c vec (Just [obj]) = + fillVector vec obj >>= setVar e var >>= continueEval e c + cpsFillVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsFillVec" + + fillVector :: LispVal -> LispVal -> IOThrowsError LispVal + fillVector (Vector vec) obj = do + let l = replicate (lenVector vec) obj + return $ Vector $ (listArray (0, length l - 1)) l + fillVector v _ = throwError $ TypeMismatch "vector" v + lenVector v = length (elems v) + +eval env cont (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do + eval env (makeCPS env cont cpsValue) rkey + where + cpsValue :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsValue e c key _ = eval e (makeCPSWArgs e c cpsH $ [key]) rvalue + + cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsH e c value (Just [key]) = eval e (makeCPSWArgs e c cpsEvalH $ [key, value]) =<< getVar e var + cpsH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsH" + + cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsEvalH e c h (Just [key, value]) = do + case h of + HashTable ht -> do + setVar env var (HashTable $ Data.Map.insert key value ht) >>= eval e c + other -> throwError $ TypeMismatch "hash-table" other + cpsEvalH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsEvalH" + +eval env cont (List [Atom "hash-table-delete!", Atom var, rkey]) = do + eval env (makeCPS env cont cpsH) rkey + where + cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsH e c key _ = eval e (makeCPSWArgs e c cpsEvalH $ [key]) =<< getVar e var + + cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsEvalH e c h (Just [key]) = do + case h of + HashTable ht -> do + setVar env var (HashTable $ Data.Map.delete key ht) >>= eval e c + other -> throwError $ TypeMismatch "hash-table" other + cpsEvalH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsEvalH" + + +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" : applyArgs)) = do + eval env (makeCPSWArgs env cont cpsLast $ [List applyArgs]) $ head applyArgs + where cpsLast :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsLast e c proc (Just [List args]) = + eval e (makeCPSWArgs e c cpsArgs $ [proc, List $ tail $ reverse $ tail $ reverse args]) $ head $ reverse args + cpsLast _ _ _ _ = throwError $ InternalError "Invalid arguments to cpsLast" + + cpsArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsArgs e c lst (Just [proc, List args]) = + case args of + [] -> cpsApply c (Just [proc, lst, List args]) + _ -> eval e (makeCPSWArgs e c cpsEvalArgs $ [proc, lst, List $ tail args, List []]) $ head args + cpsArgs _ _ _ _ = throwError $ InternalError "Invalid arguments to cpsArgs" + + cpsEvalArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsEvalArgs e c result (Just [proc, lst, List args, List evaledArgs]) = + case args of + [] -> cpsApply c (Just [proc, lst, List (evaledArgs ++ [result])]) + (x:xs) -> eval e (makeCPSWArgs e c cpsEvalArgs $ [proc, lst, List xs, List (evaledArgs ++ [result])]) x + cpsEvalArgs _ _ _ _ = throwError $ InternalError "Invalid arguments to cpsEvalArgs" + + cpsApply :: LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsApply c (Just [proc, lst, List argVals]) = do + case lst of + List l -> apply c proc (argVals ++ l) + other -> throwError $ TypeMismatch "list" other + cpsApply _ _ = throwError $ InternalError "Invalid arguments to cpsApply" + +-- +-- +-- FUTURE: Issue #2: support for other continuation-related functions, such as +-- (dynamic-wind) +-- +-- + +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 e c (List [Atom "call/cc", proc]) = eval e (makeCPS e c cpsEval) proc + where + cpsEval :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsEval _ cont func _ = + case func of + PrimitiveFunc f -> do + result <- liftThrows $ f [cont] + case cont of + Continuation cEnv _ _ _ _ -> continueEval cEnv cont result + _ -> return result + Func aparams _ _ _ -> + if (toInteger $ length aparams) == 1 + then apply cont func [cont] + else throwError $ NumArgs (toInteger $ length aparams) [cont] + other -> throwError $ TypeMismatch "procedure" other + +-- Call a function by evaluating its arguments and then +-- executing it via 'apply'. +eval env cont (List (function : functionArgs)) = do + eval env (makeCPSWArgs env cont cpsPrepArgs $ functionArgs) function + where cpsPrepArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsPrepArgs e c func (Just args) = +-- case (trace ("prep eval of args: " ++ show args) args) of + case (args) of + [] -> apply c func [] -- No args, immediately apply the function + [a] -> eval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List []]) a + (a:as) -> eval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List as]) a + cpsPrepArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (1)" + -- Store value of previous argument, evaluate the next arg until all are done + -- parg - Previous argument that has now been evaluated + -- state - List containing the following, in order: + -- - Function to apply when args are ready + -- - List of evaluated parameters + -- - List of parameters awaiting evaluation + cpsEvalArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal + cpsEvalArgs e c evaledArg (Just [func, List argsEvaled, List argsRemaining]) = + case argsRemaining of + [] -> apply c func (argsEvaled ++ [evaledArg]) + [a] -> eval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List []]) a + (a:as) -> eval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List as]) a + + cpsEvalArgs _ _ _ (Just _) = throwError $ Default "Unexpected error in function application (1)" + cpsEvalArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (2)" + +eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm + +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 +makeNormalFunc :: (Monad m) => Env + -> [LispVal] + -> [LispVal] + -> m LispVal +makeNormalFunc = makeFunc Nothing +makeVarargs :: (Monad m) => LispVal -> Env + -> [LispVal] + -> [LispVal] + -> m LispVal +makeVarargs = makeFunc . Just . showVal + +-- Call into a Scheme function +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 +apply cont (IOFunc func) args = do + result <- func args + case cont of + Continuation cEnv _ _ _ _ -> continueEval cEnv cont result + _ -> return result +apply cont (PrimitiveFunc func) args = do + result <- liftThrows $ func args + case cont of + Continuation cEnv _ _ _ _ -> continueEval cEnv cont result + _ -> return result +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) + where remainingArgs = drop (length aparams) args + num = toInteger . length + -- + -- 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 _ Nothing -> if length cBody == 0 + then continueWCont env (evBody) cCont + else continueWCont env (evBody) cont -- Might be a problem, not fully optimizing + _ -> continueWCont env (evBody) cont + + -- Shortcut for calling continueEval + continueWCont cwcEnv cwcBody cwcCont = + continueEval cwcEnv (Continuation cwcEnv cwcBody cwcCont Nothing Nothing) $ Nil "" + + bindVarArgs arg env = case arg of + Just argName -> liftIO $ extendEnv env [((varNamespace, argName), List $ remainingArgs)] + Nothing -> return env +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 +-- in the standard library which must be pulled into the environment using (load). +primitiveBindings :: IO Env +primitiveBindings = nullEnv >>= (flip extendEnv $ map (domakeFunc IOFunc) ioPrimitives + ++ map (domakeFunc PrimitiveFunc) primitives) + where domakeFunc constructor (var, func) = ((varNamespace, var), constructor func) + +ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)] +ioPrimitives = [("open-input-file", makePort ReadMode), + ("open-output-file", makePort WriteMode), + ("close-input-port", closePort), + ("close-output-port", closePort), + ("read", readProc), + ("write", writeProc), + ("read-contents", readContents), + ("read-all", readAll)] + +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) +closePort _ = return $ Bool False + +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 = do + result <- liftIO $ doesFileExist filename + if result + then (liftIO $ readFile filename) >>= liftThrows . readExprList + else throwError $ Default $ "File does not exist: " ++ filename + +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), + ("-", numSub), + ("*", numMul), + ("/", numDiv), + ("modulo", numericBinop mod), + ("quotient", numericBinop quot), + ("remainder", numericBinop rem), + + ("round", numRound), + ("floor", numFloor), + ("ceiling", numCeiling), + ("truncate", numTruncate), + + ("numerator", numNumerator), + ("denominator", numDenominator), + + ("exp", numExp), + ("log", numLog), + ("sin", numSin), + ("cos", numCos), + ("tan", numTan), + ("asin", numAsin), + ("acos", numAcos), + ("atan", numAtan), + + ("sqrt", numSqrt), + ("expt", numExpt), + + ("make-rectangular", numMakeRectangular), + ("make-polar", numMakePolar), + ("real-part", numRealPart ), + ("imag-part", numImagPart), + ("magnitude", numMagnitude), + ("angle", numAngle ), + + ("exact->inexact", numExact2Inexact), + ("inexact->exact", numInexact2Exact), + + ("number->string", num2String), + + ("=", numBoolBinopEq), + (">", numBoolBinopGt), + (">=", numBoolBinopGte), + ("<", numBoolBinopLt), + ("<=", numBoolBinopLte), + + ("&&", boolBoolBinop (&&)), + ("||", boolBoolBinop (||)), + ("string=?", strBoolBinop (==)), + ("string?", strBoolBinop (>)), + ("string<=?", strBoolBinop (<=)), + ("string>=?", strBoolBinop (>=)), + ("string-ci=?", stringCIEquals), + ("string-ci?", stringCIBoolBinop (>)), + ("string-ci<=?", stringCIBoolBinop (<=)), + ("string-ci>=?", stringCIBoolBinop (>=)), + + ("car", car), + ("cdr", cdr), + ("cons", cons), + ("eq?", eqv), + ("eqv?", eqv), + ("equal?", equal), + + ("pair?", isDottedList), + ("procedure?", isProcedure), + ("number?", isNumber), + ("complex?", isComplex), + ("real?", isReal), + ("rational?", isRational), + ("integer?", isInteger), + ("list?", unaryOp isList), + ("null?", isNull), + ("symbol?", isSymbol), + ("symbol->string", symbol2String), + ("string->symbol", string2Symbol), + ("char?", isChar), + + ("vector?", unaryOp isVector), + ("make-vector", makeVector), + ("vector", buildVector), + ("vector-length", vectorLength), + ("vector-ref", vectorRef), + ("vector->list", vectorToList), + ("list->vector", listToVector), + + ("make-hash-table", hashTblMake), + ("hash-table?", isHashTbl), + ("hash-table-exists?", hashTblExists), + ("hash-table-ref", hashTblRef), + ("hash-table-size", hashTblSize), + ("hash-table->alist", hashTbl2List), + ("hash-table-keys", hashTblKeys), + ("hash-table-values", hashTblValues), + ("hash-table-copy", hashTblCopy), + + ("string?", isString), + ("string", buildString), + ("make-string", makeString), + ("string-length", stringLength), + ("string-ref", stringRef), + ("substring", substring), + ("string-append", stringAppend), + ("string->number", stringToNumber), + ("string->list", stringToList), + ("list->string", listToString), + ("string-copy", stringCopy), + + ("boolean?", isBoolean)] + +data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a) + +unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool +unpackEquals arg1 arg2 (AnyUnpacker unpacker) = + do unpacked1 <- unpacker arg1 + unpacked2 <- unpacker arg2 + return $ unpacked1 == unpacked2 + `catchError` (const $ return False) + +boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal +boolBinop unpacker op args = if length args /= 2 + then throwError $ NumArgs 2 args + else do left <- unpacker $ args !! 0 + right <- unpacker $ args !! 1 + return $ Bool $ left `op` right + +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 +strBoolBinop = boolBinop unpackStr +boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal +boolBoolBinop = boolBinop unpackBool + +unpackStr :: LispVal -> ThrowsError String +unpackStr (String s) = return s +unpackStr (Number s) = return $ show s +unpackStr (Bool s) = return $ show s +unpackStr notString = throwError $ TypeMismatch "string" notString + +unpackBool :: LispVal -> ThrowsError Bool +unpackBool (Bool b) = return b +unpackBool notBool = throwError $ TypeMismatch "boolean" notBool + +{- List primitives -} +car :: [LispVal] -> ThrowsError LispVal +car [List (x : _)] = return x +car [DottedList (x : _) _] = return x +car [badArg] = throwError $ TypeMismatch "pair" badArg +car badArgList = throwError $ NumArgs 1 badArgList + +cdr :: [LispVal] -> ThrowsError LispVal +cdr [List (_ : xs)] = return $ List xs +cdr [DottedList [_] x] = return x +cdr [DottedList (_ : xs) x] = return $ DottedList xs x +cdr [badArg] = throwError $ TypeMismatch "pair" badArg +cdr badArgList = throwError $ NumArgs 1 badArgList + +cons :: [LispVal] -> ThrowsError LispVal +cons [x1, List []] = return $ List [x1] +cons [x, List xs] = return $ List $ x : xs +cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast +cons [x1, x2] = return $ DottedList [x1] x2 +cons badArgList = throwError $ NumArgs 2 badArgList + +equal :: [LispVal] -> ThrowsError LispVal +equal [(Vector arg1), (Vector arg2)] = eqvList equal [List $ (elems arg1), List $ (elems arg2)] +equal [l1@(List _), l2@(List _)] = eqvList equal [l1, l2] +equal [(DottedList xs x), (DottedList ys y)] = equal [List $ xs ++ [x], List $ ys ++ [y]] +equal [arg1, arg2] = do + primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2) + [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool] + eqvEquals <- eqv [arg1, arg2] + return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x) +equal badArgList = throwError $ NumArgs 2 badArgList + +-------------- Vector Primitives -------------- + +makeVector, buildVector, vectorLength, vectorRef, vectorToList, listToVector :: [LispVal] -> ThrowsError LispVal +makeVector [(Number n)] = makeVector [Number n, List []] +makeVector [(Number n), a] = do + let l = replicate (fromInteger n) a + return $ Vector $ (listArray (0, length l - 1)) l +makeVector [badType] = throwError $ TypeMismatch "integer" badType +makeVector badArgList = throwError $ NumArgs 1 badArgList + +buildVector (o:os) = do + let lst = o:os + return $ Vector $ (listArray (0, length lst - 1)) lst +buildVector badArgList = throwError $ NumArgs 1 badArgList + +vectorLength [(Vector v)] = return $ Number $ toInteger $ length (elems v) +vectorLength [badType] = throwError $ TypeMismatch "vector" badType +vectorLength badArgList = throwError $ NumArgs 1 badArgList + +vectorRef [(Vector v), (Number n)] = return $ v ! (fromInteger n) +vectorRef [badType] = throwError $ TypeMismatch "vector integer" badType +vectorRef badArgList = throwError $ NumArgs 2 badArgList + +vectorToList [(Vector v)] = return $ List $ elems v +vectorToList [badType] = throwError $ TypeMismatch "vector" badType +vectorToList badArgList = throwError $ NumArgs 1 badArgList + +listToVector [(List l)] = return $ Vector $ (listArray (0, length l - 1)) l +listToVector [badType] = throwError $ TypeMismatch "list" badType +listToVector badArgList = throwError $ NumArgs 1 badArgList + +-------------- Hash Table Primitives -------------- + +-- Future: support (equal?), (hash) parameters +hashTblMake, isHashTbl, hashTblExists, hashTblRef, hashTblSize, hashTbl2List, hashTblKeys, hashTblValues, hashTblCopy:: [LispVal] -> ThrowsError LispVal +hashTblMake _ = return $ HashTable $ Data.Map.fromList [] + +isHashTbl [(HashTable _)] = return $ Bool True +isHashTbl _ = return $ Bool False + +hashTblExists [(HashTable ht), key@(_)] = do + 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 + Just val -> return $ val + Nothing -> throwError $ BadSpecialForm "Hash table does not contain key" key +hashTblRef [(HashTable ht), key@(_), Func _ _ _ _] = do + case Data.Map.lookup key ht of + Just val -> return $ val + Nothing -> throwError $ NotImplemented "thunk" +-- FUTURE: a thunk can optionally be specified, this drives definition of /default +-- Nothing -> apply thunk [] +hashTblRef [badType] = throwError $ TypeMismatch "hash-table" badType +hashTblRef badArgList = throwError $ NumArgs 2 badArgList + +hashTblSize [(HashTable ht)] = return $ Number $ toInteger $ Data.Map.size ht +hashTblSize [badType] = throwError $ TypeMismatch "hash-table" badType +hashTblSize badArgList = throwError $ NumArgs 1 badArgList + +hashTbl2List [(HashTable ht)] = do + return $ List $ map (\(k, v) -> List [k, v]) $ Data.Map.toList ht +hashTbl2List [badType] = throwError $ TypeMismatch "hash-table" badType +hashTbl2List badArgList = throwError $ NumArgs 1 badArgList + +hashTblKeys [(HashTable ht)] = do + return $ List $ map (\(k, _) -> k) $ Data.Map.toList ht +hashTblKeys [badType] = throwError $ TypeMismatch "hash-table" badType +hashTblKeys badArgList = throwError $ NumArgs 1 badArgList + +hashTblValues [(HashTable ht)] = do + return $ List $ map (\(_, v) -> v) $ Data.Map.toList ht +hashTblValues [badType] = throwError $ TypeMismatch "hash-table" badType +hashTblValues badArgList = throwError $ NumArgs 1 badArgList + +hashTblCopy [(HashTable ht)] = do + return $ HashTable $ Data.Map.fromList $ Data.Map.toList ht +hashTblCopy [badType] = throwError $ TypeMismatch "hash-table" badType +hashTblCopy badArgList = throwError $ NumArgs 1 badArgList + +-------------- String Primitives -------------- + +buildString :: [LispVal] -> ThrowsError LispVal +buildString [(Char c)] = return $ String [c] +buildString (Char c:rest) = do + cs <- buildString rest + case cs of + String s -> return $ String $ [c] ++ s + badType -> throwError $ TypeMismatch "character" badType +buildString [badType] = throwError $ TypeMismatch "character" badType +buildString badArgList = throwError $ NumArgs 1 badArgList + +makeString :: [LispVal] -> ThrowsError LispVal +makeString [(Number n)] = return $ doMakeString n ' ' "" +makeString [(Number n), (Char c)] = return $ doMakeString n c "" +makeString badArgList = throwError $ NumArgs 1 badArgList + +doMakeString :: forall a.(Num a) => a -> Char -> String -> LispVal +doMakeString n char s = + if n == 0 + then String s + else doMakeString (n - 1) char (s ++ [char]) + +stringLength :: [LispVal] -> ThrowsError LispVal +stringLength [String s] = return $ Number $ foldr (const (+1)) 0 s -- Could probably do 'length s' instead... +stringLength [badType] = throwError $ TypeMismatch "string" badType +stringLength badArgList = throwError $ NumArgs 1 badArgList + +stringRef :: [LispVal] -> ThrowsError LispVal +stringRef [(String s), (Number k)] = return $ Char $ s !! fromInteger k +stringRef [badType] = throwError $ TypeMismatch "string number" badType +stringRef badArgList = throwError $ NumArgs 2 badArgList + +substring :: [LispVal] -> ThrowsError LispVal +substring [(String s), (Number start), (Number end)] = + do let slength = fromInteger $ end - start + let begin = fromInteger start + return $ String $ (take slength . drop begin) s +substring [badType] = throwError $ TypeMismatch "string number number" badType +substring badArgList = throwError $ NumArgs 3 badArgList + +stringCIEquals :: [LispVal] -> ThrowsError LispVal +stringCIEquals [(String str1), (String str2)] = do + if (length str1) /= (length str2) + then return $ Bool False + else return $ Bool $ ciCmp str1 str2 0 + where ciCmp s1 s2 idx = if idx == (length s1) + then True + else if (toLower $ s1 !! idx) == (toLower $ s2 !! idx) + then ciCmp s1 s2 (idx + 1) + else False +stringCIEquals [badType] = throwError $ TypeMismatch "string string" badType +stringCIEquals badArgList = throwError $ NumArgs 2 badArgList + +stringCIBoolBinop :: ([Char] -> [Char] -> Bool) -> [LispVal] -> ThrowsError LispVal +stringCIBoolBinop op [(String s1), (String s2)] = boolBinop unpackStr op [(String $ strToLower s1), (String $ strToLower s2)] + where strToLower str = map (toLower) str +stringCIBoolBinop _ [badType] = throwError $ TypeMismatch "string string" badType +stringCIBoolBinop _ badArgList = throwError $ NumArgs 2 badArgList + +stringAppend :: [LispVal] -> ThrowsError LispVal +stringAppend [(String s)] = return $ String s -- Needed for "last" string value +stringAppend (String st:sts) = do + rest <- stringAppend sts + case rest of + String s -> return $ String $ st ++ s + other -> throwError $ TypeMismatch "string" other +stringAppend [badType] = throwError $ TypeMismatch "string" badType +stringAppend badArgList = throwError $ NumArgs 1 badArgList + +stringToNumber :: [LispVal] -> ThrowsError LispVal +stringToNumber [(String s)] = do + result <- (readExpr s) + case result of + n@(Number _) -> return n + n@(Rational _) -> return n + n@(Float _) -> return n + n@(Complex _) -> return n + _ -> return $ Bool False +stringToNumber [(String s), Number radix] = do + case radix of + 2 -> stringToNumber [String $ "#b" ++ s] + 8 -> stringToNumber [String $ "#o" ++ s] + 10 -> stringToNumber [String s] + 16 -> stringToNumber [String $ "#x" ++ s] + _ -> throwError $ Default $ "Invalid radix: " ++ show radix +stringToNumber [badType] = throwError $ TypeMismatch "string" badType +stringToNumber badArgList = throwError $ NumArgs 1 badArgList + +stringToList :: [LispVal] -> ThrowsError LispVal +stringToList [(String s)] = return $ List $ map (Char) s +stringToList [badType] = throwError $ TypeMismatch "string" badType +stringToList badArgList = throwError $ NumArgs 1 badArgList + +listToString :: [LispVal] -> ThrowsError LispVal +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 +stringCopy [badType] = throwError $ TypeMismatch "string" badType +stringCopy badArgList = throwError $ NumArgs 2 badArgList + +isDottedList :: [LispVal] -> ThrowsError LispVal +isDottedList ([DottedList _ _]) = return $ Bool True +-- Must include lists as well since they are made up of 'chains' of pairs +isDottedList ([List []]) = return $ Bool False +isDottedList ([List _]) = return $ Bool True +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 +isProcedure _ = return $ Bool False + +isVector, isList :: LispVal -> ThrowsError LispVal +isVector (Vector _) = return $ Bool True +isVector _ = return $ Bool False +isList (List _) = return $ Bool True +isList _ = return $ Bool False + +isNull :: [LispVal] -> ThrowsError LispVal +isNull ([List []]) = return $ Bool True +isNull _ = return $ Bool False + +isSymbol :: [LispVal] -> ThrowsError LispVal +isSymbol ([Atom _]) = return $ Bool True +isSymbol _ = return $ Bool False + +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 +isChar _ = return $ Bool False + +isString :: [LispVal] -> ThrowsError LispVal +isString ([String _]) = return $ Bool True +isString _ = return $ Bool False + +isBoolean :: [LispVal] -> ThrowsError LispVal +isBoolean ([Bool _]) = return $ Bool True +isBoolean _ = return $ Bool False + + diff --git a/hs-src/Language/Scheme/Macro.hs b/hs-src/Language/Scheme/Macro.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Scheme/Macro.hs @@ -0,0 +1,513 @@ +{- + - husk scheme + - Macro + - @author Justin Ethier + - + - Purpose: + - + - This file contains code for hygienic macros. + - + - During transformation, the following components are considered: + - - Pattern (part of a rule that matches input) + - - Transform (what the macro "expands" into) + - - Input (the actual code in the user's program) + - + - At a high level, macro transformation is broken down into the following steps: + - + - 1) Search for a rule that matches the input. + - During this process, any variables in the input are loaded into a temporary environment + - 2) If a rule matches, + - 3) Transform by walking the transform, inserting variables as needed + - + - + - Remaining Work: + - + - * Vectors are currently not supported + - + - * Dotted lists are not 100% correctly implemented. In particular, the transformation should + - take into account whether the input was presented as a list or a pair, and replicate that + - in the output. + - + - -} +module Language.Scheme.Macro + ( + macroEval + ) where +import Language.Scheme.Types +import Language.Scheme.Variables +import Control.Monad.Error +--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 + +-- |macroEval +-- 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 + +-- Special case, just load up the syntax rules +macroEval env (List [Atom "define-syntax", Atom keyword, syntaxRules@(List (Atom "syntax-rules" : (List _ : _)))]) = do + -- + -- + -- + -- FUTURE: Issue #15: 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. + -- At a minimum, should check identifiers to make sure each is an atom (see findAtom) + -- + -- + -- + defineNamespacedVar env macroNamespace keyword syntaxRules + return $ Nil "" -- Sentinal value + +-- Inspect a list of code, and transform as necessary +macroEval env (List (x@(List _) : xs)) = do + first <- macroEval env x + rest <- mapM (macroEval env) xs + return $ List $ first : rest + +-- +-- FUTURE: Issue #4 +-- equivalent matches/transforms for vectors, and what about dotted lists? +-- +-- macroEval env (Vector v) = do +-- macroEval env (DottedList ls l) = do +-- +-- but first, need to confirm such syntax is even allowed + +-- Inspect code for macro's +macroEval env lisp@(List (Atom x : xs)) = do + isDefined <- liftIO $ isNamespacedBound env macroNamespace x + if isDefined + then do + (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 + rest <- mapM (macroEval env) xs + return $ List $ (Atom x) : rest + +-- No macro to process, just return code as it is... +macroEval _ lisp@(_) = return lisp + +-- Given input and syntax-rules, determine if any rule is a match and transform it. +-- +-- FUTURE: validate that the pattern's template and pattern are consistent (IE: no vars in transform that do not appear in matching pattern - csi "stmt1" case) +-- +-- Parameters: +-- env - Higher level LISP environment +-- identifiers - Literal identifiers - IE, atoms that should not be transformed +-- rules - pattern/transform pairs to compare to input +-- input - Code from the scheme application +macroTransform :: Env -> LispVal -> [LispVal] -> LispVal -> IOThrowsError LispVal +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 + _ -> 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 (_:ps)) = do + if not (null ps) + then case (head ps) of + Atom "..." -> True + _ -> 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 _ 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] + _ -> 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 "" + _ -> transformRule localEnv 0 (List []) template (List []) + _ -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" p + +matchRule _ _ _ rule input = do + throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ List [Atom "rule: ", rule, Atom "input: ", input] + +-- +-- loadLocal - Determine if pattern matches input, loading input into pattern variables as we go, +-- in preparation for macro transformation. +loadLocal :: Env -> LispVal -> LispVal -> LispVal -> Bool -> Bool -> IOThrowsError LispVal +loadLocal localEnv identifiers pattern input hasEllipsis outerHasEllipsis = do + case (pattern, input) of + + -- Future: vector + + ((DottedList ps p), (DottedList is i)) -> do + result <- loadLocal localEnv identifiers (List ps) (List is) False outerHasEllipsis + case result of + Bool True -> loadLocal localEnv identifiers p i False outerHasEllipsis + _ -> return $ Bool False + + (List (p:ps), List (i:is)) -> do -- check first input against first pattern, recurse... + + let localHasEllipsis = macroElementMatchesMany pattern + + -- FUTURE: error if ... detected when there is an outer ... ???? + -- no, this should (eventually) be allowed. See scheme-faq-macros + + status <- checkLocal localEnv identifiers (localHasEllipsis || outerHasEllipsis) p i + case status of + -- No match + 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 + _ -> 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 (_: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 + if (macroElementMatchesMany pattern) && ((length ps) == 1) + then return $ Bool True + else return $ Bool False + + -- Pattern ran out, but there is still input. No match. + (List [], _) -> return $ Bool False + + -- Check input against pattern (both should be single var) + (_, _) -> checkLocal localEnv identifiers (hasEllipsis || outerHasEllipsis) pattern input + +-- Check pattern against input to determine if there is a match +-- +-- @param localEnv - Local variables for the macro, used during transform +-- @param hasEllipsis - Determine whether we are in a zero-or-many match. +-- Used for loading local vars and NOT for purposes of matching. +-- @param pattern - Pattern to match +-- @param input - Input to be matched +checkLocal :: Env -> LispVal -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal +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 + -- FUTURE: may be able to simplify both cases below by using a + -- lambda function to store the 'save' actions + -- + + -- Var is part of a 0-to-many match, store up in a list... + then do isDefined <- liftIO $ isBound localEnv pattern + -- + -- If pattern is a literal identifier, need to ensure + -- input matches that literal, or that (in this case) + -- the literal is missing from the input (0 match) + -- + isIdent <- findAtom (Atom pattern) identifiers + case isIdent of + Bool True -> do + case input of + Atom inpt -> do + if (pattern == inpt) + then do + -- Set variable in the local environment + addPatternVar isDefined $ Atom pattern + return $ Bool True + else return $ Bool False + -- Pattern/Input cannot match because input is not an atom + _ -> return $ Bool False + -- No literal identifier, just load up the var + _ -> do addPatternVar isDefined input + return $ Bool True + -- + -- Simple var, try to load up into macro env + -- + else do + isIdent <- findAtom (Atom pattern) identifiers + case isIdent of + -- Fail the match if pattern is a literal identifier and input does not match + Bool True -> do + case input of + Atom inpt -> do + -- Pattern/Input are atoms; both must match + if (pattern == inpt) + then do defineVar localEnv pattern input + return $ Bool True + else return $ (Bool False) + -- Pattern/Input cannot match because input is not an atom + _ -> return $ (Bool False) + + -- No literal identifier, just load up the var + _ -> do defineVar localEnv pattern input + return $ Bool True + where + addPatternVar isDefined val = do + 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]) + +-- FUTURE: Issue #4 - vector support. And what the heck are these next two lines doing here? :) +-- +-- , load into localEnv in some (all?) cases?: eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2 +-- : eqv [(Vector arg1), (Vector arg2)] = eqv [List $ (elems arg1), List $ (elems arg2)] +-- +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 + if (length ps) == (length is) + -- Lists are same length, implying elements in both should be the same. + -- Cast pair to a List for further processing + then loadLocal localEnv identifiers (List $ ps ++ [p]) input False hasEllipsis + -- Idea here is that if we have a dotted list, the last component does not have to be provided + -- in the input. So in that case just fill in an empty list for the missing component. + else loadLocal localEnv identifiers pattern (DottedList (i : is) (List [])) False hasEllipsis +checkLocal localEnv identifiers hasEllipsis pattern@(List _) input@(List _) = + loadLocal localEnv identifiers pattern input False hasEllipsis + +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 +transformRule :: Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal + +-- Recursively transform a list +-- +-- Parameters: +-- +-- localEnv - Local variable environment +-- ellipsisIndex - Zero-or-more match variables are stored as a list. +-- This is the index into the current value to read from list +-- result - Resultant value, must be a parameter as it mutates with each function call, so we pass it using CPS +-- transform - The macro transformation, we read it out one atom at a time, and rewrite it into result +-- ellipsisList - Temporarily holds value of the "outer" result while we process the +-- zero-or-more match. Once that is complete we swap this value back into it's rightful place +-- +transformRule localEnv ellipsisIndex (List result) transform@(List(List l : ts)) (List ellipsisList) = do + if macroElementMatchesMany transform + then do + curT <- transformRule localEnv (ellipsisIndex + 1) (List []) (List l) (List result) + case curT of + Nil _ -> 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 $ ellipsisList ++ result) (List $ tail ts) (List []) + -- Dotted list transform returned during processing... + 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 _ -> 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 _, _] -> return lst + List _ -> transformRule localEnv ellipsisIndex (List $ result ++ [lst]) (List ts) (List ellipsisList) + Nil _ -> return lst + _ -> throwError $ BadSpecialForm "Macro transform error" $ List [lst, (List l), Number $ toInteger ellipsisIndex] + +-- FUTURE: issue #4 - vector transform (and taking vectors into account in other cases as well???) + + +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) ...) + curT <- transformDottedList localEnv (ellipsisIndex + 1) (List []) (List [dl]) (List result) + case curT of + Nil _ -> 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 $ 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 _] -> 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 _] -> return lst + List l -> transformRule localEnv ellipsisIndex (List $ result ++ l) (List ts) (List ellipsisList) + Nil _ -> return lst + _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [dl]), Number $ toInteger ellipsisIndex] + + +-- Transform an atom by attempting to look it up as a var... +transformRule localEnv ellipsisIndex (List result) transform@(List (Atom a : ts)) unused = do + let hasEllipsis = macroElementMatchesMany transform + isDefined <- liftIO $ isBound localEnv a + if hasEllipsis + then if isDefined + then do + -- get var + var <- getVar localEnv a + -- ensure it is a list + case var of + -- add all elements of the list into result + List v -> transformRule localEnv ellipsisIndex (List $ result ++ v) (List $ tail ts) unused + v@(_) -> transformRule localEnv ellipsisIndex (List $ result ++ [v]) (List $ tail ts) unused + else -- Matched 0 times, skip it + transformRule localEnv ellipsisIndex (List result) (List $ tail ts) unused + else do t <- if isDefined + then do var <- getVar localEnv a + if ellipsisIndex > 0 + then do case var of + 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 + _ -> transformRule localEnv ellipsisIndex (List $ result ++ [t]) (List ts) unused + +-- Transform anything else as itself... +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 _ _ result@(List _) (List []) _ = do + return result + +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) + -- + -- FUTURE: Issue #9 - 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 _ (List (badtype : _)) = throwError $ TypeMismatch "symbol" badtype +findAtom _ _ = return $ Bool False + +-- Initialize any pattern variables as an empty list. +-- That way a zero-match case can be identified later during transformation. +-- +-- Input: +-- localEnv - Local environment that contains variables +-- src - Input source, required because a pair in the pattern may be matched by either a list or a pair, +-- and the transform needs to know this... +-- identifiers - Literal identifiers that are transformed as themselves +-- pattern - Pattern portion of the syntax rule +initializePatternVars :: Env -> String -> LispVal -> LispVal -> IOThrowsError LispVal +initializePatternVars localEnv src identifiers pattern@(List _) = do + case pattern of + 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 (DottedList ps p) = do + initializePatternVars localEnv src identifiers $ List ps + initializePatternVars localEnv src identifiers p + +-- FUTURE: Issue #4: vector + +initializePatternVars localEnv src identifiers (Atom pattern) = + -- FUTURE: + -- there is code to attempt to flag "src" here, but it is not + -- wire up correctly. In fact, the whole design here probably + -- needs to be rethinked. + do defineNamespacedVar localEnv "src" pattern $ String src + isDefined <- liftIO $ isBound localEnv pattern + found <- findAtom (Atom pattern) identifiers + case found of + (Bool False) -> if not isDefined -- Set variable in the local environment + then do + defineVar localEnv pattern (List []) + else do + return $ Bool True + -- Ignore identifiers since they are just passed along as-is + _ -> return $ Bool True + +initializePatternVars _ _ _ _ = + return $ Bool True + +-- Find the first pattern var that reports being from a src, or False if none +lookupPatternVarSrc :: Env -> LispVal -> IOThrowsError LispVal +lookupPatternVarSrc localEnv pattern@(List _) = do + case pattern of + List (p:ps) -> do result <- lookupPatternVarSrc localEnv p + case result of + Bool False -> lookupPatternVarSrc localEnv $ List ps + _ -> return result + List [] -> return $ Bool False + _ -> return $ Bool False + +lookupPatternVarSrc localEnv (DottedList ps p) = do + result <- lookupPatternVarSrc localEnv $ List ps + case result of + Bool False -> lookupPatternVarSrc localEnv p + _ -> return result + +-- FUTURE: Issue #4: vector + +lookupPatternVarSrc localEnv (Atom pattern) = + do isDefined <- liftIO $ isNamespacedBound localEnv "src" pattern + if isDefined then getNamespacedVar localEnv "src" pattern + else return $ Bool False + +lookupPatternVarSrc _ _ = + return $ Bool False diff --git a/hs-src/Language/Scheme/Numerical.hs b/hs-src/Language/Scheme/Numerical.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Scheme/Numerical.hs @@ -0,0 +1,412 @@ +{- + - husk scheme interpreter + - + - A lightweight dialect of R5RS scheme. + - Numerical tower functionality + - + - @author Justin Ethier + - + - -} + +module Language.Scheme.Numerical where +import Language.Scheme.Types +import Complex +import Control.Monad.Error +import Data.Char +import Numeric +import Ratio +import Text.Printf + +numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal +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 +foldlM f v (x:xs) = (f v x) >>= \a -> foldlM f a xs +foldlM _ v [] = return v + +foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a +foldl1M f (x:xs) = foldlM f x xs +foldl1M _ _ = error "Unexpected error in foldl1M" +-- end GenUtil + + +-- FUTURE: as a general comment here, operations need to be more permissive of the +-- numerical types they accept. Within reason, a user should not have to know +-- what numerical type they are passing when using these functions + + +numAdd, numSub, numMul, numDiv :: [LispVal] -> ThrowsError LispVal +numAdd [] = return $ Number 0 +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 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 + doSub _ = throwError $ Default "Unexpected error in -" +numMul [] = return $ Number 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 aparams = do -- FUTURE: for Number type, consider casting 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 + doDiv (List [(Float a), (Float b)]) = if b == 0.0 + then throwError $ DivideByZero + else return $ Float $ a / b + doDiv (List [(Rational a), (Rational b)]) = if b == 0 + then throwError $ DivideByZero + else return $ Rational $ a / b + 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 [] = 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 [] = 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 [] = 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 [] = 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 [] = 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] +numCast [a@(Float _), b@(Float _)] = return $ List [a, b] +numCast [a@(Rational _), b@(Rational _)] = return $ List [a, b] +numCast [a@(Complex _), b@(Complex _)] = return $ List [a, b] +numCast [(Number a), b@(Float _)] = return $ List [Float $ fromInteger a, b] +numCast [(Number a), b@(Rational _)] = return $ List [Rational $ fromInteger a, b] +numCast [(Number a), b@(Complex _)] = return $ List [Complex $ fromInteger a, b] +numCast [a@(Float _), (Number b)] = return $ List [a, Float $ fromInteger b] +numCast [a@(Float _), (Rational b)] = return $ List [a, Float $ fromRational b] +numCast [(Float a), b@(Complex _)] = return $ List [Complex $ a :+ 0, b] +numCast [a@(Rational _), (Number b)] = return $ List [a, Rational $ fromInteger b] +numCast [(Rational a), b@(Float _)] = return $ List [Float $ fromRational a, b] +numCast [(Rational a), b@(Complex _)] = return $ List [Complex $ (fromInteger $ numerator a) / (fromInteger $ denominator a), b] +numCast [a@(Complex _), (Number b)] = return $ List [a, Complex $ fromInteger b] +numCast [a@(Complex _), (Float b)] = return $ List [a, Complex $ b :+ 0] +numCast [a@(Complex _), (Rational b)] = return $ List [a, Complex $ (fromInteger $ numerator b) / (fromInteger $ denominator b)] +numCast [a, b] = case a of + Number _ -> doThrowError b + Float _ -> doThrowError b + Rational _ -> doThrowError b + Complex _ -> doThrowError b + _ -> 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 +numRound [(Rational n)] = return $ Number $ round n +numRound [(Float n)] = return $ Float $ fromInteger $ round n +numRound [(Complex n)] = do + return $ Complex $ (fromInteger $ round $ realPart n) :+ (fromInteger $ round $ imagPart n) +numRound [x] = throwError $ TypeMismatch "number" x +numRound badArgList = throwError $ NumArgs 1 badArgList + +numFloor [n@(Number _)] = return n +numFloor [(Rational n)] = return $ Number $ floor n +numFloor [(Float n)] = return $ Float $ fromInteger $ floor n +numFloor [(Complex n)] = do + return $ Complex $ (fromInteger $ floor $ realPart n) :+ (fromInteger $ floor $ imagPart n) +numFloor [x] = throwError $ TypeMismatch "number" x +numFloor badArgList = throwError $ NumArgs 1 badArgList + +numCeiling [n@(Number _)] = return n +numCeiling [(Rational n)] = return $ Number $ ceiling n +numCeiling [(Float n)] = return $ Float $ fromInteger $ ceiling n +numCeiling [(Complex n)] = do + return $ Complex $ (fromInteger $ ceiling $ realPart n) :+ (fromInteger $ ceiling $ imagPart n) +numCeiling [x] = throwError $ TypeMismatch "number" x +numCeiling badArgList = throwError $ NumArgs 1 badArgList + +numTruncate [n@(Number _)] = return n +numTruncate [(Rational n)] = return $ Number $ truncate n +numTruncate [(Float n)] = return $ Float $ fromInteger $ truncate n +numTruncate [(Complex n)] = do + return $ Complex $ (fromInteger $ truncate $ realPart n) :+ (fromInteger $ truncate $ imagPart n) +numTruncate [x] = throwError $ TypeMismatch "number" x +numTruncate badArgList = throwError $ NumArgs 1 badArgList + + +numSin :: [LispVal] -> ThrowsError LispVal +numSin [(Number n)] = return $ Float $ sin $ fromInteger n +numSin [(Float n)] = return $ Float $ sin n +numSin [(Rational n)] = return $ Float $ sin $ fromRational n +numSin [(Complex n)] = return $ Complex $ sin n +numSin [x] = throwError $ TypeMismatch "number" x +numSin badArgList = throwError $ NumArgs 1 badArgList + +numCos :: [LispVal] -> ThrowsError LispVal +numCos [(Number n)] = return $ Float $ cos $ fromInteger n +numCos [(Float n)] = return $ Float $ cos n +numCos [(Rational n)] = return $ Float $ cos $ fromRational n +numCos [(Complex n)] = return $ Complex $ cos n +numCos [x] = throwError $ TypeMismatch "number" x +numCos badArgList = throwError $ NumArgs 1 badArgList + +numTan :: [LispVal] -> ThrowsError LispVal +numTan [(Number n)] = return $ Float $ tan $ fromInteger n +numTan [(Float n)] = return $ Float $ tan n +numTan [(Rational n)] = return $ Float $ tan $ fromRational n +numTan [(Complex n)] = return $ Complex $ tan n +numTan [x] = throwError $ TypeMismatch "number" x +numTan badArgList = throwError $ NumArgs 1 badArgList + +numAsin :: [LispVal] -> ThrowsError LispVal +numAsin [(Number n)] = return $ Float $ asin $ fromInteger n +numAsin [(Float n)] = return $ Float $ asin n +numAsin [(Rational n)] = return $ Float $ asin $ fromRational n +numAsin [(Complex n)] = return $ Complex $ asin n +numAsin [x] = throwError $ TypeMismatch "number" x +numAsin badArgList = throwError $ NumArgs 1 badArgList + +numAcos :: [LispVal] -> ThrowsError LispVal +numAcos [(Number n)] = return $ Float $ acos $ fromInteger n +numAcos [(Float n)] = return $ Float $ acos n +numAcos [(Rational n)] = return $ Float $ acos $ fromRational n +numAcos [(Complex n)] = return $ Complex $ acos n +numAcos [x] = throwError $ TypeMismatch "number" x +numAcos badArgList = throwError $ NumArgs 1 badArgList + +numAtan :: [LispVal] -> ThrowsError LispVal +numAtan [(Number n)] = return $ Float $ atan $ fromInteger n +numAtan [Number y, Number x] = return $ Float $ phase $ (fromInteger x) :+ (fromInteger y) +numAtan [(Float n)] = return $ Float $ atan n +numAtan [Float y, Float x] = return $ Float $ phase $ x :+ y +numAtan [(Rational n)] = return $ Float $ atan $ fromRational n +numAtan [Rational y, Rational x] = return $ Float $ phase $ (fromRational x) :+ (fromRational y) +numAtan [(Complex n)] = return $ Complex $ atan n +numAtan [x] = throwError $ TypeMismatch "number" x +numAtan badArgList = throwError $ NumArgs 1 badArgList + +numSqrt, numExpt :: [LispVal] -> ThrowsError LispVal +numSqrt [(Number n)] = if n >= 0 then return $ Float $ sqrt $ fromInteger n + else return $ Complex $ sqrt ((fromInteger n) :+ 0) +numSqrt [(Float n)] = if n >= 0 then return $ Float $ sqrt n + else return $ Complex $ sqrt (n :+ 0) +numSqrt [(Rational n)] = numSqrt [Float $ fromRational n] +numSqrt [(Complex n)] = return $ Complex $ sqrt n +numSqrt [x] = throwError $ TypeMismatch "number" x +numSqrt badArgList = throwError $ NumArgs 1 badArgList + +numExpt [(Number n), (Number p)] = return $ Float $ (fromInteger n) ^ p +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 [_, y] = throwError $ TypeMismatch "integer" y +numExpt badArgList = throwError $ NumArgs 2 badArgList + +{-numExpt params = do + foldl1M (\a b -> doExpt =<< (numCast [a, b])) params + where doExpt (List [(Number a), (Number b)]) = return $ Float $ (fromInteger a) ^ (fromInteger b) +-- doExpt (List [(Rational a), (Rational b)]) = return $ Float $ fromRational $ a ^ b + doExpt (List [(Float a), (Float b)]) = return $ Float $ a ^ b +-- doExpt (List [(Complex a), (Complex b)]) = return $ Complex $ a ^ b-} + +numExp :: [LispVal] -> ThrowsError LispVal +numExp [(Number n)] = return $ Float $ exp $ fromInteger n +numExp [(Float n)] = return $ Float $ exp n +numExp [(Rational n)] = return $ Float $ exp $ fromRational n +numExp [(Complex n)] = return $ Complex $ exp n +numExp [x] = throwError $ TypeMismatch "number" x +numExp badArgList = throwError $ NumArgs 1 badArgList + +numLog :: [LispVal] -> ThrowsError LispVal +numLog [(Number n)] = return $ Float $ log $ fromInteger n +numLog [(Float n)] = return $ Float $ log n +numLog [(Rational n)] = return $ Float $ log $ fromRational n +numLog [(Complex n)] = return $ Complex $ log n +numLog [x] = throwError $ TypeMismatch "number" x +numLog badArgList = throwError $ NumArgs 1 badArgList + + +buildComplex :: LispVal -> LispVal -> ThrowsError LispVal +buildComplex (Number x) (Number y) = return $ Complex $ (fromInteger x) :+ (fromInteger y) +buildComplex (Number x) (Rational y) = return $ Complex $(fromInteger x) :+ (fromRational y) +buildComplex (Number x) (Float y) = return $ Complex $ (fromInteger x) :+ y +buildComplex (Rational x) (Number y) = return $ Complex $ (fromRational x) :+ (fromInteger y) +buildComplex (Rational x) (Rational y) = return $ Complex $ (fromRational x) :+ (fromRational y) +buildComplex (Rational x) (Float y) = return $ Complex $ (fromRational x) :+ y +buildComplex (Float x) (Number y) = return $ Complex $ x :+ (fromInteger y) +buildComplex (Float x) (Rational y) = return $ Complex $ x :+ (fromRational y) +buildComplex (Float x) (Float y) = return $ Complex $ x :+ y +buildComplex x y = throwError $ TypeMismatch "number" $ List [x, y] + +-- Complex number functions +numMakeRectangular, numMakePolar, numRealPart, numImagPart, numMagnitude, numAngle :: [LispVal] -> ThrowsError LispVal +numMakeRectangular [x, y] = buildComplex x y +numMakeRectangular badArgList = throwError $ NumArgs 2 badArgList + +numMakePolar [(Float x), (Float y)] = return $ Complex $ mkPolar x y +numMakePolar [(Float _), y] = throwError $ TypeMismatch "real" y +numMakePolar [x, (Float _)] = throwError $ TypeMismatch "real real" $ x +numMakePolar badArgList = throwError $ NumArgs 2 badArgList + +numAngle [(Complex c)] = return $ Float $ phase c +numAngle [x] = throwError $ TypeMismatch "complex number" x +numAngle badArgList = throwError $ NumArgs 1 badArgList + +numMagnitude [(Complex c)] = return $ Float $ magnitude c +numMagnitude [x] = throwError $ TypeMismatch "complex number" x +numMagnitude badArgList = throwError $ NumArgs 1 badArgList + +numRealPart [(Complex c)] = return $ Float $ realPart c +numRealPart [x] = throwError $ TypeMismatch "complex number" x +numRealPart badArgList = throwError $ NumArgs 1 badArgList + +numImagPart [(Complex c)] = return $ Float $ imagPart c +numImagPart [x] = throwError $ TypeMismatch "complex number" x +numImagPart badArgList = throwError $ NumArgs 1 badArgList + + +numNumerator, numDenominator:: [LispVal] -> ThrowsError LispVal +numNumerator [(Rational r)] = return $ Number $ numerator r +numNumerator [x] = throwError $ TypeMismatch "rational number" x +numNumerator badArgList = throwError $ NumArgs 1 badArgList + +numDenominator [(Rational r)] = return $ Number $ denominator r +numDenominator [x] = throwError $ TypeMismatch "rational number" x +numDenominator badArgList = throwError $ NumArgs 1 badArgList + +numExact2Inexact, numInexact2Exact :: [LispVal] -> ThrowsError LispVal +numExact2Inexact [(Number n)] = return $ Float $ fromInteger n +numExact2Inexact [(Rational n)] = return $ Float $ fromRational n +numExact2Inexact [n@(Float _)] = return n +numExact2Inexact [n@(Complex _)] = return n +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 +numInexact2Exact [c@(Complex _)] = numRound [c] +numInexact2Exact [badType] = throwError $ TypeMismatch "number" badType +numInexact2Exact badArgList = throwError $ NumArgs 1 badArgList + +-- Convert a number to a string; radix is optional, defaults to base 10 +num2String :: [LispVal] -> ThrowsError LispVal +num2String [(Number n)] = return $ String $ show n +num2String [(Number n), (Number radix)] = do + case radix of + 2 -> do -- Nice tip from StackOverflow question #1959715 + return $ String $ showIntAtBase 2 intToDigit n "" + 8 -> return $ String $ printf "%o" n + 10 -> return $ String $ printf "%d" n + 16 -> return $ String $ printf "%x" n + _ -> 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 +num2String [x] = throwError $ TypeMismatch "number" x +num2String badArgList = throwError $ NumArgs 1 badArgList + +isNumber, isComplex, isReal, isRational, isInteger :: [LispVal] -> ThrowsError LispVal +isNumber ([Number _]) = return $ Bool True +isNumber ([Float _]) = return $ Bool True +isNumber ([Complex _]) = return $ Bool True +isNumber ([Rational _]) = return $ Bool True +isNumber _ = return $ Bool False + +isComplex ([Complex _]) = return $ Bool True +isComplex ([Number _]) = return $ Bool True +isComplex ([Rational _]) = return $ Bool True +isComplex ([Float _]) = return $ Bool True +isComplex _ = return $ Bool False + +isReal ([Number _]) = return $ Bool True +isReal ([Rational _]) = return $ Bool True +isReal ([Float _]) = return $ Bool True +isReal ([Complex c]) = return $ Bool $ (imagPart c) == 0 +isReal _ = return $ Bool False + +isRational ([Number _]) = return $ Bool True +isRational ([Rational _]) = return $ Bool True +isRational ([n@(Float _)]) = return $ Bool $ isFloatAnInteger n + -- FUTURE: not quite good enough, could be represented exactly and not an integer +isRational _ = return $ Bool False + +isInteger ([Number _]) = return $ Bool True +isInteger ([Complex n]) = do + return $ Bool $ (isFloatAnInteger $ Float $ realPart n) && (isFloatAnInteger $ Float $ imagPart n) +isInteger ([Rational n]) = do + let numer = numerator n + let denom = denominator n + return $ Bool $ (numer >= denom) && ((mod numer denom) == 0) +isInteger ([n@(Float _)]) = return $ Bool $ isFloatAnInteger n +isInteger _ = return $ Bool False + +isFloatAnInteger :: LispVal -> Bool +isFloatAnInteger (Float n) = (floor n) == (ceiling n) +isFloatAnInteger _ = False + +--- end Numeric operations section --- + + +unpackNum :: LispVal -> ThrowsError Integer +unpackNum (Number n) = return n +unpackNum notNum = throwError $ TypeMismatch "number" notNum diff --git a/hs-src/Language/Scheme/Parser.hs b/hs-src/Language/Scheme/Parser.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Scheme/Parser.hs @@ -0,0 +1,258 @@ +{- + - husk scheme + - Parser + - + - This file contains the code for parsing scheme + - + - @author Justin Ethier + - + - -} +module Language.Scheme.Parser where +import Language.Scheme.Types +import Control.Monad.Error +import Char +import Complex +import Data.Array +import Numeric +import Ratio +import Text.ParserCombinators.Parsec hiding (spaces) + +symbol :: Parser Char +symbol = oneOf "!$%&|*+-/:<=>?@^_~" + +spaces :: Parser () +spaces = skipMany1 space + +parseAtom :: Parser LispVal +parseAtom = do + first <- letter <|> symbol <|> (oneOf ".") + rest <- many (letter <|> digit <|> symbol <|> (oneOf ".")) + let atom = first:rest + if atom == "." + then pzero -- Do not match this form + else return $ Atom atom + +parseBool :: Parser LispVal +parseBool = do string "#" + x <- oneOf "tf" + 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 pchr = c:r + return $ case pchr of + "space" -> Char ' ' + "newline" -> Char '\n' + _ -> Char c + +parseOctalNumber :: Parser LispVal +parseOctalNumber = do + try (string "#o") + sign <- many (oneOf "-") + num <- many1(oneOf "01234567") + case (length sign) of + 0 -> return $ Number $ fst $ Numeric.readOct num !! 0 + 1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ Numeric.readOct num !! 0 + _ -> pzero + +parseBinaryNumber :: Parser LispVal +parseBinaryNumber = do + try (string "#b") + sign <- many (oneOf "-") + num <- many1(oneOf "01") + case (length sign) of + 0 -> return $ Number $ 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 +parseHexNumber = do + try (string "#x") + sign <- many (oneOf "-") + num <- many1(digit <|> oneOf "abcdefABCDEF") + case (length sign) of + 0 -> return $ Number $ fst $ Numeric.readHex num !! 0 + 1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ Numeric.readHex num !! 0 + _ -> pzero + +-- |Parser for Integer, base 10 +parseDecimalNumber :: Parser LispVal +parseDecimalNumber = do + try (many(string "#d")) + sign <- many (oneOf "-") + num <- many1 (digit) + if (length sign) > 1 + then pzero + else return $ (Number . read) $ sign ++ num + +parseNumber :: Parser LispVal +parseNumber = parseDecimalNumber <|> + parseHexNumber <|> + parseBinaryNumber <|> + parseOctalNumber + "Unable to parse number" + +{- Parser for floating points + - -} +parseRealNumber :: Parser LispVal +parseRealNumber = do + sign <- many (oneOf "-") + num <- many1(digit) + char '.' + frac <- many1(digit) + let dec = num ++ "." ++ frac + case (length sign) of + 0 -> do + let numbr = fst $ Numeric.readFloat dec !! 0 +-- expnt <- try (char 'e') + return $ Float $ numbr +{- FUTURE: Issue #14: parse numbers in format #e1e10 + - + expnt <- try (char 'e') + case expnt of +-- 'e' -> return $ Float $ numbr + _ -> return $ Float $ numbr +-} +-- return $ Float $ fst $ Numeric.readFloat dec !! 0 + 1 -> return $ Float $ (*) (-1.0) $ fst $ Numeric.readFloat dec !! 0 + _ -> pzero + +parseRationalNumber :: Parser LispVal +parseRationalNumber = do + pnumerator <- parseDecimalNumber + case pnumerator of + Number n -> do + char '/' + sign <- many (oneOf "-") + num <- many1 (digit) + if (length sign) > 1 + then pzero + else return $ Rational $ n % (read $ sign ++ num) + _ -> pzero + +parseComplexNumber :: Parser LispVal +parseComplexNumber = do + lispreal <- (try(parseRealNumber) <|> parseDecimalNumber) + 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 + return $ case c of + 'n' -> '\n' + 't' -> '\t' + 'r' -> '\r' + _ -> c + +parseString :: Parser LispVal +parseString = do + char '"' + x <- many (parseEscapedChar <|> noneOf("\"")) + char '"' + return $ String x + +parseVector :: Parser LispVal +parseVector = do + vals <- sepBy parseExpr spaces + return $ Vector (listArray (0, (length vals - 1)) vals) + +parseList :: Parser LispVal +parseList = liftM List $ sepBy parseExpr spaces + +parseDottedList :: Parser LispVal +parseDottedList = do + phead <- endBy parseExpr spaces + ptail <- char '.' >> spaces >> parseExpr + return $ DottedList phead ptail + +parseQuoted :: Parser LispVal +parseQuoted = do + char '\'' + x <- parseExpr + return $ List [Atom "quote", x] + +parseQuasiQuoted :: Parser LispVal +parseQuasiQuoted = do + char '`' + x <- parseExpr + return $ List [Atom "quasiquote", x] + +parseUnquoted :: Parser LispVal +parseUnquoted = do + try (char ',') + x <- parseExpr + return $ List [Atom "unquote", x] + +parseUnquoteSpliced :: Parser LispVal +parseUnquoteSpliced = do + try (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(parseRationalNumber) + <|> try(parseComplexNumber) + <|> parseComment + <|> try(parseRealNumber) + <|> try(parseNumber) + <|> parseChar + <|> parseUnquoteSpliced + <|> do try (string "#(") + x <- parseVector + char ')' + return x + <|> try (parseAtom) + <|> parseString + <|> parseBool + <|> parseQuoted + <|> parseQuasiQuoted + <|> parseUnquoted + <|> do char '(' + x <- try parseList <|> parseDottedList + char ')' + return x + "Expression" + +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 + +readExprList :: String -> ThrowsError [LispVal] +readExprList = readOrThrow (endBy parseExpr spaces) + diff --git a/hs-src/Language/Scheme/Types.hs b/hs-src/Language/Scheme/Types.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Scheme/Types.hs @@ -0,0 +1,244 @@ +{-- + - husk scheme + - Types + - + - This file contains top-level data type definitions and their associated functions, including: + - - Scheme data types + - - Scheme errors + - + - @author Justin Ethier + - + - -} +module Language.Scheme.Types where +import Complex +import Control.Monad.Error +import Data.Array +import Data.IORef +import qualified Data.Map +import IO hiding (try) +import Ratio +import Text.ParserCombinators.Parsec hiding (spaces) + +{- Environment management -} + +-- |A Scheme environment containing variable bindings of form @(namespaceName, variableName), variableValue@ +data Env = Environment {parentEnv :: (Maybe Env), bindings :: (IORef [((String, String), IORef LispVal)])} -- lookup via: (namespace, variable) + +-- |An empty environment +nullEnv :: IO Env +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 +data LispError = NumArgs Integer [LispVal] -- ^Invalid number of function arguments + | TypeMismatch String LispVal -- ^Type error + | Parser ParseError -- ^Parsing error + | BadSpecialForm String LispVal -- ^Invalid special (built-in) form + | NotFunction String String + | UnboundVar String String + | DivideByZero -- ^Divide by Zero error + | NotImplemented String + | InternalError String -- ^An internal error within husk; in theory user (Scheme) code + -- should never allow one of these errors to be triggered. + | Default String -- ^Default error + +-- |Create a textual description for a 'LispError' +showError :: LispError -> String +showError (NumArgs expected found) = "Expected " ++ show expected + ++ " args; found values " ++ unwordsList found +showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected + ++ ", found " ++ show found +showError (Parser parseErr) = "Parse error at " ++ ": " ++ show parseErr +showError (BadSpecialForm message form) = message ++ ": " ++ show form +showError (NotFunction message func) = message ++ ": " ++ show func +showError (UnboundVar message varname) = message ++ ": " ++ varname +showError (DivideByZero) = "Division by zero" +showError (NotImplemented message) = "Not implemented: " ++ message +showError (InternalError message) = "An internal error occurred: " ++ message +showError (Default message) = "Error: " ++ message + +instance Show LispError where show = showError +instance Error LispError where + noMsg = Default "An error has occurred" + strMsg = Default + +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 + +liftThrows :: ThrowsError a -> IOThrowsError a +liftThrows (Left err) = throwError err +liftThrows (Right val) = return val + +runIOThrows :: IOThrowsError String -> IO String +runIOThrows action = runErrorT (trapError action) >>= return . extractValue + +-- |Scheme data types +data LispVal = Atom String + -- ^Symbol + | List [LispVal] + -- ^List + | DottedList [LispVal] LispVal + -- ^Pair + | Vector (Array Int LispVal) + -- ^Vector + | HashTable (Data.Map.Map LispVal LispVal) + -- ^Hash table. + -- Technically this could be a derived data type instead of being built-in to the + -- interpreter. And perhaps in the future it will be. But for now, a hash table + -- is too important of a data type to not be included. + -- + -- Map is technically the wrong structure to use for a hash table since it is based on a binary tree and hence operations tend to be O(log n) instead of O(1). However, according to Map has good performance characteristics compared to the alternatives. So it stays for the moment... + -- + | Number Integer -- FUTURE: rename this to "Integer" (or "WholeNumber" or something else more meaningful) + -- ^Integer + | Float Double -- FUTURE: rename this "Real" instead of "Float"... + -- ^Floating point + | Complex (Complex Double) + -- ^Complex number + | Rational Rational + -- ^Rational number + | String String + -- ^String + | Char Char + -- ^Character + | Bool Bool + -- ^Boolean + | PrimitiveFunc ([LispVal] -> ThrowsError LispVal) + -- ^ + | Func {params :: [String], + vararg :: (Maybe String), + body :: [LispVal], + closure :: Env + } + -- ^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 + , contFunctionArgs :: (Maybe [LispVal]) -- Arguments to a higher-order function + , continuationFunction :: (Maybe (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)) + -- FUTURE: stack (for dynamic wind) + } + -- ^Continuation + | Nil String + -- ^Internal use only; do not use this type directly. + +-- Make an "empty" continuation that does not contain any code +makeNullContinuation :: Env -> LispVal +makeNullContinuation env = Continuation env [] (Nil "") Nothing Nothing + +-- Make a continuation that takes a higher-order function (written in Haskell) +makeCPS :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal]-> IOThrowsError LispVal) -> LispVal +makeCPS env cont cps = Continuation env [] cont Nothing (Just cps) + +-- Make a continuation that stores a higher-order function and arguments to that function +makeCPSWArgs :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) -> [LispVal] -> LispVal +makeCPSWArgs env cont cps args = Continuation env [] cont (Just args) (Just cps) + +instance Ord LispVal where + compare (Bool a) (Bool b) = compare a b + compare (Number a) (Number b) = compare a b + compare (Rational a) (Rational b) = compare a b + compare (Float a) (Float b) = compare a b + compare (String a) (String b) = compare a b + compare (Char a) (Char b) = compare a b + compare (Atom a) (Atom b) = compare a b +-- compare (DottedList xs x) (DottedList xs x) = compare a b +-- Vector +-- HashTable +-- List +-- Func +-- Others? + compare a b = compare (show a) (show b) -- Hack (??): sort alphabetically when types differ or have no handlers + +-- |Compare two 'LispVal' instances +eqv :: [LispVal] -> ThrowsError LispVal +eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2 +eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2 +eqv [(Complex arg1), (Complex arg2)] = return $ Bool $ arg1 == arg2 +eqv [(Rational arg1), (Rational arg2)] = return $ Bool $ arg1 == arg2 +eqv [(Float arg1), (Float arg2)] = return $ Bool $ arg1 == arg2 +eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2 +eqv [(Char arg1), (Char arg2)] = return $ Bool $ arg1 == arg2 +eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2 +eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]] +eqv [(Vector arg1), (Vector arg2)] = eqv [List $ (elems arg1), List $ (elems arg2)] +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 _), l2@(List _)] = eqvList eqv [l1, l2] +eqv [_, _] = return $ Bool False +eqv badArgList = throwError $ NumArgs 2 badArgList + +eqvList :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal +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 _ -> 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 _ -> False + Right (Bool val) -> val + _ -> False -- Is this OK? + +instance Eq LispVal where + x == y = eqVal x y + +-- |Create a textual description of a 'LispVal' +showVal :: LispVal -> String +showVal (Nil _) = "" +showVal (String contents) = "\"" ++ contents ++ "\"" +showVal (Char chr) = [chr] +showVal (Atom name) = name +showVal (Number contents) = show contents +showVal (Complex contents) = (show $ realPart contents) ++ "+" ++ (show $ imagPart contents) ++ "i" +showVal (Rational contents) = (show (numerator contents)) ++ "/" ++ (show (denominator contents)) +showVal (Float contents) = show contents +showVal (Bool True) = "#t" +showVal (Bool False) = "#f" +showVal (Vector contents) = "#(" ++ (unwordsList $ Data.Array.elems contents) ++ ")" +showVal (HashTable _) = "" +showVal (List contents) = "(" ++ unwordsList contents ++ ")" +showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")" +showVal (PrimitiveFunc _) = "" +showVal (Continuation {closure = _, body = _}) = "" +showVal (Func {params = args, vararg = varargs, body = _, closure = _}) = + "(lambda (" ++ unwords (map show args) ++ + (case varargs of + Nothing -> "" + Just arg -> " . " ++ arg) ++ ") ...)" +showVal (Port _) = "" +showVal (IOFunc _) = "" + +unwordsList :: [LispVal] -> String +unwordsList = unwords . map showVal + +-- |Allow conversion of lispval instances to strings +instance Show LispVal where show = showVal diff --git a/hs-src/Language/Scheme/Variables.hs b/hs-src/Language/Scheme/Variables.hs new file mode 100644 --- /dev/null +++ b/hs-src/Language/Scheme/Variables.hs @@ -0,0 +1,91 @@ +{- + - husk scheme + - Variables + - + - This file contains code for working with Scheme variables + - + - @author Justin Ethier + - + - -} +module Language.Scheme.Variables where +import Language.Scheme.Types +import Control.Monad.Error +import Data.IORef + +-- |Extend given environment by binding a series of values to a new environment. +extendEnv :: Env -> [((String, String), LispVal)] -> IO Env +extendEnv envRef bindings = do bindinglist <- mapM (\((namespace, name), val) -> + do ref <- newIORef val + return ((namespace, name), ref)) bindings + >>= newIORef + return $ Environment (Just envRef) bindinglist + +{- +-- Old implementation, left for the moment for reference purposes only: +-- +-- |Bind a series of values to the given environment. +-- +-- Input is of form: @(namespaceName, variableName), variableValue@ +bindVars :: Env -> [((String, String), LispVal)] -> IO Env +bindVars envRef abindings = (readIORef $ bindings envRef) >>= myExtendEnv abindings >>= newIORef + where myExtendEnv bindings env = liftM (++ env) (mapM addBinding bindings) + addBinding (var, value) = do ref <- newIORef value + return (var, ref) +-} + +-- |Determine if a variable is bound in the default namespace +isBound :: Env -> String -> IO Bool +isBound envRef var = isNamespacedBound envRef varNamespace var + +-- |Determine if a variable is bound in a given namespace +isNamespacedBound :: Env -> String -> String -> IO Bool +isNamespacedBound envRef namespace var = (readIORef $ bindings envRef) >>= return . maybe False (const True) . lookup (namespace, var) + +-- |Retrieve the value of a variable defined in the default namespace +getVar :: Env -> String -> IOThrowsError LispVal +getVar envRef var = getNamespacedVar envRef varNamespace var + +-- |Retrieve the value of a variable defined in a given namespace +getNamespacedVar :: Env -> String -> String -> IOThrowsError LispVal +getNamespacedVar envRef + namespace + var = do binds <- liftIO $ readIORef $ bindings envRef + case lookup (namespace, var) binds of + (Just a) -> liftIO $ readIORef a + Nothing -> case parentEnv envRef of + (Just par) -> getNamespacedVar par namespace var + Nothing -> (throwError $ UnboundVar "Getting an unbound variable" var) + +-- |Set a variable in the default namespace +setVar, defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal +setVar envRef var value = setNamespacedVar envRef varNamespace var value + +-- ^Bind a variable in the default namespace +defineVar envRef var value = defineNamespacedVar envRef varNamespace var value + +-- |Set a variable in a given namespace +setNamespacedVar :: Env -> String -> String -> LispVal -> IOThrowsError LispVal +setNamespacedVar envRef + namespace + var value = do env <- liftIO $ readIORef $ bindings envRef + case lookup (namespace, var) env of + (Just a) -> do --vprime <- liftIO $ readIORef a + liftIO $ writeIORef a value + return value + Nothing -> case parentEnv envRef of + (Just par) -> setNamespacedVar par namespace var value + Nothing -> throwError $ UnboundVar "Setting an unbound variable: " var + +-- |Bind a variable in the given namespace +defineNamespacedVar :: Env -> String -> String -> LispVal -> IOThrowsError LispVal +defineNamespacedVar envRef + namespace + var value = do + alreadyDefined <- liftIO $ isNamespacedBound envRef namespace var + if alreadyDefined + then setNamespacedVar envRef namespace var value >> return value + else liftIO $ do + valueRef <- newIORef value + env <- readIORef $ bindings envRef + writeIORef (bindings envRef) (((namespace, var), valueRef) : env) + return value diff --git a/hs-src/Scheme/Core.hs b/hs-src/Scheme/Core.hs deleted file mode 100644 --- a/hs-src/Scheme/Core.hs +++ /dev/null @@ -1,1114 +0,0 @@ -{- - - husk scheme interpreter - - - - A lightweight dialect of R5RS scheme. - - This file contains Core functionality, primarily Scheme expression evaluation. - - - - @author Justin Ethier - - - - -} - -module Scheme.Core - ( - eval - , evalLisp - , evalString - , evalAndPrint - , primitiveBindings -- FUTURE: this may be a bad idea... - -- but there should be an interface to inject custom functions written in Haskell - ) where -import Scheme.Macro -import Scheme.Numerical -import Scheme.Parser -import Scheme.Types -import Scheme.Variables -import Control.Monad.Error -import Char -import Data.Array -import qualified Data.Map -import Maybe -import List -import IO hiding (try) ---import Debug.Trace - -{-| Evaluate a string containing Scheme code. - - For example: - -@ -env <- primitiveBindings - -evalString env "(+ x x x)" -"3" - -evalString env "(+ x x x (* 3 9))" -"30" - -evalString env "(* 3 9)" -"27" -@ --} -evalString :: Env -> String -> IO String -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 --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 (makeNullContinuation env)) - - -{- continueEval is a support function for eval, below. - - - - 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 --- Passing a higher-order function as the continuation; just evaluate it. This is --- done to enable an 'eval' function to be broken up into multiple sub-functions, --- so that any of the sub-functions can be passed around as a continuation. --- --- This perhaps shows cruft as we also pass cBody (scheme code) as a continuation. --- We could probably just use higher-order functions instead, but both are used for --- two different things. -continueEval _ (Continuation cEnv _ cCont funcArgs (Just func)) val = func cEnv cCont val funcArgs - --- No higher order function, so: --- --- If there is Scheme code to evaluate in the function body, we continue to evaluate it. --- --- Otherwise, if all code in the function has been executed, we 'unwind' to an outer --- continuation (if there is one), or we just return the result. Yes technically with --- CPS you are supposed to keep calling into functions and never return, but eventually --- when the computation is complete, you have to return something. -continueEval _ (Continuation cEnv cBody cCont Nothing Nothing) val = do - case cBody of - [] -> do - case cCont of - Continuation nEnv _ _ _ _ -> continueEval nEnv cCont val - _ -> return (val) - [lv] -> eval cEnv (Continuation cEnv [] cCont Nothing Nothing) (lv) - (lv : lvs) -> eval cEnv (Continuation cEnv lvs cCont Nothing Nothing) (lv) -continueEval _ _ _ = throwError $ Default "Internal error in continueEval" - --- |Core eval function --- Evaluate a scheme expression. --- NOTE: This function does not include macro support and should not be called directly. Instead, use 'evalLisp' --- --- --- Implementation Notes: --- --- Internally, this function is written in continuation passing style (CPS) to allow the Scheme language --- itself to support first-class continuations. That is, at any point in the evaluation, call/cc may --- be used to capture the current continuation. Thus this code must call into the next continuation point, eg: --- --- eval ... (makeCPS ...) --- --- Instead of calling eval directly from within the same function, eg: --- --- eval ... --- eval ... --- --- This can make the code harder to follow, however some coding conventions have been established to make the --- code easier to follow. Whenever a single function has been broken into multiple ones for the purpose of CPS, --- those additional functions are defined locally using 'where', and each has been given a 'cps' prefix. --- -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 - --- Unquote an expression; unquoting is different than quoting in that --- it may also be inter-spliced with code that is meant to be evaluated. -eval envi cont (List [Atom "quasiquote", value]) = cpsUnquote envi cont value Nothing - where cpsUnquote :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsUnquote e c val _ = do - case val of - List [Atom "unquote", vval] -> eval e c vval - List (_ : _) -> doCpsUnquoteList e c val - DottedList xs x -> do - doCpsUnquoteList e (makeCPSWArgs e c cpsUnquotePair $ [x] ) $ List xs - Vector vec -> do - let len = length (elems vec) - doCpsUnquoteList e (makeCPSWArgs e c cpsUnquoteVector $ [Number $ toInteger len]) $ List $ elems vec - _ -> eval e c (List [Atom "quote", val]) -- Behave like quote if there is nothing to "unquote"... - - -- Unquote a pair - -- This must be started by unquoting the "left" hand side of the pair, - -- then pass a continuation to this function to unquote the right-hand side (RHS). - -- This function does the RHS and then calls into a continuation to finish the pair. - cpsUnquotePair :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsUnquotePair e c (List rxs) (Just [rx]) = do - cpsUnquote e (makeCPSWArgs e c cpsUnquotePairFinish $ [List rxs]) rx Nothing - cpsUnquotePair _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquotePair" - - -- Finish unquoting a pair by combining both of the unquoted left/right hand sides. - cpsUnquotePairFinish :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsUnquotePairFinish e c rx (Just [List rxs]) = do - case rx of - List [] -> continueEval e c $ List rxs - List rxlst -> continueEval e c $ List $ rxs ++ rxlst - DottedList rxlst rxlast -> continueEval e c $ DottedList (rxs ++ rxlst) rxlast - _ -> continueEval e c $ DottedList rxs rx - cpsUnquotePairFinish _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquotePairFinish" - - -- Unquote a vector - cpsUnquoteVector :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsUnquoteVector e c (List vList) (Just [Number len]) = continueEval e c (Vector $ listArray (0, fromInteger len) vList) - cpsUnquoteVector _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteVector" - - -- Front-end to cpsUnquoteList, to encapsulate default values in the call - doCpsUnquoteList :: Env -> LispVal -> LispVal -> IOThrowsError LispVal - doCpsUnquoteList e c (List (x:xs)) = cpsUnquoteList e c x $ Just ([List xs, List []]) - doCpsUnquoteList _ _ _ = throwError $ InternalError "Unexpected parameters to doCpsUnquoteList" - - -- Unquote a list - cpsUnquoteList :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsUnquoteList e c val (Just ([List unEvaled, List acc])) = do - case val of - List [Atom "unquote-splicing", vvar] -> do - eval e (makeCPSWArgs e c cpsUnquoteSplicing $ [List unEvaled, List acc]) vvar - _ -> cpsUnquote e (makeCPSWArgs e c cpsUnquoteFld $ [List unEvaled, List acc]) val Nothing - cpsUnquoteList _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteList" - - -- Evaluate an expression instead of quoting it - cpsUnquoteSplicing :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsUnquoteSplicing e c val (Just ([List unEvaled, List acc])) = do - case val of - List v -> case unEvaled of - [] -> continueEval e c $ List $ acc ++ v - _ -> cpsUnquoteList e c (head unEvaled) (Just [List (tail unEvaled), List $ acc ++ v ]) - _ -> throwError $ TypeMismatch "proper list" val - cpsUnquoteSplicing _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteSplicing" - - -- Unquote processing for single field of a list - cpsUnquoteFld :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsUnquoteFld e c val (Just ([List unEvaled, List acc])) = do - case unEvaled of - [] -> continueEval e c $ List $ acc ++ [val] - _ -> cpsUnquoteList e c (head unEvaled) (Just [List (tail unEvaled), List $ acc ++ [val] ]) - cpsUnquoteFld _ _ _ _ = throwError $ InternalError "Unexpected parameters to cpsUnquoteFld" - -eval env cont (List [Atom "if", predic, conseq, alt]) = do - eval env (makeCPS env cont cps) (predic) - where cps :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cps e c result _ = - case (result) of - Bool False -> eval e c alt - _ -> eval e c conseq - -eval env cont (List [Atom "if", predic, conseq]) = - eval env (makeCPS env cont cpsResult) predic - where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsResult e c result _ = - case result of - Bool True -> eval e c conseq - _ -> continueEval e c $ Atom "#unspecified" -- Unspecified return value per R5RS - --- FUTURE: convert cond to a derived form (scheme macro) -eval env cont (List (Atom "cond" : clauses)) = - if length clauses == 0 - then throwError $ BadSpecialForm "No matching clause" $ String "cond" - else do - case (clauses !! 0) of - 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 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 - -eval env cont (List (Atom "begin" : funcs)) = - if length funcs == 0 - then eval env cont $ Nil "" - else if length funcs == 1 - then eval env cont (head funcs) - else eval env (makeCPSWArgs env cont cpsRest $ tail funcs) (head funcs) - where cpsRest :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsRest e c _ args = - case args of - Just fArgs -> eval e c $ List (Atom "begin" : fArgs) - Nothing -> throwError $ Default "Unexpected error in begin" - - --- TODO: rewrite in CPS (??) -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 cont (List [Atom "set!", Atom var, form]) = do - eval env (makeCPS env cont cpsResult) form - where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsResult e c result _ = setVar e var result >>= continueEval e c - -eval env cont (List [Atom "define", Atom var, form]) = do - eval env (makeCPS env cont cpsResult) form - where cpsResult :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsResult e c result _ = defineVar e var result >>= continueEval e c - -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 cont (List [Atom "string-fill!", Atom var, character]) = do - eval env (makeCPS env cont cpsVar) =<< getVar env var - where cpsVar :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsVar e c result _ = eval e (makeCPSWArgs e c cpsChr $ [result]) $ character - - cpsChr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsChr e c result (Just [rVar]) = (fillStr(rVar, result) >>= setVar e var) >>= continueEval e c - cpsChr _ _ _ _ = throwError $ Default "Unexpected error in string-fill!" - - 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 - eval env (makeCPS env cont cpsStr) i - where - cpsStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsStr e c idx _ = eval e (makeCPSWArgs e c cpsSubStr $ [idx]) =<< getVar e var - - cpsSubStr :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsSubStr e c str (Just [idx]) = - substr(str, character, idx) >>= setVar e var >>= continueEval e c - cpsSubStr _ _ _ _ = throwError $ InternalError "Invalid argument to cpsSubStr" - - substr (String str, Char char, Number ii) = do - return $ String $ (take (fromInteger ii) . drop 0) str ++ - [char] ++ - (take (length str) . drop (fromInteger ii + 1)) str - substr (String _, Char _, n) = throwError $ TypeMismatch "number" n - substr (String _, c, _) = throwError $ TypeMismatch "character" c - substr (s, _, _) = throwError $ TypeMismatch "string" s - -eval env cont (List [Atom "set-cdr!", Atom var, argObj]) = do --- eval env (makeCPS env cont cpsObj) =<< getVar env var - continueEval env (makeCPS env cont cpsObj) =<< getVar env var - where - cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsObj _ _ pair@(List []) _ = throwError $ TypeMismatch "pair" pair - cpsObj e c pair@(List (_:_)) _ = eval e (makeCPSWArgs e c cpsSet $ [pair]) argObj - cpsObj e c pair@(DottedList _ _) _ = eval e (makeCPSWArgs e c cpsSet $ [pair]) argObj - cpsObj _ _ pair _ = throwError $ TypeMismatch "pair" pair - - cpsSet :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsSet e c obj (Just [List (l : _)]) = setVar e var (DottedList [l] obj) >>= continueEval e c - cpsSet e c obj (Just [DottedList (l : _) _]) = setVar e var (DottedList [l] obj) >>= continueEval e c - cpsSet _ _ _ _ = throwError $ InternalError "Unexpected argument to cpsSet" - -eval env cont (List [Atom "vector-set!", Atom var, i, object]) = do - eval env (makeCPS env cont cpsObj) i - where - cpsObj :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsObj e c idx _ = eval e (makeCPSWArgs e c cpsVec $ [idx]) object - - cpsVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsVec e c obj (Just [idx]) = eval e (makeCPSWArgs e c cpsUpdateVec $ [idx, obj]) =<< getVar e var - cpsVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsVec" - - cpsUpdateVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsUpdateVec e c vec (Just [idx, obj]) = - updateVector vec idx obj >>= setVar e var >>= continueEval e c - cpsUpdateVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsUpdateVec" - - 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 cont (List [Atom "vector-fill!", Atom var, object]) = do - eval env (makeCPS env cont cpsVec) object - where - cpsVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsVec e c obj _ = eval e (makeCPSWArgs e c cpsFillVec $ [obj]) =<< getVar e var - - cpsFillVec :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsFillVec e c vec (Just [obj]) = - fillVector vec obj >>= setVar e var >>= continueEval e c - cpsFillVec _ _ _ _ = throwError $ InternalError "Invalid argument to cpsFillVec" - - fillVector :: LispVal -> LispVal -> IOThrowsError LispVal - fillVector (Vector vec) obj = do - let l = replicate (lenVector vec) obj - return $ Vector $ (listArray (0, length l - 1)) l - fillVector v _ = throwError $ TypeMismatch "vector" v - lenVector v = length (elems v) - -eval env cont (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do - eval env (makeCPS env cont cpsValue) rkey - where - cpsValue :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsValue e c key _ = eval e (makeCPSWArgs e c cpsH $ [key]) rvalue - - cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsH e c value (Just [key]) = eval e (makeCPSWArgs e c cpsEvalH $ [key, value]) =<< getVar e var - cpsH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsH" - - cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsEvalH e c h (Just [key, value]) = do - case h of - HashTable ht -> do - setVar env var (HashTable $ Data.Map.insert key value ht) >>= eval e c - other -> throwError $ TypeMismatch "hash-table" other - cpsEvalH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsEvalH" - -eval env cont (List [Atom "hash-table-delete!", Atom var, rkey]) = do - eval env (makeCPS env cont cpsH) rkey - where - cpsH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsH e c key _ = eval e (makeCPSWArgs e c cpsEvalH $ [key]) =<< getVar e var - - cpsEvalH :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsEvalH e c h (Just [key]) = do - case h of - HashTable ht -> do - setVar env var (HashTable $ Data.Map.delete key ht) >>= eval e c - other -> throwError $ TypeMismatch "hash-table" other - cpsEvalH _ _ _ _ = throwError $ InternalError "Invalid argument to cpsEvalH" - --- TODO: --- hash-table-merge! - - -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" : applyArgs)) = do - eval env (makeCPSWArgs env cont cpsLast $ [List applyArgs]) $ head applyArgs - where cpsLast :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsLast e c proc (Just [List args]) = - eval e (makeCPSWArgs e c cpsArgs $ [proc, List $ tail $ reverse $ tail $ reverse args]) $ head $ reverse args - cpsLast _ _ _ _ = throwError $ InternalError "Invalid arguments to cpsLast" - - cpsArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsArgs e c lst (Just [proc, List args]) = - case args of - [] -> cpsApply c (Just [proc, lst, List args]) - _ -> eval e (makeCPSWArgs e c cpsEvalArgs $ [proc, lst, List $ tail args, List []]) $ head args - cpsArgs _ _ _ _ = throwError $ InternalError "Invalid arguments to cpsArgs" - - cpsEvalArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsEvalArgs e c result (Just [proc, lst, List args, List evaledArgs]) = - case args of - [] -> cpsApply c (Just [proc, lst, List (evaledArgs ++ [result])]) - (x:xs) -> eval e (makeCPSWArgs e c cpsEvalArgs $ [proc, lst, List xs, List (evaledArgs ++ [result])]) x - cpsEvalArgs _ _ _ _ = throwError $ InternalError "Invalid arguments to cpsEvalArgs" - - cpsApply :: LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsApply c (Just [proc, lst, List argVals]) = do - case lst of - List l -> apply c proc (argVals ++ l) - other -> throwError $ TypeMismatch "list" other - cpsApply _ _ = throwError $ InternalError "Invalid arguments to cpsApply" - -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 -- TODO: Use CPS here instead???? - case func of - PrimitiveFunc f -> do - result <- liftThrows $ f [cont] - case cont of - Continuation cEnv _ _ _ _ -> continueEval cEnv cont result - _ -> return result - Func aparams _ _ _ -> - if (toInteger $ length aparams) == 1 - then apply cont func [cont] - else throwError $ NumArgs (toInteger $ length aparams) [cont] - other -> throwError $ TypeMismatch "procedure" other - --- Call a function by evaluating its arguments and then --- executing it via 'apply'. -eval env cont (List (function : functionArgs)) = do - eval env (makeCPSWArgs env cont cpsPrepArgs $ functionArgs) function - where cpsPrepArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsPrepArgs e c func (Just args) = --- case (trace ("prep eval of args: " ++ show args) args) of - case (args) of - [] -> apply c func [] -- No args, immediately apply the function - [a] -> eval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List []]) a - (a:as) -> eval env (makeCPSWArgs e c cpsEvalArgs $ [func, List [], List as]) a - cpsPrepArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (1)" - -- Store value of previous argument, evaluate the next arg until all are done - -- parg - Previous argument that has now been evaluated - -- state - List containing the following, in order: - -- - Function to apply when args are ready - -- - List of evaluated parameters - -- - List of parameters awaiting evaluation - cpsEvalArgs :: Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal - cpsEvalArgs e c evaledArg (Just [func, List argsEvaled, List argsRemaining]) = - case argsRemaining of - [] -> apply c func (argsEvaled ++ [evaledArg]) - [a] -> eval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List []]) a - (a:as) -> eval e (makeCPSWArgs e c cpsEvalArgs $ [func, List (argsEvaled ++ [evaledArg]), List as]) a - - cpsEvalArgs _ _ _ (Just _) = throwError $ Default "Unexpected error in function application (1)" - cpsEvalArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (2)" - -eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm - -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 -makeNormalFunc :: (Monad m) => Env - -> [LispVal] - -> [LispVal] - -> m LispVal -makeNormalFunc = makeFunc Nothing -makeVarargs :: (Monad m) => LispVal -> Env - -> [LispVal] - -> [LispVal] - -> m LispVal -makeVarargs = makeFunc . Just . showVal - --- Call into a Scheme function -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 -apply cont (IOFunc func) args = do - result <- func args - case cont of - Continuation cEnv _ _ _ _ -> continueEval cEnv cont result - _ -> return result -apply cont (PrimitiveFunc func) args = do - result <- liftThrows $ func args - case cont of - Continuation cEnv _ _ _ _ -> continueEval cEnv cont result - _ -> return result -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) - where remainingArgs = drop (length aparams) args - num = toInteger . length - -- - -- 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 _ Nothing -> if length cBody == 0 - then continueWCont env (evBody) cCont - else continueWCont env (evBody) cont -- Might be a problem, not fully optimizing - _ -> continueWCont env (evBody) cont - - -- Shortcut for calling continueEval - continueWCont cwcEnv cwcBody cwcCont = - continueEval cwcEnv (Continuation cwcEnv cwcBody cwcCont Nothing Nothing) $ Nil "" - - bindVarArgs arg env = case arg of - Just argName -> liftIO $ extendEnv env [((varNamespace, argName), List $ remainingArgs)] - Nothing -> return env -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 --- in the standard library which must be pulled into the environment using (load). -primitiveBindings :: IO Env -primitiveBindings = nullEnv >>= (flip extendEnv $ map (domakeFunc IOFunc) ioPrimitives - ++ map (domakeFunc PrimitiveFunc) primitives) - where domakeFunc constructor (var, func) = ((varNamespace, var), constructor func) - -ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)] -ioPrimitives = [("open-input-file", makePort ReadMode), - ("open-output-file", makePort WriteMode), - ("close-input-port", closePort), - ("close-output-port", closePort), - ("read", readProc), - ("write", writeProc), - ("read-contents", readContents), - ("read-all", readAll)] - -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) -closePort _ = return $ Bool False - -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), - ("-", numSub), - ("*", numMul), - ("/", numDiv), - ("modulo", numericBinop mod), - ("quotient", numericBinop quot), - ("remainder", numericBinop rem), - - ("round", numRound), - ("floor", numFloor), - ("ceiling", numCeiling), - ("truncate", numTruncate), - - ("numerator", numNumerator), - ("denominator", numDenominator), - - ("exp", numExp), - ("log", numLog), - ("sin", numSin), - ("cos", numCos), - ("tan", numTan), - ("asin", numAsin), - ("acos", numAcos), - ("atan", numAtan), - - ("sqrt", numSqrt), - ("expt", numExpt), - - ("make-rectangular", numMakeRectangular), - ("make-polar", numMakePolar), - ("real-part", numRealPart ), - ("imag-part", numImagPart), - ("magnitude", numMagnitude), - ("angle", numAngle ), - - ("exact->inexact", numExact2Inexact), - ("inexact->exact", numInexact2Exact), - - ("number->string", num2String), - - ("=", numBoolBinopEq), - (">", numBoolBinopGt), - (">=", numBoolBinopGte), - ("<", numBoolBinopLt), - ("<=", numBoolBinopLte), - --- TODO: sweep through the spec to make sure all numeric procedures are accounted for - --- TODO: sweep through spec and implement all numeric "library procedures" - but in stdlib.scm - --- TODO: string and number conversion functions; need to make --- sure they are implemented and that they handle the full tower - - - ("&&", boolBoolBinop (&&)), - ("||", boolBoolBinop (||)), - ("string=?", strBoolBinop (==)), - ("string?", strBoolBinop (>)), - ("string<=?", strBoolBinop (<=)), - ("string>=?", strBoolBinop (>=)), - ("string-ci=?", stringCIEquals), - ("string-ci?", stringCIBoolBinop (>)), - ("string-ci<=?", stringCIBoolBinop (<=)), - ("string-ci>=?", stringCIBoolBinop (>=)), - - ("car", car), - ("cdr", cdr), - ("cons", cons), - ("eq?", eqv), - ("eqv?", eqv), - ("equal?", equal), - - ("pair?", isDottedList), - ("procedure?", isProcedure), -{- - TODO: full numeric tower: number?, complex?, rational? - --} - ("number?", isNumber), - ("complex?", isComplex), - ("real?", isReal), - ("rational?", isRational), - ("integer?", isInteger), - ("list?", unaryOp isList), - ("null?", isNull), - ("symbol?", isSymbol), - ("symbol->string", symbol2String), - ("string->symbol", string2Symbol), - ("char?", isChar), - - ("vector?", unaryOp isVector), - ("make-vector", makeVector), - ("vector", buildVector), - ("vector-length", vectorLength), - ("vector-ref", vectorRef), - ("vector->list", vectorToList), - ("list->vector", listToVector), - - ("make-hash-table", hashTblMake), - ("hash-table?", isHashTbl), --- TODO: alist->hash-table - ("hash-table-exists?", hashTblExists), - ("hash-table-ref", hashTblRef), - ("hash-table-size", hashTblSize), - ("hash-table->alist", hashTbl2List), - ("hash-table-keys", hashTblKeys), - ("hash-table-values", hashTblValues), --- TODO next: hash-table-walk, hash-table-fold --- TODO: many more, see SRFI - ("hash-table-copy", hashTblCopy), - - ("string?", isString), - ("string", buildString), - ("make-string", makeString), - ("string-length", stringLength), - ("string-ref", stringRef), - ("substring", substring), - ("string-append", stringAppend), - ("string->number", stringToNumber), - ("string->list", stringToList), - ("list->string", listToString), - ("string-copy", stringCopy), - - ("boolean?", isBoolean)] - -data Unpacker = forall a. Eq a => AnyUnpacker (LispVal -> ThrowsError a) - -unpackEquals :: LispVal -> LispVal -> Unpacker -> ThrowsError Bool -unpackEquals arg1 arg2 (AnyUnpacker unpacker) = - do unpacked1 <- unpacker arg1 - unpacked2 <- unpacker arg2 - return $ unpacked1 == unpacked2 - `catchError` (const $ return False) - -boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal -boolBinop unpacker op args = if length args /= 2 - then throwError $ NumArgs 2 args - else do left <- unpacker $ args !! 0 - right <- unpacker $ args !! 1 - return $ Bool $ left `op` right - -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 -strBoolBinop = boolBinop unpackStr -boolBoolBinop :: (Bool -> Bool -> Bool) -> [LispVal] -> ThrowsError LispVal -boolBoolBinop = boolBinop unpackBool - -unpackStr :: LispVal -> ThrowsError String -unpackStr (String s) = return s -unpackStr (Number s) = return $ show s -unpackStr (Bool s) = return $ show s -unpackStr notString = throwError $ TypeMismatch "string" notString - -unpackBool :: LispVal -> ThrowsError Bool -unpackBool (Bool b) = return b -unpackBool notBool = throwError $ TypeMismatch "boolean" notBool - -{- List primitives -} -car :: [LispVal] -> ThrowsError LispVal -car [List (x : _)] = return x -car [DottedList (x : _) _] = return x -car [badArg] = throwError $ TypeMismatch "pair" badArg -car badArgList = throwError $ NumArgs 1 badArgList - -cdr :: [LispVal] -> ThrowsError LispVal -cdr [List (_ : xs)] = return $ List xs -cdr [DottedList [_] x] = return x -cdr [DottedList (_ : xs) x] = return $ DottedList xs x -cdr [badArg] = throwError $ TypeMismatch "pair" badArg -cdr badArgList = throwError $ NumArgs 1 badArgList - -cons :: [LispVal] -> ThrowsError LispVal -cons [x1, List []] = return $ List [x1] -cons [x, List xs] = return $ List $ x : xs -cons [x, DottedList xs xlast] = return $ DottedList (x : xs) xlast -cons [x1, x2] = return $ DottedList [x1] x2 -cons badArgList = throwError $ NumArgs 2 badArgList - -equal :: [LispVal] -> ThrowsError LispVal -equal [(Vector arg1), (Vector arg2)] = eqvList equal [List $ (elems arg1), List $ (elems arg2)] --- TODO: hash table? -equal [l1@(List _), l2@(List _)] = eqvList equal [l1, l2] -equal [(DottedList xs x), (DottedList ys y)] = equal [List $ xs ++ [x], List $ ys ++ [y]] -equal [arg1, arg2] = do - primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2) - [AnyUnpacker unpackNum, AnyUnpacker unpackStr, AnyUnpacker unpackBool] - eqvEquals <- eqv [arg1, arg2] - return $ Bool $ (primitiveEquals || let (Bool x) = eqvEquals in x) -equal badArgList = throwError $ NumArgs 2 badArgList - --------------- Vector Primitives -------------- - -makeVector, buildVector, vectorLength, vectorRef, vectorToList, listToVector :: [LispVal] -> ThrowsError LispVal -makeVector [(Number n)] = makeVector [Number n, List []] -makeVector [(Number n), a] = do - let l = replicate (fromInteger n) a - return $ Vector $ (listArray (0, length l - 1)) l -makeVector [badType] = throwError $ TypeMismatch "integer" badType -makeVector badArgList = throwError $ NumArgs 1 badArgList - -buildVector (o:os) = do - let lst = o:os - return $ Vector $ (listArray (0, length lst - 1)) lst -buildVector badArgList = throwError $ NumArgs 1 badArgList - -vectorLength [(Vector v)] = return $ Number $ toInteger $ length (elems v) -vectorLength [badType] = throwError $ TypeMismatch "vector" badType -vectorLength badArgList = throwError $ NumArgs 1 badArgList - -vectorRef [(Vector v), (Number n)] = return $ v ! (fromInteger n) -vectorRef [badType] = throwError $ TypeMismatch "vector integer" badType -vectorRef badArgList = throwError $ NumArgs 2 badArgList - -vectorToList [(Vector v)] = return $ List $ elems v -vectorToList [badType] = throwError $ TypeMismatch "vector" badType -vectorToList badArgList = throwError $ NumArgs 1 badArgList - -listToVector [(List l)] = return $ Vector $ (listArray (0, length l - 1)) l -listToVector [badType] = throwError $ TypeMismatch "list" badType -listToVector badArgList = throwError $ NumArgs 1 badArgList - --------------- Hash Table Primitives -------------- - --- Future: support (equal?), (hash) parameters -hashTblMake, isHashTbl, hashTblExists, hashTblRef, hashTblSize, hashTbl2List, hashTblKeys, hashTblValues, hashTblCopy:: [LispVal] -> ThrowsError LispVal -hashTblMake _ = return $ HashTable $ Data.Map.fromList [] - -isHashTbl [(HashTable _)] = return $ Bool True -isHashTbl _ = return $ Bool False - -hashTblExists [(HashTable ht), key@(_)] = do - 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 - Just val -> return $ val - Nothing -> throwError $ BadSpecialForm "Hash table does not contain key" key -hashTblRef [(HashTable ht), key@(_), Func _ _ _ _] = do - case Data.Map.lookup key ht of - Just val -> return $ val - Nothing -> throwError $ NotImplemented "thunk" --- FUTURE: a thunk can optionally be specified, this drives definition of /default --- Nothing -> apply thunk [] -hashTblRef [badType] = throwError $ TypeMismatch "hash-table" badType -hashTblRef badArgList = throwError $ NumArgs 2 badArgList - -hashTblSize [(HashTable ht)] = return $ Number $ toInteger $ Data.Map.size ht -hashTblSize [badType] = throwError $ TypeMismatch "hash-table" badType -hashTblSize badArgList = throwError $ NumArgs 1 badArgList - -hashTbl2List [(HashTable ht)] = do - return $ List $ map (\(k, v) -> List [k, v]) $ Data.Map.toList ht -hashTbl2List [badType] = throwError $ TypeMismatch "hash-table" badType -hashTbl2List badArgList = throwError $ NumArgs 1 badArgList - -hashTblKeys [(HashTable ht)] = do - return $ List $ map (\(k, _) -> k) $ Data.Map.toList ht -hashTblKeys [badType] = throwError $ TypeMismatch "hash-table" badType -hashTblKeys badArgList = throwError $ NumArgs 1 badArgList - -hashTblValues [(HashTable ht)] = do - return $ List $ map (\(_, v) -> v) $ Data.Map.toList ht -hashTblValues [badType] = throwError $ TypeMismatch "hash-table" badType -hashTblValues badArgList = throwError $ NumArgs 1 badArgList - -hashTblCopy [(HashTable ht)] = do - return $ HashTable $ Data.Map.fromList $ Data.Map.toList ht -hashTblCopy [badType] = throwError $ TypeMismatch "hash-table" badType -hashTblCopy badArgList = throwError $ NumArgs 1 badArgList - --------------- String Primitives -------------- - -buildString :: [LispVal] -> ThrowsError LispVal -buildString [(Char c)] = return $ String [c] -buildString (Char c:rest) = do - cs <- buildString rest - case cs of - String s -> return $ String $ [c] ++ s - badType -> throwError $ TypeMismatch "character" badType -buildString [badType] = throwError $ TypeMismatch "character" badType -buildString badArgList = throwError $ NumArgs 1 badArgList - -makeString :: [LispVal] -> ThrowsError LispVal -makeString [(Number n)] = return $ doMakeString n ' ' "" -makeString [(Number n), (Char c)] = return $ doMakeString n c "" -makeString badArgList = throwError $ NumArgs 1 badArgList - -doMakeString :: forall a.(Num a) => a -> Char -> String -> LispVal -doMakeString n char s = - if n == 0 - then String s - else doMakeString (n - 1) char (s ++ [char]) - -stringLength :: [LispVal] -> ThrowsError LispVal -stringLength [String s] = return $ Number $ foldr (const (+1)) 0 s -- Could probably do 'length s' instead... -stringLength [badType] = throwError $ TypeMismatch "string" badType -stringLength badArgList = throwError $ NumArgs 1 badArgList - -stringRef :: [LispVal] -> ThrowsError LispVal -stringRef [(String s), (Number k)] = return $ Char $ s !! fromInteger k -stringRef [badType] = throwError $ TypeMismatch "string number" badType -stringRef badArgList = throwError $ NumArgs 2 badArgList - -substring :: [LispVal] -> ThrowsError LispVal -substring [(String s), (Number start), (Number end)] = - do let slength = fromInteger $ end - start - let begin = fromInteger start - return $ String $ (take slength . drop begin) s -substring [badType] = throwError $ TypeMismatch "string number number" badType -substring badArgList = throwError $ NumArgs 3 badArgList - -stringCIEquals :: [LispVal] -> ThrowsError LispVal -stringCIEquals [(String str1), (String str2)] = do - if (length str1) /= (length str2) - then return $ Bool False - else return $ Bool $ ciCmp str1 str2 0 - where ciCmp s1 s2 idx = if idx == (length s1) - then True - else if (toLower $ s1 !! idx) == (toLower $ s2 !! idx) - then ciCmp s1 s2 (idx + 1) - else False -stringCIEquals [badType] = throwError $ TypeMismatch "string string" badType -stringCIEquals badArgList = throwError $ NumArgs 2 badArgList - -stringCIBoolBinop :: ([Char] -> [Char] -> Bool) -> [LispVal] -> ThrowsError LispVal -stringCIBoolBinop op [(String s1), (String s2)] = boolBinop unpackStr op [(String $ strToLower s1), (String $ strToLower s2)] - where strToLower str = map (toLower) str -stringCIBoolBinop _ [badType] = throwError $ TypeMismatch "string string" badType -stringCIBoolBinop _ badArgList = throwError $ NumArgs 2 badArgList - -stringAppend :: [LispVal] -> ThrowsError LispVal -stringAppend [(String s)] = return $ String s -- Needed for "last" string value -stringAppend (String st:sts) = do - rest <- stringAppend sts --- TODO: I needed to use <- instead of "let = " here, for type problems. Why??? --- TBD: this probably will solve type problems when processing other lists of objects in the other string functions - case rest of - String s -> return $ String $ st ++ s - other -> throwError $ TypeMismatch "string" other -stringAppend [badType] = throwError $ TypeMismatch "string" badType -stringAppend badArgList = throwError $ NumArgs 1 badArgList - --- This could be expanded, for now just converts integers --- TODO: handle a radix param -stringToNumber :: [LispVal] -> ThrowsError LispVal -stringToNumber [(String s)] = do - result <- (readExpr s) -- result <- parseExpr s - case result of - n@(Number _) -> return n - n@(Rational _) -> return n - n@(Float _) -> return n - n@(Complex _) -> return n - _ -> return $ Bool False -stringToNumber [badType] = throwError $ TypeMismatch "string" badType -stringToNumber badArgList = throwError $ NumArgs 1 badArgList - -stringToList :: [LispVal] -> ThrowsError LispVal -stringToList [(String s)] = return $ List $ map (Char) s -stringToList [badType] = throwError $ TypeMismatch "string" badType -stringToList badArgList = throwError $ NumArgs 1 badArgList - -listToString :: [LispVal] -> ThrowsError LispVal -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 -stringCopy [badType] = throwError $ TypeMismatch "string" badType -stringCopy badArgList = throwError $ NumArgs 2 badArgList - -isDottedList :: [LispVal] -> ThrowsError LispVal -isDottedList ([DottedList _ _]) = return $ Bool True --- Must include lists as well since they are made up of 'chains' of pairs -isDottedList ([List []]) = return $ Bool False -isDottedList ([List _]) = return $ Bool True -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 -isProcedure _ = return $ Bool False - -isVector, isList :: LispVal -> ThrowsError LispVal -isVector (Vector _) = return $ Bool True -isVector _ = return $ Bool False -isList (List _) = return $ Bool True -isList _ = return $ Bool False - -isNull :: [LispVal] -> ThrowsError LispVal -isNull ([List []]) = return $ Bool True -isNull _ = return $ Bool False - -isSymbol :: [LispVal] -> ThrowsError LispVal -isSymbol ([Atom _]) = return $ Bool True -isSymbol _ = return $ Bool False - -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 -isChar _ = return $ Bool False - -isString :: [LispVal] -> ThrowsError LispVal -isString ([String _]) = return $ Bool True -isString _ = return $ Bool False - -isBoolean :: [LispVal] -> ThrowsError LispVal -isBoolean ([Bool _]) = return $ Bool True -isBoolean _ = return $ Bool False --- end Eval section - -{- Should not need this function, since we are using Haskell -trampoline :: Env -> LispVal -> IOThrowsError LispVal -trampoline env val = do - result <- eval env val - case result of - -- If a form is not fully-evaluated to a value, bounce it back onto the trampoline... - func@(Func params vararg body closure True) -> trampoline env func -- next iteration, via tail call (?) - val -> return val --} - -{- My original notes about implementing continuations - - - - TODO: write a wiki page about continuations once everything is implemented. - - maybe use some of this as background material for the article. - - - - 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... - - - - -} - diff --git a/hs-src/Scheme/Macro.hs b/hs-src/Scheme/Macro.hs deleted file mode 100644 --- a/hs-src/Scheme/Macro.hs +++ /dev/null @@ -1,471 +0,0 @@ -{- - - husk scheme - - Macro - - @author Justin Ethier - - - - Purpose: - - - - This file contains code for hygienic macros. - - - - During transformation, the following components are considered: - - - Pattern (part of a rule that matches input) - - - Transform (what the macro "expands" into) - - - Input (the actual code in the user's program) - - - - At a high level, macro transformation is broken down into the following steps: - - - - 1) Search for a rule that matches the input. - - During this process, any variables in the input are loaded into a temporary environment - - 2) If a rule matches, - - 3) Transform by walking the transform, inserting variables as needed - - - - - - Remaining Work: - - - - * Vectors are currently not supported - - - - * Dotted lists are not 100% correctly implemented. In particular, the transformation should - - take into account whether the input was presented as a list or a pair, and replicate that - - in the output. - - - - -} -module Scheme.Macro - ( - macroEval - ) where -import Scheme.Types -import Scheme.Variables -import Control.Monad.Error ---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 - --- 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 _ : _)))]) = 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 (List (x@(List _) : xs)) = do - first <- macroEval env x - rest <- mapM (macroEval env) xs - return $ List $ first : rest --- TODO: equivalent matches/transforms for vectors --- what about dotted lists? -macroEval env lisp@(List (Atom x : xs)) = do - isDefined <- liftIO $ isNamespacedBound env macroNamespace x - if isDefined - then do - (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 - rest <- mapM (macroEval env) xs - return $ List $ (Atom x) : rest -macroEval _ lisp@(_) = return lisp - --- Given input and syntax-rules, determine if any rule is a match and transform it. --- --- FUTURE: validate that the pattern's template and pattern are consistent (IE: no vars in transform that do not appear in matching pattern - csi "stmt1" case) --- --- Parameters: --- env - Higher level LISP environment --- identifiers - Literal identifiers - IE, atoms that should not be transformed --- rules - pattern/transform pairs to compare to input --- input - Code from the scheme application -macroTransform :: Env -> LispVal -> [LispVal] -> LispVal -> IOThrowsError LispVal -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 - _ -> 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 (_:ps)) = do - if not (null ps) - then case (head ps) of - Atom "..." -> True - _ -> 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 _ 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] - _ -> 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 "" - _ -> transformRule localEnv 0 (List []) template (List []) - _ -> throwError $ BadSpecialForm "Malformed rule in syntax-rules" p - -matchRule _ _ _ rule input = do - throwError $ BadSpecialForm "Malformed rule in syntax-rules" $ List [Atom "rule: ", rule, Atom "input: ", input] - --- --- loadLocal - Determine if pattern matches input, loading input into pattern variables as we go, --- in preparation for macro transformation. -loadLocal :: Env -> LispVal -> LispVal -> LispVal -> Bool -> Bool -> IOThrowsError LispVal -loadLocal localEnv identifiers pattern input hasEllipsis outerHasEllipsis = do -- TODO: kind of a hack to have both ellipsis vars. Is only outer req'd? - case (pattern, input) of - - -- Future: vector - - ((DottedList ps p), (DottedList is i)) -> do - result <- loadLocal localEnv identifiers (List ps) (List is) False outerHasEllipsis - case result of - Bool True -> loadLocal localEnv identifiers p i False outerHasEllipsis - _ -> return $ Bool False - - (List (p:ps), List (i:is)) -> do -- check first input against first pattern, recurse... - - 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 (localHasEllipsis || outerHasEllipsis) p i - case status of - -- No match - 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 - _ -> 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 (_: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 - if (macroElementMatchesMany pattern) && ((length ps) == 1) - then return $ Bool True - else return $ Bool False - - -- Pattern ran out, but there is still input. No match. - (List [], _) -> return $ Bool False - - -- Check input against pattern (both should be single var) - (_, _) -> checkLocal localEnv identifiers (hasEllipsis || outerHasEllipsis) pattern input - --- Check pattern against input to determine if there is a match --- --- @param localEnv - Local variables for the macro, used during transform --- @param hasEllipsis - Determine whether we are in a zero-or-many match. --- Used for loading local vars and NOT for purposes of matching. --- @param pattern - Pattern to match --- @param input - Input to be matched -checkLocal :: Env -> LispVal -> Bool -> LispVal -> LispVal -> IOThrowsError LispVal -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... - then do isDefined <- liftIO $ isBound localEnv pattern - -- If pattern is a literal identifier, then just pass it along as-is - -- - -- - -- TODO: is this OK? May need to compare literal identifier as we are - -- doing below in the 'else do' - -- - -- - found <- findAtom (Atom pattern) identifiers - let val = case found of - (Bool True) -> Atom pattern - _ -> 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]) - return $ Bool True - -- Simple var, try to load up into macro env - else do - isIdent <- findAtom (Atom pattern) identifiers - case isIdent of - -- Fail the match if pattern is a literal identifier and input does not match - Bool True -> do - case input of - Atom inpt -> do - -- Pattern/Input are atoms; both must match - if (pattern == inpt) - then do defineVar localEnv pattern input - return $ Bool True - else return $ (Bool False) - -- Pattern/Input cannot match because input is not an atom - _ -> return $ (Bool False) - - -- No literal identifier, just load up the var - _ -> do defineVar localEnv pattern input - return $ Bool True - --- TODO: vector support. And what the heck are these next two TODO's doing here? :) --- 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 _ _) 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 - if (length ps) == (length is) - -- Lists are same length, implying elements in both should be the same. - -- Cast pair to a List for further processing - then loadLocal localEnv identifiers (List $ ps ++ [p]) input False hasEllipsis - -- Idea here is that if we have a dotted list, the last component does not have to be provided - -- in the input. So in that case just fill in an empty list for the missing component. - else loadLocal localEnv identifiers pattern (DottedList (i : is) (List [])) False hasEllipsis -checkLocal localEnv identifiers hasEllipsis pattern@(List _) input@(List _) = - loadLocal localEnv identifiers pattern input False hasEllipsis - -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 -transformRule :: Env -> Int -> LispVal -> LispVal -> LispVal -> IOThrowsError LispVal - --- Recursively transform a list --- --- Parameters: --- --- localEnv - Local variable environment --- ellipsisIndex - Zero-or-more match variables are stored as a list. --- This is the index into the current value to read from list --- result - Resultant value, must be a parameter as it mutates with each function call, so we pass it using CPS --- transform - The macro transformation, we read it out one atom at a time, and rewrite it into result --- ellipsisList - Temporarily holds value of the "outer" result while we process the --- zero-or-more match. Once that is complete we swap this value back into it's rightful place --- -transformRule localEnv ellipsisIndex (List result) transform@(List(List l : ts)) (List ellipsisList) = do - if macroElementMatchesMany transform - then do - curT <- transformRule localEnv (ellipsisIndex + 1) (List []) (List l) (List result) - case curT of - Nil _ -> 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 $ ellipsisList ++ result) (List $ tail ts) (List []) - -- Dotted list transform returned during processing... - 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 _ -> 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 _, _] -> return lst - List _ -> transformRule localEnv ellipsisIndex (List $ result ++ [lst]) (List ts) (List ellipsisList) - Nil _ -> return 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 _ _) : 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) ...) - curT <- transformDottedList localEnv (ellipsisIndex + 1) (List []) (List [dl]) (List result) - case curT of - Nil _ -> 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 $ 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 _] -> 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 _] -> return lst - List l -> transformRule localEnv ellipsisIndex (List $ result ++ l) (List ts) (List ellipsisList) - Nil _ -> return lst - _ -> throwError $ BadSpecialForm "transformRule: Macro transform error" $ List [(List ellipsisList), lst, (List [dl]), Number $ toInteger ellipsisIndex] - - --- Transform an atom by attempting to look it up as a var... -transformRule localEnv ellipsisIndex (List result) transform@(List (Atom a : ts)) unused = do - let hasEllipsis = macroElementMatchesMany transform - isDefined <- liftIO $ isBound localEnv a - if hasEllipsis - then if isDefined - then do - -- get var - var <- getVar localEnv a - -- ensure it is a list - case var of - -- add all elements of the list into result - List v -> transformRule localEnv ellipsisIndex (List $ result ++ v) (List $ tail ts) unused - v@(_) -> transformRule localEnv ellipsisIndex (List $ result ++ [v]) (List $ tail ts) unused - else -- Matched 0 times, skip it - transformRule localEnv ellipsisIndex (List result) (List $ tail ts) unused - else do t <- if isDefined - then do var <- getVar localEnv a - if ellipsisIndex > 0 - then do case var of - 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 - _ -> transformRule localEnv ellipsisIndex (List $ result ++ [t]) (List ts) unused - --- Transform anything else as itself... -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 _ _ result@(List _) (List []) _ = do - return result - -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 _ (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. --- --- Input: --- localEnv - Local environment that contains variables --- src - Input source, required because a pair in the pattern may be matched by either a list or a pair, --- and the transform needs to know this... --- identifiers - Literal identifiers that are transformed as themselves --- pattern - Pattern portion of the syntax rule -initializePatternVars :: Env -> String -> LispVal -> LispVal -> IOThrowsError LispVal -initializePatternVars localEnv src identifiers pattern@(List _) = do - case pattern of - 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 (DottedList ps p) = do - initializePatternVars localEnv src identifiers $ List ps - initializePatternVars localEnv src identifiers p - --- TODO: vector - -initializePatternVars localEnv src identifiers (Atom pattern) = - -- FUTURE: - -- there is code to attempt to flag "src" here, but it is not - -- wire up correctly. In fact, the whole design here probably - -- needs to be rethinked. - do defineNamespacedVar localEnv "src" pattern $ String src - isDefined <- liftIO $ isBound localEnv pattern - found <- findAtom (Atom pattern) identifiers - case found of - (Bool False) -> if not isDefined -- Set variable in the local environment - then do - defineVar localEnv pattern (List []) - else do - return $ Bool True - -- Ignore identifiers since they are just passed along as-is - _ -> return $ Bool True - -initializePatternVars _ _ _ _ = - return $ Bool True - --- Find the first pattern var that reports being from a src, or False if none -lookupPatternVarSrc :: Env -> LispVal -> IOThrowsError LispVal -lookupPatternVarSrc localEnv pattern@(List _) = do - case pattern of - List (p:ps) -> do result <- lookupPatternVarSrc localEnv p - case result of - Bool False -> lookupPatternVarSrc localEnv $ List ps - _ -> return result - List [] -> return $ Bool False - _ -> return $ Bool False - -lookupPatternVarSrc localEnv (DottedList ps p) = do - result <- lookupPatternVarSrc localEnv $ List ps - case result of - Bool False -> lookupPatternVarSrc localEnv p - _ -> return result - --- TODO: vector - -lookupPatternVarSrc localEnv (Atom pattern) = - do isDefined <- liftIO $ isNamespacedBound localEnv "src" pattern - if isDefined then getNamespacedVar localEnv "src" pattern - else return $ Bool False - -lookupPatternVarSrc _ _ = - return $ Bool False diff --git a/hs-src/Scheme/Numerical.hs b/hs-src/Scheme/Numerical.hs deleted file mode 100644 --- a/hs-src/Scheme/Numerical.hs +++ /dev/null @@ -1,388 +0,0 @@ -{- - - husk scheme interpreter - - - - A lightweight dialect of R5RS scheme. - - Numerical tower functionality - - - - @author Justin Ethier - - - - -} - -module Scheme.Numerical where -import Scheme.Types -import Complex -import Control.Monad.Error -import Ratio -import Text.Printf - -numericBinop :: (Integer -> Integer -> Integer) -> [LispVal] -> ThrowsError LispVal -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 -foldlM f v (x:xs) = (f v x) >>= \a -> foldlM f a xs -foldlM _ v [] = return v - -foldl1M :: Monad m => (a -> a -> m a) -> [a] -> m a -foldl1M f (x:xs) = foldlM f x xs -foldl1M _ _ = error "Unexpected error in foldl1M" --- end GenUtil - - ---- Numeric operations section --- --- TODO: move all of this out into its own file - -numAdd, numSub, numMul, numDiv :: [LispVal] -> ThrowsError LispVal -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 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 - 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 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 - doDiv (List [(Float a), (Float b)]) = if b == 0.0 - then throwError $ DivideByZero - else return $ Float $ a / b - doDiv (List [(Rational a), (Rational b)]) = if b == 0 - then throwError $ DivideByZero - else return $ Rational $ a / b - 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 [] = 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 [] = 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 [] = 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 [] = 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 [] = 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] -numCast [a@(Float _), b@(Float _)] = return $ List [a, b] -numCast [a@(Rational _), b@(Rational _)] = return $ List [a, b] -numCast [a@(Complex _), b@(Complex _)] = return $ List [a, b] -numCast [(Number a), b@(Float _)] = return $ List [Float $ fromInteger a, b] -numCast [(Number a), b@(Rational _)] = return $ List [Rational $ fromInteger a, b] -numCast [(Number a), b@(Complex _)] = return $ List [Complex $ fromInteger a, b] -numCast [a@(Float _), (Number b)] = return $ List [a, Float $ fromInteger b] -numCast [a@(Float _), (Rational b)] = return $ List [a, Float $ fromRational b] -numCast [(Float a), b@(Complex _)] = return $ List [Complex $ a :+ 0, b] -numCast [a@(Rational _), (Number b)] = return $ List [a, Rational $ fromInteger b] -numCast [(Rational a), b@(Float _)] = return $ List [Float $ fromRational a, b] -numCast [(Rational a), b@(Complex _)] = return $ List [Complex $ (fromInteger $ numerator a) / (fromInteger $ denominator a), b] -numCast [a@(Complex _), (Number b)] = return $ List [a, Complex $ fromInteger b] -numCast [a@(Complex _), (Float b)] = return $ List [a, Complex $ b :+ 0] -numCast [a@(Complex _), (Rational b)] = return $ List [a, Complex $ (fromInteger $ numerator b) / (fromInteger $ denominator b)] -numCast [a, b] = case a of - Number _ -> doThrowError b - Float _ -> doThrowError b - Rational _ -> doThrowError b - Complex _ -> doThrowError b - _ -> 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 -numRound [(Rational n)] = return $ Number $ round n -numRound [(Float n)] = return $ Float $ fromInteger $ round n --- TODO: complex (?) -numRound [x] = throwError $ TypeMismatch "number" x -numRound badArgList = throwError $ NumArgs 1 badArgList - --- TODO: -numFloor [n@(Number _)] = return n -numFloor [(Rational n)] = return $ Number $ floor n -numFloor [(Float n)] = return $ Float $ fromInteger $ floor n --- TODO: complex (?) -numFloor [x] = throwError $ TypeMismatch "number" x -numFloor badArgList = throwError $ NumArgs 1 badArgList - -numCeiling [n@(Number _)] = return n -numCeiling [(Rational n)] = return $ Number $ ceiling n -numCeiling [(Float n)] = return $ Float $ fromInteger $ ceiling n --- TODO: complex (?) -numCeiling [x] = throwError $ TypeMismatch "number" x -numCeiling badArgList = throwError $ NumArgs 1 badArgList - -numTruncate [n@(Number _)] = return n -numTruncate [(Rational n)] = return $ Number $ truncate n -numTruncate [(Float n)] = return $ Float $ fromInteger $ truncate n --- TODO: complex (?) -numTruncate [x] = throwError $ TypeMismatch "number" x -numTruncate badArgList = throwError $ NumArgs 1 badArgList - - -numSin :: [LispVal] -> ThrowsError LispVal -numSin [(Number n)] = return $ Float $ sin $ fromInteger n -numSin [(Float n)] = return $ Float $ sin n -numSin [(Rational n)] = return $ Float $ sin $ fromRational n -numSin [(Complex n)] = return $ Complex $ sin n -numSin [x] = throwError $ TypeMismatch "number" x -numSin badArgList = throwError $ NumArgs 1 badArgList - -numCos :: [LispVal] -> ThrowsError LispVal -numCos [(Number n)] = return $ Float $ cos $ fromInteger n -numCos [(Float n)] = return $ Float $ cos n -numCos [(Rational n)] = return $ Float $ cos $ fromRational n -numCos [(Complex n)] = return $ Complex $ cos n -numCos [x] = throwError $ TypeMismatch "number" x -numCos badArgList = throwError $ NumArgs 1 badArgList - -numTan :: [LispVal] -> ThrowsError LispVal -numTan [(Number n)] = return $ Float $ tan $ fromInteger n -numTan [(Float n)] = return $ Float $ tan n -numTan [(Rational n)] = return $ Float $ tan $ fromRational n -numTan [(Complex n)] = return $ Complex $ tan n -numTan [x] = throwError $ TypeMismatch "number" x -numTan badArgList = throwError $ NumArgs 1 badArgList - -numAsin :: [LispVal] -> ThrowsError LispVal -numAsin [(Number n)] = return $ Float $ asin $ fromInteger n -numAsin [(Float n)] = return $ Float $ asin n -numAsin [(Rational n)] = return $ Float $ asin $ fromRational n -numAsin [(Complex n)] = return $ Complex $ asin n -numAsin [x] = throwError $ TypeMismatch "number" x -numAsin badArgList = throwError $ NumArgs 1 badArgList - -numAcos :: [LispVal] -> ThrowsError LispVal -numAcos [(Number n)] = return $ Float $ acos $ fromInteger n -numAcos [(Float n)] = return $ Float $ acos n -numAcos [(Rational n)] = return $ Float $ acos $ fromRational n -numAcos [(Complex n)] = return $ Complex $ acos n -numAcos [x] = throwError $ TypeMismatch "number" x -numAcos badArgList = throwError $ NumArgs 1 badArgList - --- TODO: support for (atan y x) - see spec -numAtan :: [LispVal] -> ThrowsError LispVal -numAtan [(Number n)] = return $ Float $ atan $ fromInteger n -numAtan [(Float n)] = return $ Float $ atan n -numAtan [(Rational n)] = return $ Float $ atan $ fromRational n -numAtan [(Complex n)] = return $ Complex $ atan n -numAtan [x] = throwError $ TypeMismatch "number" x -numAtan badArgList = throwError $ NumArgs 1 badArgList - -numSqrt, numExpt :: [LispVal] -> ThrowsError LispVal -numSqrt [(Number n)] = if n >= 0 then return $ Float $ sqrt $ fromInteger n - else return $ Complex $ sqrt ((fromInteger n) :+ 0) -numSqrt [(Float n)] = if n >= 0 then return $ Float $ sqrt n - else return $ Complex $ sqrt (n :+ 0) -numSqrt [(Rational n)] = numSqrt [Float $ fromRational n] -numSqrt [(Complex n)] = return $ Complex $ sqrt n -numSqrt [x] = throwError $ TypeMismatch "number" x -numSqrt badArgList = throwError $ NumArgs 1 badArgList - -numExpt [(Number n), (Number p)] = return $ Float $ (fromInteger n) ^ p -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 [_, y] = throwError $ TypeMismatch "integer" y -numExpt badArgList = throwError $ NumArgs 2 badArgList - -{-numExpt params = do - foldl1M (\a b -> doExpt =<< (numCast [a, b])) params - where doExpt (List [(Number a), (Number b)]) = return $ Float $ (fromInteger a) ^ (fromInteger b) --- doExpt (List [(Rational a), (Rational b)]) = return $ Float $ fromRational $ a ^ b - doExpt (List [(Float a), (Float b)]) = return $ Float $ a ^ b --- doExpt (List [(Complex a), (Complex b)]) = return $ Complex $ a ^ b-} - -numExp :: [LispVal] -> ThrowsError LispVal -numExp [(Number n)] = return $ Float $ exp $ fromInteger n -numExp [(Float n)] = return $ Float $ exp n -numExp [(Rational n)] = return $ Float $ exp $ fromRational n -numExp [(Complex n)] = return $ Complex $ exp n -numExp [x] = throwError $ TypeMismatch "number" x -numExp badArgList = throwError $ NumArgs 1 badArgList - -numLog :: [LispVal] -> ThrowsError LispVal -numLog [(Number n)] = return $ Float $ log $ fromInteger n -numLog [(Float n)] = return $ Float $ log n -numLog [(Rational n)] = return $ Float $ log $ fromRational n -numLog [(Complex n)] = return $ Complex $ log n -numLog [x] = throwError $ TypeMismatch "number" x -numLog badArgList = throwError $ NumArgs 1 badArgList - - --- Complex number functions -numMakeRectangular, numMakePolar, numRealPart, numImagPart, numMagnitude, numAngle :: [LispVal] -> ThrowsError LispVal -numMakeRectangular [(Float x), (Float y)] = return $ Complex $ x :+ y --- TODO: other members of the numeric tower (?) -numMakeRectangular [x, y] = throwError $ TypeMismatch "real real" $ List [x, y] -numMakeRectangular badArgList = throwError $ NumArgs 2 badArgList - -numMakePolar [(Float x), (Float y)] = return $ Complex $ mkPolar x y --- TODO: other members of the numeric tower (?) -numMakePolar [x, y] = throwError $ TypeMismatch "real real" $ List [x, y] -numMakePolar badArgList = throwError $ NumArgs 2 badArgList - -numAngle [(Complex c)] = return $ Float $ phase c -- TODO: correct?? need to check this -numAngle [x] = throwError $ TypeMismatch "number" x -numAngle badArgList = throwError $ NumArgs 1 badArgList - -numMagnitude [(Complex c)] = return $ Float $ magnitude c -numMagnitude [x] = throwError $ TypeMismatch "number" x -numMagnitude badArgList = throwError $ NumArgs 1 badArgList - -numRealPart [(Complex c)] = return $ Float $ realPart c -numRealPart [x] = throwError $ TypeMismatch "number" x -numRealPart badArgList = throwError $ NumArgs 1 badArgList - -numImagPart [(Complex c)] = return $ Float $ imagPart c -numImagPart [x] = throwError $ TypeMismatch "number" x -numImagPart badArgList = throwError $ NumArgs 1 badArgList - - -numNumerator, numDenominator:: [LispVal] -> ThrowsError LispVal -numNumerator [(Rational r)] = return $ Number $ numerator r --- TODO: real? -numNumerator [x] = throwError $ TypeMismatch "rational number" x -numNumerator badArgList = throwError $ NumArgs 1 badArgList - -numDenominator [(Rational r)] = return $ Number $ denominator r --- TODO: real? -numDenominator [x] = throwError $ TypeMismatch "rational number" x -numDenominator badArgList = throwError $ NumArgs 1 badArgList - -numExact2Inexact, numInexact2Exact :: [LispVal] -> ThrowsError LispVal -numExact2Inexact [(Number n)] = return $ Float $ fromInteger n -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) --- procedure: (number->string z radix) -num2String :: [LispVal] -> ThrowsError LispVal -num2String [(Number n)] = return $ String $ show n -num2String [(Number n), (Number radix)] = do - case radix of --- TODO: boolean 2 -> return $ String $ printf "%x" n - 8 -> return $ String $ printf "%o" n - 10 -> return $ String $ printf "%d" n - 16 -> return $ String $ printf "%x" n - _ -> 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 -num2String [x] = throwError $ TypeMismatch "number" x -num2String badArgList = throwError $ NumArgs 1 badArgList - --- TODO: relocated string->number logic here (???), --- and extend to support all of the tower... - -isNumber, isComplex, isReal, isRational, isInteger :: [LispVal] -> ThrowsError LispVal -isNumber ([Number _]) = return $ Bool True -isNumber ([Float _]) = return $ Bool True -isNumber ([Complex _]) = return $ Bool True -isNumber ([Rational _]) = return $ Bool True -isNumber _ = return $ Bool False - -isComplex ([Complex _]) = return $ Bool True -isComplex ([Number _]) = return $ Bool True -isComplex ([Rational _]) = return $ Bool True -isComplex ([Float _]) = return $ Bool True -isComplex _ = return $ Bool False - -isReal ([Number _]) = return $ Bool True -isReal ([Rational _]) = return $ Bool True -isReal ([Float _]) = return $ Bool True -isReal ([Complex c]) = return $ Bool $ (imagPart c) == 0 -isReal _ = return $ Bool False - -isRational ([Number _]) = return $ Bool True -isRational ([Rational _]) = return $ Bool True --- TODO: true of float if it can be represented exactly??? -isRational _ = return $ Bool False - -isInteger ([Number _]) = return $ Bool True --- TODO: true of real/rational types if they round to an integer -isInteger _ = return $ Bool False - ---- end Numeric operations section --- - - -unpackNum :: LispVal -> ThrowsError Integer -unpackNum (Number n) = return n -unpackNum notNum = throwError $ TypeMismatch "number" notNum diff --git a/hs-src/Scheme/Parser.hs b/hs-src/Scheme/Parser.hs deleted file mode 100644 --- a/hs-src/Scheme/Parser.hs +++ /dev/null @@ -1,251 +0,0 @@ -{- - - husk scheme - - Parser - - - - This file contains the code for parsing scheme - - - - @author Justin Ethier - - - - -} -module Scheme.Parser where -import Scheme.Types -import Control.Monad.Error -import Char -import Complex -import Data.Array -import Numeric -import Ratio -import Text.ParserCombinators.Parsec hiding (spaces) - -symbol :: Parser Char -symbol = oneOf "!$%&|*+-/:<=>?@^_~" -- TODO: I removed #, make sure this is OK w/spec, and test cases - -spaces :: Parser () -spaces = skipMany1 space - -parseAtom :: Parser LispVal -parseAtom = do - first <- letter <|> symbol <|> (oneOf ".") - rest <- many (letter <|> digit <|> symbol <|> (oneOf ".")) - let atom = first:rest - if atom == "." - then pzero -- Do not match this form - else return $ Atom atom - -parseBool :: Parser LispVal -parseBool = do string "#" - x <- oneOf "tf" - 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 pchr = c:r - return $ case pchr of - "space" -> Char ' ' - "newline" -> Char '\n' - _ -> Char c {- TODO: err if invalid char -} - -parseOctalNumber :: Parser LispVal -parseOctalNumber = do - try (string "#o") - sign <- many (oneOf "-") - num <- many1(oneOf "01234567") - case (length sign) of - 0 -> return $ Number $ fst $ Numeric.readOct num !! 0 - 1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ Numeric.readOct num !! 0 - _ -> pzero - -parseBinaryNumber :: Parser LispVal -parseBinaryNumber = do - try (string "#b") - sign <- many (oneOf "-") - num <- many1(oneOf "01") - case (length sign) of - 0 -> return $ Number $ 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 -parseHexNumber = do - try (string "#x") - sign <- many (oneOf "-") - num <- many1(digit <|> oneOf "abcdefABCDEF") - case (length sign) of - 0 -> return $ Number $ fst $ Numeric.readHex num !! 0 - 1 -> return $ Number $ fromInteger $ (*) (-1) $ fst $ Numeric.readHex num !! 0 - _ -> pzero - --- |Parser for Integer, base 10 -parseDecimalNumber :: Parser LispVal -parseDecimalNumber = do - try (many(string "#d")) - sign <- many (oneOf "-") - num <- many1 (digit) - if (length sign) > 1 - then pzero - else return $ (Number . read) $ sign ++ num - -parseNumber :: Parser LispVal -parseNumber = parseDecimalNumber <|> - parseHexNumber <|> - parseBinaryNumber <|> - parseOctalNumber - "Unable to parse number" - -{- Parser for floating points - - - - TODO: parse numbers in format #e1e10 - - TODO: bug - - - huski> (string->number "3.42323+2i") - - 3.42323 - - -} -parseRealNumber :: Parser LispVal -parseRealNumber = do - sign <- many (oneOf "-") - num <- many1(digit) - char '.' - frac <- many1(digit) - let dec = num ++ "." ++ frac - case (length sign) of - 0 -> return $ Float $ fst $ Numeric.readFloat dec !! 0 - 1 -> return $ Float $ (*) (-1.0) $ fst $ Numeric.readFloat dec !! 0 - _ -> pzero - -parseRationalNumber :: Parser LispVal -parseRationalNumber = do - pnumerator <- parseDecimalNumber - case pnumerator of - Number n -> do - char '/' - sign <- many (oneOf "-") - num <- many1 (digit) - if (length sign) > 1 - then pzero - else return $ Rational $ n % (read $ sign ++ num) - _ -> pzero - -parseComplexNumber :: Parser LispVal -parseComplexNumber = do - lispreal <- (try(parseRealNumber) <|> parseDecimalNumber) - 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 - return $ case c of - 'n' -> '\n' - 't' -> '\t' - 'r' -> '\r' - _ -> c - -parseString :: Parser LispVal -parseString = do - char '"' - x <- many (parseEscapedChar <|> noneOf("\"")) - char '"' - return $ String x - -parseVector :: Parser LispVal -parseVector = do - vals <- sepBy parseExpr spaces - return $ Vector (listArray (0, (length vals - 1)) vals) --- TODO: old code from Data.Vector implementation: return $ Vector $ Data.Vector.fromList vals - -parseList :: Parser LispVal -parseList = liftM List $ sepBy parseExpr spaces - -parseDottedList :: Parser LispVal -parseDottedList = do - phead <- endBy parseExpr spaces - ptail <- char '.' >> spaces >> parseExpr - return $ DottedList phead ptail - -parseQuoted :: Parser LispVal -parseQuoted = do - char '\'' - x <- parseExpr - return $ List [Atom "quote", x] - -parseQuasiQuoted :: Parser LispVal -parseQuasiQuoted = do - char '`' - x <- parseExpr - return $ List [Atom "quasiquote", x] - -parseUnquoted :: Parser LispVal -parseUnquoted = do - try (char ',') - x <- parseExpr - return $ List [Atom "unquote", x] - -parseUnquoteSpliced :: Parser LispVal -parseUnquoteSpliced = do - try (string ",@") - x <- parseExpr - return $ List [Atom "unquote-splicing", x] - - --- Comment parser --- TODO: this is a hack, it should really not return anything... -parseComment :: Parser LispVal -parseComment = do - char ';' - many (noneOf ("\n")) - return $ Nil "" - - -parseExpr :: Parser LispVal -parseExpr = - try(parseRationalNumber) - <|> try(parseComplexNumber) - <|> parseComment - <|> try(parseRealNumber) - <|> try(parseNumber) - <|> parseChar - <|> parseUnquoteSpliced - <|> do try (string "#(") - x <- parseVector - char ')' - return x - <|> try (parseAtom) - <|> parseString - <|> parseBool - <|> parseQuoted - <|> parseQuasiQuoted - <|> parseUnquoted - <|> do char '(' - x <- try parseList <|> parseDottedList - char ')' - return x - "Expression" - -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 - -readExprList :: String -> ThrowsError [LispVal] -readExprList = readOrThrow (endBy parseExpr spaces) - diff --git a/hs-src/Scheme/Types.hs b/hs-src/Scheme/Types.hs deleted file mode 100644 --- a/hs-src/Scheme/Types.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-- - - husk scheme - - Types - - - - This file contains top-level data type definitions and their associated functions, including: - - - Scheme data types - - - Scheme errors - - - - @author Justin Ethier - - - - -} -module Scheme.Types where -import Complex -import Control.Monad.Error -import Data.Array -import Data.IORef -import qualified Data.Map -import IO hiding (try) -import Ratio -import Text.ParserCombinators.Parsec hiding (spaces) - -{- Environment management -} - --- |A Scheme environment containing variable bindings of form @(namespaceName, variableName), variableValue@ -data Env = Environment {parentEnv :: (Maybe Env), bindings :: (IORef [((String, String), IORef LispVal)])} -- lookup via: (namespace, variable) - --- |An empty environment -nullEnv :: IO Env -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 -data LispError = NumArgs Integer [LispVal] -- ^Invalid number of function arguments - | TypeMismatch String LispVal -- ^Type error - | Parser ParseError -- ^Parsing error - | BadSpecialForm String LispVal -- ^Invalid special (built-in) form - | NotFunction String String - | UnboundVar String String - | DivideByZero -- ^Divide by Zero error - | NotImplemented String - | InternalError String -- ^An internal error within husk; in theory user (Scheme) code - -- should never allow one of these errors to be triggered. - | Default String -- ^Default error - --- |Create a textual description for a 'LispError' -showError :: LispError -> String -showError (NumArgs expected found) = "Expected " ++ show expected - ++ " args; found values " ++ unwordsList found -showError (TypeMismatch expected found) = "Invalid type: expected " ++ expected - ++ ", found " ++ show found -showError (Parser parseErr) = "Parse error at " ++ ": " ++ show parseErr -showError (BadSpecialForm message form) = message ++ ": " ++ show form -showError (NotFunction message func) = message ++ ": " ++ show func -showError (UnboundVar message varname) = message ++ ": " ++ varname -showError (DivideByZero) = "Division by zero" -showError (NotImplemented message) = "Not implemented: " ++ message -showError (InternalError message) = "An internal error occurred: " ++ message -showError (Default message) = "Error: " ++ message - -instance Show LispError where show = showError -instance Error LispError where - noMsg = Default "An error has occurred" - strMsg = Default - -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 - -liftThrows :: ThrowsError a -> IOThrowsError a -liftThrows (Left err) = throwError err -liftThrows (Right val) = return val - -runIOThrows :: IOThrowsError String -> IO String -runIOThrows action = runErrorT (trapError action) >>= return . extractValue - --- |Scheme data types -data LispVal = Atom String - -- ^Symbol - | List [LispVal] - -- ^List - | DottedList [LispVal] LispVal - -- ^Pair - | Vector (Array Int LispVal) - -- ^Vector - | HashTable (Data.Map.Map LispVal LispVal) - -- ^Hash table. - -- Technically this could be a derived data type instead of being built-in to the - -- interpreter. And perhaps in the future it will be. But for now, a hash table - -- is too important of a data type to not be included. - -- - -- Map is technically the wrong structure to use for a hash table since it is based on a binary tree and hence operations tend to be O(log n) instead of O(1). However, according to Map has good performance characteristics compared to the alternatives. So it stays for the moment... - -- - | Number Integer -- FUTURE: rename this to "Integer" (or something else more meaningful) - -- ^Integer - | Float Double -- FUTURE: rename this "Real" instead of "Float"... - -- ^Floating point - | Complex (Complex Double) - -- ^Complex number - | Rational Rational - -- ^Rational number - | String String - -- ^String - | Char Char - -- ^Character - | Bool Bool - -- ^Boolean - | PrimitiveFunc ([LispVal] -> ThrowsError LispVal) - -- ^ - | Func {params :: [String], - vararg :: (Maybe String), - body :: [LispVal], - closure :: Env - } - -- ^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 - , contFunctionArgs :: (Maybe [LispVal]) -- Arguments to a higher-order function - , continuationFunction :: (Maybe (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)) - -- FUTURE: stack (for dynamic wind) - } - -- ^Continuation - | Nil String - -- ^Internal use only; do not use this type directly. - --- Make an "empty" continuation that does not contain any code -makeNullContinuation :: Env -> LispVal -makeNullContinuation env = Continuation env [] (Nil "") Nothing Nothing - --- Make a continuation that takes a higher-order function (written in Haskell) -makeCPS :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal]-> IOThrowsError LispVal) -> LispVal -makeCPS env cont cps = Continuation env [] cont Nothing (Just cps) - --- Make a continuation that stores a higher-order function and arguments to that function -makeCPSWArgs :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) -> [LispVal] -> LispVal -makeCPSWArgs env cont cps args = Continuation env [] cont (Just args) (Just cps) - -instance Ord LispVal where - compare (Bool a) (Bool b) = compare a b - compare (Number a) (Number b) = compare a b - compare (Rational a) (Rational b) = compare a b - compare (Float a) (Float b) = compare a b - compare (String a) (String b) = compare a b - compare (Char a) (Char b) = compare a b - compare (Atom a) (Atom b) = compare a b --- compare (DottedList xs x) (DottedList xs x) = compare a b --- Vector --- HashTable --- List --- Func --- Others? - compare a b = compare (show a) (show b) -- Hack (??): sort alphabetically when types differ or have no handlers - --- |Compare two 'LispVal' instances -eqv :: [LispVal] -> ThrowsError LispVal -eqv [(Bool arg1), (Bool arg2)] = return $ Bool $ arg1 == arg2 -eqv [(Number arg1), (Number arg2)] = return $ Bool $ arg1 == arg2 -eqv [(Complex arg1), (Complex arg2)] = return $ Bool $ arg1 == arg2 -eqv [(Rational arg1), (Rational arg2)] = return $ Bool $ arg1 == arg2 -eqv [(Float arg1), (Float arg2)] = return $ Bool $ arg1 == arg2 -eqv [(String arg1), (String arg2)] = return $ Bool $ arg1 == arg2 -eqv [(Char arg1), (Char arg2)] = return $ Bool $ arg1 == arg2 -eqv [(Atom arg1), (Atom arg2)] = return $ Bool $ arg1 == arg2 -eqv [(DottedList xs x), (DottedList ys y)] = eqv [List $ xs ++ [x], List $ ys ++ [y]] -eqv [(Vector arg1), (Vector arg2)] = eqv [List $ (elems arg1), List $ (elems arg2)] -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 _), l2@(List _)] = eqvList eqv [l1, l2] -eqv [_, _] = return $ Bool False -eqv badArgList = throwError $ NumArgs 2 badArgList - -eqvList :: ([LispVal] -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal -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 _ -> 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 _ -> False - Right (Bool val) -> val - _ -> False -- Is this OK? - -instance Eq LispVal where - x == y = eqVal x y - --- |Create a textual description of a 'LispVal' -showVal :: LispVal -> String -showVal (Nil _) = "" -showVal (String contents) = "\"" ++ contents ++ "\"" -showVal (Char chr) = [chr] -showVal (Atom name) = name -showVal (Number contents) = show contents -showVal (Complex contents) = (show $ realPart contents) ++ "+" ++ (show $ imagPart contents) ++ "i" -showVal (Rational contents) = (show (numerator contents)) ++ "/" ++ (show (denominator contents)) -showVal (Float contents) = show contents -showVal (Bool True) = "#t" -showVal (Bool False) = "#f" -showVal (Vector contents) = "#(" ++ (unwordsList $ Data.Array.elems contents) ++ ")" -showVal (HashTable _) = "" -showVal (List contents) = "(" ++ unwordsList contents ++ ")" -showVal (DottedList h t) = "(" ++ unwordsList h ++ " . " ++ showVal t ++ ")" -showVal (PrimitiveFunc _) = "" -showVal (Continuation {closure = _, body = _}) = "" -showVal (Func {params = args, vararg = varargs, body = _, closure = _}) = - "(lambda (" ++ unwords (map show args) ++ - (case varargs of - Nothing -> "" - Just arg -> " . " ++ arg) ++ ") ...)" -showVal (Port _) = "" -showVal (IOFunc _) = "" - -unwordsList :: [LispVal] -> String -unwordsList = unwords . map showVal - --- |Allow conversion of lispval instances to strings -instance Show LispVal where show = showVal diff --git a/hs-src/Scheme/Variables.hs b/hs-src/Scheme/Variables.hs deleted file mode 100644 --- a/hs-src/Scheme/Variables.hs +++ /dev/null @@ -1,91 +0,0 @@ -{- - - husk scheme - - Variables - - - - This file contains code for working with Scheme variables - - - - @author Justin Ethier - - - - -} -module Scheme.Variables where -import Scheme.Types -import Control.Monad.Error -import Data.IORef - --- |Extend given environment by binding a series of values to a new environment. -extendEnv :: Env -> [((String, String), LispVal)] -> IO Env -extendEnv envRef bindings = do bindinglist <- mapM (\((namespace, name), val) -> - do ref <- newIORef val - return ((namespace, name), ref)) bindings - >>= newIORef - return $ Environment (Just envRef) bindinglist - -{- --- Old implementation, left for the moment for reference purposes only: --- --- |Bind a series of values to the given environment. --- --- Input is of form: @(namespaceName, variableName), variableValue@ -bindVars :: Env -> [((String, String), LispVal)] -> IO Env -bindVars envRef abindings = (readIORef $ bindings envRef) >>= myExtendEnv abindings >>= newIORef - where myExtendEnv bindings env = liftM (++ env) (mapM addBinding bindings) - addBinding (var, value) = do ref <- newIORef value - return (var, ref) --} - --- |Determine if a variable is bound in the default namespace -isBound :: Env -> String -> IO Bool -isBound envRef var = isNamespacedBound envRef varNamespace var - --- |Determine if a variable is bound in a given namespace -isNamespacedBound :: Env -> String -> String -> IO Bool -isNamespacedBound envRef namespace var = (readIORef $ bindings envRef) >>= return . maybe False (const True) . lookup (namespace, var) - --- |Retrieve the value of a variable defined in the default namespace -getVar :: Env -> String -> IOThrowsError LispVal -getVar envRef var = getNamespacedVar envRef varNamespace var - --- |Retrieve the value of a variable defined in a given namespace -getNamespacedVar :: Env -> String -> String -> IOThrowsError LispVal -getNamespacedVar envRef - namespace - var = do binds <- liftIO $ readIORef $ bindings envRef - case lookup (namespace, var) binds of - (Just a) -> liftIO $ readIORef a - Nothing -> case parentEnv envRef of - (Just par) -> getNamespacedVar par namespace var - Nothing -> (throwError $ UnboundVar "Getting an unbound variable" var) - --- |Set a variable in the default namespace -setVar, defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal -setVar envRef var value = setNamespacedVar envRef varNamespace var value - --- ^Bind a variable in the default namespace -defineVar envRef var value = defineNamespacedVar envRef varNamespace var value - --- |Set a variable in a given namespace -setNamespacedVar :: Env -> String -> String -> LispVal -> IOThrowsError LispVal -setNamespacedVar envRef - namespace - var value = do env <- liftIO $ readIORef $ bindings envRef - case lookup (namespace, var) env of - (Just a) -> do --vprime <- liftIO $ readIORef a - liftIO $ writeIORef a value - return value - Nothing -> case parentEnv envRef of - (Just par) -> setNamespacedVar par namespace var value - Nothing -> throwError $ UnboundVar "Setting an unbound variable: " var - --- |Bind a variable in the given namespace -defineNamespacedVar :: Env -> String -> String -> LispVal -> IOThrowsError LispVal -defineNamespacedVar envRef - namespace - var value = do - alreadyDefined <- liftIO $ isNamespacedBound envRef namespace var - if alreadyDefined - then setNamespacedVar envRef namespace var value >> return value - else liftIO $ do - valueRef <- newIORef value - env <- readIORef $ bindings envRef - writeIORef (bindings envRef) (((namespace, var), valueRef) : env) - return value diff --git a/hs-src/shell.hs b/hs-src/shell.hs --- a/hs-src/shell.hs +++ b/hs-src/shell.hs @@ -12,9 +12,9 @@ module Main where import Paths_husk_scheme -import Scheme.Core -- Scheme Interpreter -import Scheme.Types -- Scheme data types -import Scheme.Variables -- Scheme variable operations +import Language.Scheme.Core -- Scheme Interpreter +import Language.Scheme.Types -- Scheme data types +import Language.Scheme.Variables -- Scheme variable operations import Control.Monad.Error import IO hiding (try) import System.Environment @@ -33,16 +33,15 @@ runOne :: [String] -> IO () runOne args = do env <- primitiveBindings >>= flip extendEnv [((varNamespace, "args"), List $ map String $ drop 1 args)] - (runIOThrows $ liftM show $ eval env (makeNullContinuation env) (List [Atom "load", String (args !! 0)])) -- TODO: replace with evalLisp + (runIOThrows $ liftM show $ evalLisp env (List [Atom "load", String (args !! 0)])) >>= 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 - -- 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 + then (runIOThrows $ liftM show $ evalLisp env (List [Atom "main", List [Atom "quote", argv]])) >>= hPutStrLn stderr + else (runIOThrows $ liftM show $ evalLisp env (Nil "")) >>= hPutStrLn stderr showBanner :: IO () showBanner = do @@ -53,7 +52,7 @@ putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ " putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| " putStrLn " " - putStrLn " husk Scheme Interpreter Version 2.0 " + putStrLn " husk Scheme Interpreter Version 2.1 " putStrLn " (c) 2010 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: 2.0 +Version: 2.1 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. Advanced R5RS features are @@ -32,24 +32,24 @@ Data-Files: stdlib.scm Library - Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec + Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory Extensions: ExistentialQuantification Hs-Source-Dirs: hs-src - Exposed-Modules: Scheme.Core - Scheme.Types - Scheme.Variables - Other-Modules: Scheme.Macro - Scheme.Numerical - Scheme.Parser + Exposed-Modules: Language.Scheme.Core + Language.Scheme.Types + Language.Scheme.Variables + Other-Modules: Language.Scheme.Macro + Language.Scheme.Numerical + Language.Scheme.Parser Executable huski - Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec + Build-Depends: base >= 2.0 && < 5, array, containers, haskeline, haskell98, mtl, parsec, directory Extensions: ExistentialQuantification Main-is: shell.hs Hs-Source-Dirs: hs-src - Other-Modules: Scheme.Core - Scheme.Types - Scheme.Variables - Scheme.Macro - Scheme.Numerical - Scheme.Parser + Other-Modules: Language.Scheme.Core + Language.Scheme.Types + Language.Scheme.Variables + Language.Scheme.Macro + Language.Scheme.Numerical + Language.Scheme.Parser diff --git a/stdlib.scm b/stdlib.scm --- a/stdlib.scm +++ b/stdlib.scm @@ -100,7 +100,7 @@ (define (assv obj alist) (fold (mem-helper (curry eqv? obj) car) #f alist)) (define (assoc obj alist) (fold (mem-helper (curry equal? obj) car) #f alist)) -; TODO on map and for-each - Support variable number of args, per spec: +; FUTURE: on map and for-each - Support variable number of args, per spec: ; http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_sec_6.4 ;(define (for-each func . lsts) ) @@ -129,13 +129,6 @@ (let () (define x v) ... (let () e1 e2 ...))))) -; TODO: should be able to use dotted lists, as below: -;(define-syntax letrec -; (syntax-rules () -; ((_ ((x v) ...) . body) -; (let () -; (define x v) ... -; (let () . body))))) ; let and named let (using the Y-combinator): (define-syntax let @@ -236,16 +229,39 @@ (hash-table-set! hash-table key (function (hash-table-ref hash-table key thunk)))) -;(define (hash-table-update!/default hash-table key function default) -; (hash-table-update! hash-table key function (lambda () default))) +(define-syntax hash-table-merge! + (syntax-rules () + ((_ hdest hsrc) + (map (lambda (node) (hash-table-set! hdest + (car node) + (cadr node))) + (hash-table->alist hsrc))))) -; TODO: hash-table-fold +(define (alist->hash-table lst) + (let ((ht (make-hash-table))) + (for-each (lambda (node) + (hash-table-set! ht (car node) (cadr node))) + lst) + ht)) + +; FUTURE: Issue #11: hash-table-fold +;(define (hash-table-fold hash-table f init-value) +; TBD) + ; End delayed evaluation section -; TODO: from numeric section - +; FUTURE: Issue #10: from numeric section - ; gcd -;(define (gcd . nums) nums) +;(define (gcd . nums) +; (if (eqv? nums '()) +; 0 +; TBD...)) + +; Limited form of gcd from: http://www.dreamincode.net/code/snippet1358.htm +(define (gcd a b) + (if (= b 0) a + (gcd b (modulo a b)))) ; lcm ; rationalize ;