husk-scheme 1.3 → 2.0
raw patch · 7 files changed
+501/−376 lines, 7 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Scheme.Types: frameEvaledArgs :: LispVal -> (Maybe [LispVal])
- Scheme.Types: frameFunc :: LispVal -> (Maybe LispVal)
- Scheme.Types: partialEval :: LispVal -> Bool
+ Scheme.Types: InternalError :: String -> LispError
+ Scheme.Types: contFunctionArgs :: LispVal -> (Maybe [LispVal])
+ Scheme.Types: continuationFunction :: LispVal -> (Maybe (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal))
+ Scheme.Types: makeCPS :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) -> LispVal
+ Scheme.Types: makeCPSWArgs :: Env -> LispVal -> (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal) -> [LispVal] -> LispVal
- Scheme.Types: Continuation :: Env -> [LispVal] -> LispVal -> (Maybe LispVal) -> (Maybe [LispVal]) -> LispVal
+ Scheme.Types: Continuation :: Env -> [LispVal] -> LispVal -> (Maybe [LispVal]) -> (Maybe (Env -> LispVal -> LispVal -> Maybe [LispVal] -> IOThrowsError LispVal)) -> LispVal
- Scheme.Types: Func :: [String] -> (Maybe String) -> [LispVal] -> Env -> Bool -> LispVal
+ Scheme.Types: Func :: [String] -> (Maybe String) -> [LispVal] -> Env -> LispVal
Files
- README.markdown +20/−9
- hs-src/Scheme/Core.hs +384/−306
- hs-src/Scheme/Macro.hs +26/−3
- hs-src/Scheme/Types.hs +28/−26
- hs-src/shell.hs +11/−7
- husk-scheme.cabal +12/−8
- stdlib.scm +20/−17
README.markdown view
@@ -1,28 +1,35 @@-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/). Husk is not intended to be 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 a great 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.+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.++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:+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 - Proper lexical scoping - Conditionals: if, case, cond-- Assignment operations - Sequencing: begin - Iteration: do - Quasi-quotation - Delayed Execution: delay, force - Binding constructs: let, named let, let*, letrec+- Assignment operations - Basic IO functions - Standard library of Scheme functions-- Read-Eval-Print-Loop (REPL) interpreter, with input driven by Haskeline-- Full numeric tower - includes support for parsing/storing types (exact, inexact, etc), support for operations on these types as well as mixing types, other constraints from spec.+- Read-Eval-Print-Loop (REPL) interpreter, with input driven by Haskeline to provide a rich user experience+- <b>Full numeric tower</b>: 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.+- <b>Continuations</b>: call/cc and first-class continuations.+- <b>Hygienic Macros</b>: 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.++As well as the following approved extensions:+ - Hash tables, as specified by [SRFI 69](http://srfi.schemers.org/srfi-69/srfi-69.html)-- Hygenic Macros: High-level macros via define-syntax - *Note this is still a heavy work in progress* and while it works well enough that many derived forms are implemented in our standard library, you may still run into problems when defining your own macros.-- Continuations - call/cc and first-class continuations are partially implemented, however this functionality is extremely limited and in an alpha state. See the change log (release notes) for more information. husk scheme is available under the [MIT license](http://www.opensource.org/licenses/mit-license.php). @@ -43,6 +50,9 @@ ./huski my-scheme-file.scm +API+---+ 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.@@ -61,10 +71,11 @@ cabal install haskeline -The 'scm-unit-tests' directory contains unit tests for much of the scheme code. Tests may be executed via 'make test'+The `scm-unit-tests` directory contains unit tests for much of the scheme code. All tests may be executed via `make test` command. The examples directory contains example scheme programs. +Patches are welcome; please send via pull request on github. Credits -------
hs-src/Scheme/Core.hs view
@@ -2,20 +2,12 @@ - husk scheme interpreter - - A lightweight dialect of R5RS scheme.- - Core functionality+ - This file contains Core functionality, primarily Scheme expression evaluation. - - @author Justin Ethier - - -} -{-- - TODO: - -- - => compare my functions against those listed on - - http://en.wikipedia.org/wiki/Scheme_(programming_language)- -- - -}- module Scheme.Core ( eval@@ -70,129 +62,62 @@ evalLisp env lisp = macroEval env lisp >>= (eval env (makeNullContinuation env)) -{- Changes will be required to eval to support continuations. According to original wiki book:- - TBD- -- -- - Need to rethink below and come up with a clear, top-level design approach. Some starting points- - for this are:- - http://c2.com/cgi/wiki?ContinuationImplementation- - http://c2.com/cgi/wiki?CallWithCurrentContinuation (the link to this book may be helpful as well: http://c2.com/cgi/wiki?EssentialsOfProgrammingLanguages - apparently if the interpreter is written using CPS, then call/cc is free)- - http://tech.phillipwright.com/2010/05/23/continuations-in-scheme/- - http://community.schemewiki.org/?call-with-current-continuation- -- - ALSO, consider the following quote: - - "CPS is a programming style where no function is ever allowed to return."- - So, this would mean that when evaluating a simple integer, string, etc eval should call into- - the continuation instead of just returning.- - Need to think about how this will be handled, how functions will be called using CPS, and what- - the continuation data type needs to contain.- -- -- -- -- -- - Some of my notes:- - as simple as using CPS to evaluate lists of "lines" (body)? Then could pass the next part of the CPS as the cont arg to eval. Or is this too simple to work? need to think about this - http://en.wikipedia.org/wiki/Continuation-passing_style- -- - Possible design approach:- -- - * thread cont through eval- - * instead of returning, call into next eval using CPS style, with the cont parameter.- - this replaces code in evalBody (possibly other places?) that uses local CPS to execute a function- - * parameter will consist of a lisp function- - * eval will call into another function to deal with details of manipulating the cont prior to next call- - need to work out details of exactly how that would work, but could for example just go to the next line- - of body. - - * To continue above point, where is eval'd value returned to? May want to refer to R5RS section that describes call/cc:- - A common use of call-with-current-continuation is for structured, non-local exits from loops or procedure bodies, but in fact call-with-current-continuation is extremely useful for implementing a wide variety of advanced control structures.- -- - Whenever a Scheme expression is evaluated there is a continuation wanting the result of the expression. The continuation represents an entire (default) future for the computation. If the expression is evaluated at top level, for example, then the continuation might take the result, print it on the screen, prompt for the next input, evaluate it, and so on forever. Most of the time the continuation includes actions specified by user code, as in a continuation that will take the result, multiply it by the value stored in a local variable, add seven, and give the answer to the top level continuation to be printed. Normally these ubiquitous continuations are hidden behind the scenes and programmers do not think much about them. On rare occasions, however, a programmer may need to deal with continuations explicitly. Call-with-current-continuation allows Scheme programmers to do that by creating a procedure that acts just like the current continuation.- -- - Most programming languages incorporate one or more special-purpose escape constructs with names like exit, return, or even goto. In 1965, however, Peter Landin [16] invented a general purpose escape operator called the J-operator. John Reynolds [24] described a simpler but equally powerful construct in 1972. The catch special form described by Sussman and Steele in the 1975 report on Scheme is exactly the same as Reynolds's construct, though its name came from a less general construct in MacLisp. Several Scheme implementors noticed that the full power of the catch construct could be provided by a procedure instead of by a special syntactic construct, and the name call-with-current-continuation was coined in 1982. This name is descriptive, but opinions differ on the merits of such a long name, and some people use the name call/cc instead.- -- - * need to consider what would be passed when evaluating via a REPL, at top-level, via haskell entry points, etc...+{- 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.+ - 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--- case (trace ("cBody => " ++ show cBody ++ " val => " ++ show val) cBody) of [] -> do case cCont of Continuation nEnv _ _ _ _ -> continueEval nEnv cCont val- _ -> return val- [lv] -> eval cEnv (Continuation cEnv [] cCont Nothing Nothing) lv --val--- [lv] -> eval cEnv (Continuation cEnv [] cCont) (trace ("clv => " ++ show lv) lv) --val- (lv : lvs) -> eval cEnv (Continuation cEnv lvs cCont Nothing Nothing) lv--- (lv : lvs) -> eval cEnv (Continuation cEnv (trace ("clvs => " ++ show lvs) lvs) cCont) (trace ("lv:lvs, (lv) => " ++ show lv) lv)--{- Alpha code for next version...-continueEval _ cont@(Continuation cEnv cBody cCont cFunc Nothing) _ = do- -- This section is called when we are evaluating a function call- -- First the function needs to be eval'd. Then once that is done,- -- We will drop into the section below to eval each argument.- -- Once all that is done, the function can be called.- --- -- Notes: function needs to eval'd, then args- -- need to call back into the cont later on, probably after- -- calling one of the makefunc variants? need to make sure- -- changing those calls does not break anything else- case cBody of- [] -> eval cEnv (Continuation cEnv [Nil ""] cCont (Just $ Nil "") (Just (trace ("calling function:" ++ show (fromJust cFunc)) []))) (fromJust cFunc)- other -> eval cEnv (Continuation cEnv cBody cCont (Just $ Nil "") (Just (trace ("calling function:" ++ show (fromJust cFunc)) []))) (fromJust cFunc)----- Something to think about:--- Hack: attempting to "protect" last func/arg params by placing them within--- an inner Continuation object. If this works it will (hopefully) be more of--- a 1.0 solution than a permanent one. A better approach might be using some form--- of currying to evaluate a function, however have not thought through exactly--- how that would be implemented, and whether it would require transformation--- of the Scheme AST itself...---- TODO: beginning to wonder if this approach will ever work (?)--- think about this - can we use haskell lambda functions to--- achieve the same goal?------ alternatively, maybe shelf this for now and just get this branch good enough for a release??--- TCO is the missing component--continueEval _ cont@(Continuation cEnv cBody cCont (Just cFunc) (Just cArgs)) val = do --- if length cArgs == 0 && cFunc == (Nil "")- case cFunc of- Nil _ -> do- case (trace ("cBody1: " ++ show cBody) cBody) of--- case cBody of- [] -> continueEval cEnv cCont =<< apply cCont cFunc [] -- TODO: ContinueEval is a temporary stopgap, here and in below (apply)- [Nil ""] -> continueEval cEnv cCont =<< apply cCont val [] -- TODO: ContinueEval is a temporary stopgap, here and in below (apply)- [arg] -> do -- Eval the arg, but keep in mind val contains the function- eval cEnv (Continuation cEnv [Nil ""] cCont (Just val) (Just cArgs)) arg- (arg : args) -> do -- Peel off next arg and evaluate it, saving function- eval cEnv (Continuation cEnv args cCont (Just val) (Just cArgs)) arg- o -> case (trace ("cBody2: " ++ show cBody) cBody) of- [] -> continueEval cEnv cCont =<< apply cCont cFunc (trace ("args: " ++ show (cArgs) ++ " func: " ++ show cFunc) (cArgs)) -- No more arguments, call the function- -- Nil value indicates that all args have been processed- [Nil ""] -> continueEval cEnv cCont =<< apply cCont cFunc (trace ("args (Nil): " ++ show (cArgs ++ [val]) ++ " func: " ++ show cFunc) (cArgs ++ [val])) -- No more arguments, call the function--- o -> case cBody of--- [] -> apply cCont cFunc (cArgs ++ [val]) -- No more arguments, call the function- [arg] -> do -- Evaluate the last arg- eval cEnv (Continuation cEnv [Nil ""] cCont (Just cFunc) (Just $ cArgs ++ [val])) arg- (arg : args) -> do -- Peel off next arg and evaluate it- eval cEnv (Continuation cEnv args cCont (Just cFunc) (Just $ cArgs ++ [val])) arg--}-+ _ -> 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@@ -207,130 +132,178 @@ eval env cont (Atom a) = continueEval env cont =<< getVar env a eval env cont (List [Atom "quote", val]) = continueEval env cont val --- The way it is written now, quasiquotation does not support--- being part of a continuation, so we use the null continuation--- within it for right now-eval envi cont (List [Atom "quasiquote", value]) = continueEval envi cont =<< doUnQuote envi value- where doUnQuote :: Env -> LispVal -> IOThrowsError LispVal- doUnQuote env val = do+-- 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 env (makeNullContinuation env) vval- List (x : xs) -> unquoteListM env (x:xs) >>= return . List+ List [Atom "unquote", vval] -> eval e c vval+ List (_ : _) -> doCpsUnquoteList e c val DottedList xs x -> do- rxs <- unquoteListM env xs >>= return - rx <- doUnQuote env x- case rx of- List [] -> return $ List rxs- List rxlst -> return $ List $ rxs ++ rxlst - DottedList rxlst rxlast -> return $ DottedList (rxs ++ rxlst) rxlast- _ -> return $ DottedList rxs rx+ doCpsUnquoteList e (makeCPSWArgs e c cpsUnquotePair $ [x] ) $ List xs Vector vec -> do let len = length (elems vec)- vList <- unquoteListM env $ elems vec >>= return- return $ Vector $ listArray (0, len) vList- _ -> eval env (makeNullContinuation env) (List [Atom "quote", val]) -- Behave like quote if there is nothing to "unquote"... - unquoteListM env lst = foldlM (unquoteListFld env) ([]) lst- unquoteListFld env (acc) val = do+ 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- evalue <- eval env (makeNullContinuation env) vvar- case evalue of- List v -> return $ (acc ++ v)- -- Question: In which cases should I generate a type error if evalue is not a list?- --- -- csi reports an error for this: `(1 ,@(+ 1 2) 4)- -- but allows cases such as: `,@2- -- For now we just throw an error - perhaps more strict than we need to be, but at- -- least we will not allow anything invalid to be returned.- --- -- Old code that we might build on if this changes down the road: otherwise -> return $ (acc ++ [v])- _ -> throwError $ TypeMismatch "proper list" evalue+ 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" - _ -> do result <- doUnQuote env val- return $ (acc ++ [result])+ -- 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" -eval env cont (List [Atom "if", predic, conseq, alt]) =- do result <- eval env cont predic- case result of- Bool False -> eval env cont alt- _ -> eval env cont conseq+ -- 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]) = - do result <- eval env cont predic- case result of- Bool True -> eval env cont conseq- _ -> eval env cont $ List []+ 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- let c = clauses !! 0 -- First clause- let cs = tail clauses -- other clauses- test <- case c of- List (Atom "else" : _) -> eval env cont $ Bool True- List (cond : _) -> eval env cont cond+ 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 - case test of- Bool True -> evalCond env cont c- _ -> eval env cont $ List $ (Atom "cond" : cs)--eval env cont (List (Atom "case" : keyAndClauses)) = - do let key = keyAndClauses !! 0- let cls = tail keyAndClauses- ekey <- eval env cont key- evalCase env cont $ List $ (ekey : cls)+ 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 do- let fs = tail funcs- eval env cont (head funcs)- eval env cont (List (Atom "begin" : fs))+ 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 cont form >>= setVar env var- result <- eval env (makeNullContinuation env) form >>= setVar env var- continueEval env cont result+ 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 cont form >>= defineVar env var- result <- eval env (makeNullContinuation env) form >>= defineVar env var- continueEval env cont result+ 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 - str <- eval env (makeNullContinuation env) =<< getVar env var - echr <- eval env (makeNullContinuation env) character- result <- ((eval env (makeNullContinuation env) =<< fillStr(str, echr))) >>= setVar env var- continueEval env cont result- where fillStr (String str, Char achr) = doFillStr (String "", Char achr, length str)+ 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@@ -338,37 +311,73 @@ doFillStr (String _, c, _) = throwError $ TypeMismatch "character" c doFillStr (s, Char _, _) = throwError $ TypeMismatch "string" s doFillStr (_, _, _) = throwError $ BadSpecialForm "Unexpected error in string-fill!" $ List []++ eval env cont (List [Atom "string-set!", Atom var, i, character]) = do - idx <- eval env (makeNullContinuation env) i- str <- eval env (makeNullContinuation env) =<< getVar env var- result <- ((eval env (makeNullContinuation env) =<< substr(str, character, idx))) >>= setVar env var- continueEval env cont result- where substr (String str, Char char, Number ii) = do+ 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-{- TODO: - - also need to add unit tests for this...-} substr (String _, Char _, n) = throwError $ TypeMismatch "number" n substr (String _, c, _) = throwError $ TypeMismatch "character" c substr (s, _, _) = throwError $ TypeMismatch "string" s +eval env 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 - idx <- eval env (makeNullContinuation env) i- obj <- eval env (makeNullContinuation env) object- vec <- eval env (makeNullContinuation env) =<< getVar env var- result <- ((eval env (makeNullContinuation env) =<< (updateVector vec idx obj))) >>= setVar env var- continueEval env cont result- where updateVector :: LispVal -> LispVal -> LispVal -> IOThrowsError LispVal+ 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 - obj <- eval env (makeNullContinuation env) object- vec <- eval env (makeNullContinuation env) =<< getVar env var- result <- ((eval env (makeNullContinuation env) =<< (fillVector vec obj))) >>= setVar env var- continueEval env cont result- where fillVector :: LispVal -> LispVal -> IOThrowsError LispVal+ 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@@ -376,113 +385,122 @@ lenVector v = length (elems v) eval env cont (List [Atom "hash-table-set!", Atom var, rkey, rvalue]) = do - key <- eval env (makeNullContinuation env) rkey- value <- eval env (makeNullContinuation env) rvalue- h <- eval env (makeNullContinuation env) =<< getVar env var- case h of- HashTable ht -> do- result <- (eval env (makeNullContinuation env) $ HashTable $ Data.Map.insert key value ht) >>= setVar env var- continueEval env cont result- other -> throwError $ TypeMismatch "hash-table" other+ eval env (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 - key <- eval env (makeNullContinuation env) rkey- h <- eval env (makeNullContinuation env) =<< getVar env var- case h of- HashTable ht -> do- result <- (eval env (makeNullContinuation env) $ HashTable $ Data.Map.delete key ht) >>= setVar env var- continueEval env cont result- other -> throwError $ TypeMismatch "hash-table" other+ 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! --- TODO: for CPS form, need to be able to pass a continuation to a function--- need to work through this implementation.------ See http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_sec_6.6--- for test cases that are required to ensure apply is not broken by this change. Need--- it intact prior to proceeding with CPS and functions eval _ _ (List [Atom "apply"]) = throwError $ BadSpecialForm "apply" $ String "Function not specified" eval _ _ (List [Atom "apply", _]) = throwError $ BadSpecialForm "apply" $ String "Arguments not specified"-eval env cont (List (Atom "apply" : args)) = do- -- FUTURE: verify length of list?- -- TODO: for all Continuations below, will almost certainly need to pull each into this continuation- proc <- eval env (makeNullContinuation env) $ head $ args- lst <- eval env (makeNullContinuation env) $ head $ reverse args- argVals <- mapM (eval env (makeNullContinuation env)) $ tail $ reverse $ tail (reverse args)- case lst of- List l -> apply cont proc (argVals ++ l)- other -> throwError $ TypeMismatch "list" other+eval env cont (List (Atom "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 + func <- eval env (makeNullContinuation env) proc -- TODO: Use CPS here instead???? case func of- PrimitiveFunc f -> liftThrows $ f [cont]- Func aparams _ _ _ _ ->+ 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 -eval env cont (List (function : args)) = do--- Alpha code for next version: continueEval env (Continuation env (args) cont (Just function) Nothing) $ Nil "" --- { - TODO: obsolete code, delete once above is working- func <- eval env (makeNullContinuation env) function -- TODO: almost certainly need to pull this into the continuation- argVals <- mapM (eval env (makeNullContinuation env)) args -- TODO: almost certainly need to pull this into the continuation- apply cont func argVals--- } + cpsEvalArgs _ _ _ (Just _) = throwError $ Default "Unexpected error in function application (1)"+ cpsEvalArgs _ _ _ Nothing = throwError $ Default "Unexpected error in function application (2)" ---Obsolete (?) - eval env cont (List (Atom func : args)) = mapM (eval env) args >>= liftThrows . apply func eval _ _ badForm = throwError $ BadSpecialForm "Unrecognized special form" badForm --- Helper function for evaluating 'case'--- TODO: still need to handle case where nothing matches key--- (same problem exists with cond, if)-evalCase :: Env -> LispVal -> LispVal -> IOThrowsError LispVal-evalCase envOuter cont (List (key : cases)) = do- let c = cases !! 0- ekey <- eval envOuter cont key- case c of- List (Atom "else" : exprs) -> last $ map (eval envOuter cont) exprs- List (List cond : exprs) -> do test <- checkEq envOuter ekey (List cond)- case test of- Bool True -> last $ map (eval envOuter cont) exprs- _ -> evalCase envOuter cont $ List $ ekey : tail cases- badForm -> throwError $ BadSpecialForm "Unrecognized special form in case" badForm- where- checkEq env ekey (List (x : xs)) = do - test <- eval env cont $ List [Atom "eqv?", ekey, x]- case test of- Bool True -> eval env cont $ Bool True- _ -> checkEq env ekey (List xs)-- checkEq env ekey val =- case val of- List [] -> eval env cont $ Bool False -- If nothing else is left, then nothing matched key- _ -> do- test <- eval env cont $ List [Atom "eqv?", ekey, val]- case test of- Bool True -> eval env cont $ Bool True- _ -> eval env cont $ Bool False--evalCase _ _ badForm = throwError $ BadSpecialForm "case: Unrecognized special form" badForm---- Helper function for evaluating 'cond'-evalCond :: Env -> LispVal -> LispVal -> IOThrowsError LispVal-evalCond env cont (List [_, expr]) = eval env cont expr-evalCond env cont (List (_ : expr)) = last $ map (eval env cont) expr -- TODO: all expr's need to be evaluated, not sure happening right now-evalCond _ _ badForm = throwError $ BadSpecialForm "evalCond: Unrecognized special form" badForm- makeFunc :: --forall (m :: * -> *). (Monad m) => Maybe String -> Env -> [LispVal] -> [LispVal] -> m LispVal-makeFunc varargs env fparams fbody = return $ Func (map showVal fparams) varargs fbody env False+makeFunc varargs env fparams fbody = return $ Func (map showVal fparams) varargs fbody env makeNormalFunc :: (Monad m) => Env -> [LispVal] -> [LispVal]@@ -494,19 +512,23 @@ -> 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 -- may not be correct, what happens if call/cc is an inner part of a list?--- else continueEval env (trace ("continueEval => " ++ show cont) c) $ head args -- may not be correct, what happens if call/cc is an inner part of a list?- -- TODO:- -- this is not good enough. is it correct if we take c and replace the "outer" continuation with it??- --- -- this would work for return and other simple examples-apply _ (IOFunc func) args = func args-apply _ (PrimitiveFunc func) args = liftThrows $ func args-apply cont (Func aparams avarargs abody aclosure _) args =+ 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)@@ -520,16 +542,18 @@ -- -- 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+ -- detect all tail calls. --+ -- See: http://icem-www.folkwang-hochschule.de/~finnendahl/cm_kurse/doc/schintro/schintro_142.html#SEC294+ -- evalBody evBody env = case cont of- Continuation _ cBody cCont _ _ -> if length cBody == 0- then continueWithContinuation env evBody cCont- else continueWithContinuation env evBody cont- _ -> continueWithContinuation env evBody cont+ 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- continueWithContinuation cwcEnv cwcBody cwcCont = + continueWCont cwcEnv cwcBody cwcCont = continueEval cwcEnv (Continuation cwcEnv cwcBody cwcCont Nothing Nothing) $ Nil "" bindVarArgs arg env = case arg of@@ -839,7 +863,7 @@ 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 --thunk@(Func _ _ _ _ _)] = do+hashTblRef [(HashTable ht), key@(_), Func _ _ _ _] = do case Data.Map.lookup key ht of Just val -> return $ val Nothing -> throwError $ NotImplemented "thunk"@@ -977,12 +1001,15 @@ 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 ([Func _ _ _ _]) = return $ Bool True isProcedure ([IOFunc _]) = return $ Bool True isProcedure _ = return $ Bool False @@ -1034,3 +1061,54 @@ 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...+ -+ - -}+
hs-src/Scheme/Macro.hs view
@@ -189,6 +189,12 @@ -- 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@@ -200,9 +206,26 @@ (List vs) -> setVar localEnv pattern (List $ vs ++ [val]) _ -> throwError $ Default "Unexpected error in checkLocal (Atom)" else defineVar localEnv pattern (List [val])- -- Simple var, load up into macro env- else defineVar localEnv pattern input- return $ Bool True+ 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
hs-src/Scheme/Types.hs view
@@ -46,6 +46,8 @@ | 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'@@ -60,6 +62,7 @@ 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@@ -97,10 +100,16 @@ | Vector (Array Int LispVal) -- ^Vector | HashTable (Data.Map.Map LispVal LispVal)- -- ^Hash table. 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 <http://www.opensubscriber.com/message/haskell-cafe@haskell.org/10779624.html> Map has good performance characteristics compared to the alternatives. So it stays for the moment...- | Number Integer+ -- ^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 <http://www.opensubscriber.com/message/haskell-cafe@haskell.org/10779624.html> 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 -- TODO: rename this "Real" instead of "Float"...+ | Float Double -- FUTURE: rename this "Real" instead of "Float"... -- ^Floating point | Complex (Complex Double) -- ^Complex number@@ -117,42 +126,35 @@ | Func {params :: [String], vararg :: (Maybe String), body :: [LispVal], - closure :: Env,- partialEval :: Bool -- TODO: Obsolete, this member should be removed+ 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- , frameFunc :: (Maybe LispVal)--- , frameRawArgs :: (Maybe [LispVal])- , frameEvaledArgs :: (Maybe [LispVal])- --- --TODO: frame information- -- for evaluating a function (prior to calling) need:- -- - function obj- -- - list of args- --- -- TODO: for TCO within a function, need:- -- - calling function name (or some unique ID, for lambda's)- -- - calling function arg values- -- may be able to have a single frame object take care of both- -- purposes. but before implementing this, do a bit more research- -- to verify the approach.- --- --+ | 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+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
hs-src/shell.hs view
@@ -46,13 +46,17 @@ showBanner :: IO () showBanner = do- putStrLn " __ __ __ __ ______ __ __ "- putStrLn "/\\ \\_\\ \\ /\\ \\/\\ \\ /\\ ___\\ /\\ \\/ / Scheme Interpreter " - putStrLn "\\ \\ __ \\ \\ \\ \\_\\ \\ \\ \\___ \\ \\ \\ _\\\"-. Version 1.3"- putStrLn " \\ \\_\\ \\_\\ \\ \\_____\\ \\/\\_____\\ \\ \\_\\ \\_\\ (c) 2010 Justin Ethier "- putStrLn " \\/_/\\/_/ \\/_____/ \\/_____/ \\/_/\\/_/ github.com/justinethier/husk-scheme "- putStrLn ""- + putStrLn " _ _ __ _ " + putStrLn " | | | | \\\\\\ | | "+ putStrLn " | |__ _ _ ___| | __ \\\\\\ ___ ___| |__ ___ _ __ ___ ___ "+ putStrLn " | '_ \\| | | / __| |/ / //\\\\\\ / __|/ __| '_ \\ / _ \\ '_ ` _ \\ / _ \\ "+ putStrLn " | | | | |_| \\__ \\ < /// \\\\\\ \\__ \\ (__| | | | __/ | | | | | __/ "+ putStrLn " |_| |_|\\__,_|___/_|\\_\\ /// \\\\\\ |___/\\___|_| |_|\\___|_| |_| |_|\\___| "+ putStrLn " "+ putStrLn " husk Scheme Interpreter Version 2.0 "+ putStrLn " (c) 2010 Justin Ethier github.com/justinethier/husk-scheme "+ putStrLn " "+ runRepl :: IO () runRepl = do stdlib <- getDataFileName "stdlib.scm"
husk-scheme.cabal view
@@ -1,14 +1,18 @@ Name: husk-scheme-Version: 1.3+Version: 2.0 Synopsis: R5RS Scheme interpreter program and library. Description: Husk is a dialect of Scheme written in Haskell that implements - a subset of the R5RS standard. Husk is not intended to be a - 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 a great 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.+ a subset of the R5RS standard. Advanced R5RS features are+ provided including continuations, hygenic macros, and the+ full numeric tower.+ + Husk is not intended to be 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 a + great 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. This package includes a stand-alone executable as well as a library that allows an interpreter to be embedded within an
stdlib.scm view
@@ -166,10 +166,27 @@ (let* ((vars vals) ...) body))))) +; FUTURE: cond++; Case+;+; Based loosely on implementation from:+; http://blog.jcoglan.com/2009/02/25/announcing-heist-a-new-scheme-implementation-written-in-ruby/+(define-syntax case+ (syntax-rules (else)+ ((_ key) ((lambda () #f)))+ ((_ key (else expr1 expr2 ...))+ (begin expr1 expr2 ...))+ ((_ key (() expr ...) clause ...)+ (case key clause ...))+ ((_ key+ ((datum1 datum2 ...) expr1 expr2 ...)+ clause ...)+ (if (eqv? #f (memv key '(datum1 datum2 ...)))+ (case key clause ...)+ (begin expr1 expr2 ...)))))+ ; Iteration - do-; TODO: New version of do that makes step optional on a per-variable basis-; This works great in csi but the macro does not match in huski.-; It looks like our macro logic needs to have some more work done :) (define-syntax do (syntax-rules () ((_ ((var init . step) ...)@@ -183,20 +200,6 @@ (if (null? (cdr (list var . step))) (car (list var . step)) (cadr (list var . step))) ...)))))))-; TODO: above (if) block has many transformation problems that need to be worked through--; Old version that always requires step be specified, which violates spec-;(define-syntax old-do-; (syntax-rules ()-; ((_ ((var init step ...) ...)-; (test expr ...) -; command ...)-; (let loop ((var init) ...)-; (if test-; (begin expr ...)-; (begin (begin command ...)-; (loop step ...)))))))- ; Delayed evaluation functions (define force