Initial commit, previous history in darcs repo\!

README

@@ -0,0 +1,4 @@
+This was never intended for public consumption.  Build with `rake build` and then run ./elschemo, that's it!
+
+sjs
+sami.samhuri@gmail.com

Rakefile

@@ -0,0 +1,40 @@
+bin = "elschemo"
+names = %w[lisp]
+
+task :build do
+  sh "ghc --make -package parsec -fglasgow-exts -o #{bin} #{extensionize 'hs', names}"
+end
+
+task :clean do
+  sh "rm -f #{bin} #{obj_files(names)}"
+end
+
+def obj_files names
+  "#{extensionize 'hi', names} #{extensionize 'o', names}"
+end
+
+def extensionize ext, names
+  names.join(".#{ext} ") + ".#{ext}"
+end
+
+
+
+# bin = "elschemo"
+# names = %w[main elschemo parser eval numeric primitives io]
+# 
+# task :build do
+#   sh "ghc --make -package parsec -fglasgow-exts -o #{bin} #{extensionize 'hs', names}"
+# end
+# 
+# task :clean do
+#   sh "rm -f #{bin} #{obj_files(names)}"
+# end
+# 
+# def obj_files names
+#   "#{extensionize 'hi', names} #{extensionize 'o', names}"
+# end
+# 
+# def extensionize ext, names
+#   names.join(".#{ext} ") + ".#{ext}"
+# end
+# 

TODO

@@ -0,0 +1,46 @@
+my own wishes for this little scheme
+------------------------------------
+
+* implement char=?, char<?, char>?, char<=?, and char>=?
+  (char<? #\a #\b) => #t
+
+* readline support (blah, use emacs it's good enough)
+
+* eval code in any given binding (and, hence, expose the binding somehow)
+
+
+tutorial exercises
+------------------
+
+* Add data types and parsers to support the full numeric tower of Scheme numeric types. Haskell has built-in
+  types to represent many of these; check the Prelude. For the others, you can define compound types that
+  represent eg. a Rational as a numerator and denominator, or a Complex as a real and imaginary part (each
+  itself a Real number).
+
+  http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_sec_6.2.1
+
+
+* Add support for the backquote syntactic sugar: the Scheme standard details what it should expand into
+  (quasiquote/unquote).
+
+  http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-7.html#%_sec_4.2.6
+
+* Add support for vectors. The Haskell representation is up to you: GHC does have an Array data type, but it
+  can be difficult to use. Strictly speaking, a vector should have constant-time indexing and updating, but
+  destructive update in a purely functional language is difficult. You may have a better idea how to do this
+  after the section on set!, later in this tutorial.
+
+  http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-9.html#%_sec_6.3.6
+  http://www.haskell.org/ghc/docs/latest/html/libraries/base/Data-Array.html
+
+* Instead of using the try combinator, left-factor the grammar so that the common subsequence is its own
+  parser. You should end up with a parser that matches a string of expressions, and one that matches either
+  nothing or a dot and a single expressions. Combining the return values of these into either a List or a
+  DottedList is left as a (somewhat tricky) exercise for the reader: you may want to break it out into another
+  helper function.
+
+
+* Implement <strike>cond</strike> and case expressions.
+
+* Add the rest of the string functions. You don't yet know enough to do string-set!; this is difficult to
+  implement in Haskell, but you'll have enough information after the next 2 sections

lisp.hs

@@ -0,0 +1,990 @@
+-- author: sjs
+-- last updated: july-10-2007
+--
+-- A small Scheme based on the tutorial by Jonathan Tang.
+-- http://halogen.note.amherst.edu/~jdtang/scheme_in_48/tutorial/overview.html
+--
+-- Where possible and convenient I try to support R5RS.
+-- http://www.schemers.org/Documents/Standards/R5RS/HTML/r5rs-Z-H-2.html
+
+module Main where
+import Char
+import Control.Monad.Error
+import Data.IORef
+import Data.List (isPrefixOf)
+import IO hiding (try)
+import Monad
+import Numeric
+import System.Environment
+import System.Random
+import Text.ParserCombinators.Parsec hiding (spaces)
+
+elSchemoVersion = "0.7"
+
+-- If no file is named on the command line run the REPL, otherwise run the
+-- file then start the REPL
+main :: IO ()
+main = do args <- getArgs
+          putStrLn ("ElSchemo v" ++ elSchemoVersion ++ " by sjs")
+          if null args
+              then runRepl
+              else runOneThenRepl args
+
+-- Some very basic syntax error messages
+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 = readOrThrow parseExpr
+readExprList = readOrThrow (endBy parseExpr maybeSpaces)
+
+type Name = String
+type LispInt = Integer
+type LispFloat = Float
+
+-- numeric lisp data types
+data LispNum = Integer LispInt
+             | Float LispFloat
+    deriving (Eq, Ord, Show)
+
+-- lisp data types
+data LispVal = Atom Name
+             | List [LispVal]
+             | DottedList [LispVal] LispVal
+             | Number LispNum
+             | Char Char
+             | String String
+             | Bool Bool
+             | PrimitiveFunc Name ([LispVal] -> ThrowsError LispVal)
+             | Func {params :: [Name], vararg :: (Maybe String),
+                       body :: [LispVal], closure :: Env}
+             | IOFunc Name ([LispVal] -> IOThrowsError LispVal)
+             | Port Handle
+             | Null Bool
+
+
+-- make the lisp data types instances of relevant classes
+
+lispNumPlus :: LispNum -> LispNum -> LispNum
+lispNumPlus (Integer x) (Integer y) = Integer $ x + y
+lispNumPlus (Integer x) (Float y)   = Float $ (fromInteger x) + y
+lispNumPlus (Float x)   (Float y)   = Float $ x + y
+lispNumPlus (Float x)   (Integer y) = Float $ x + (fromInteger y)
+
+lispNumMinus :: LispNum -> LispNum -> LispNum
+lispNumMinus (Integer x) (Integer y) = Integer $ x - y
+lispNumMinus (Integer x) (Float y)   = Float $ (fromInteger x) - y
+lispNumMinus (Float x)   (Float y)   = Float $ x - y
+lispNumMinus (Float x)   (Integer y) = Float $ x - (fromInteger y)
+
+lispNumMult :: LispNum -> LispNum -> LispNum
+lispNumMult (Integer x) (Integer y) = Integer $ x * y
+lispNumMult (Integer x) (Float y)   = Float $ (fromInteger x) * y
+lispNumMult (Float x)   (Float y)   = Float $ x * y
+lispNumMult (Float x)   (Integer y) = Float $ x * (fromInteger y)
+
+lispNumDiv :: LispNum -> LispNum -> LispNum
+lispNumDiv (Integer x) (Integer y) = Integer $ x `div` y
+lispNumDiv (Integer x) (Float y)   = Float $ (fromInteger x) / y
+lispNumDiv (Float x)   (Float y)   = Float $ x / y
+lispNumDiv (Float x)   (Integer y) = Float $ x / (fromInteger y)
+
+lispNumAbs :: LispNum -> LispNum
+lispNumAbs (Integer x) = Integer (abs x)
+lispNumAbs (Float x) = Float (abs x)
+
+lispNumSignum :: LispNum -> LispNum
+lispNumSignum (Integer x) = Integer (signum x)
+lispNumSignum (Float x) = Float (signum x)
+
+instance Num LispNum where
+    (+) = lispNumPlus
+    (-) = lispNumMinus
+    (*) = lispNumMult
+    abs = lispNumAbs
+    signum = lispNumSignum
+    fromInteger x = Integer x
+
+
+lispNumToRational :: LispNum -> Rational
+lispNumToRational (Integer x) = toRational x
+lispNumToRational (Float x) = toRational x
+
+instance Real LispNum where
+    toRational = lispNumToRational
+
+
+lispValEq :: LispVal -> LispVal -> Bool
+lispValEq (Bool arg1) (Bool arg2) = arg1 == arg2
+lispValEq (Number arg1) (Number arg2) = arg1 == arg2
+lispValEq (String arg1) (String arg2) = arg1 == arg2
+lispValEq (Atom arg1) (Atom arg2) = arg1 == arg2
+lispValEq (DottedList xs x) (DottedList ys y) = lispValEq (List $ xs ++ [x]) (List $ ys ++ [y])
+lispValEq (List arg1) (List arg2) = (length arg1 == length arg2) &&
+                                    (and $ map equalPair $ zip arg1 arg2)
+    where equalPair (x1, x2) = lispValEq x1 x2
+lispValEq _ _ = False
+
+instance Eq LispVal where (==) = lispValEq
+
+
+-- Empty values for each LispVal, these are used for letrec
+
+emptyValue :: LispVal -> LispVal
+emptyValue (Number (Integer _)) = Number (Integer 0)
+emptyValue (Number (Float _)) = Number (Float 0.0)
+emptyValue (Atom _) = Atom "_"
+emptyValue (List _) = List []
+emptyValue (DottedList l r) = DottedList [] (emptyValue r)
+emptyValue (Char _) = Char ' '
+emptyValue (String _) = String ""
+emptyValue (Bool _) = Bool False
+emptyValue (Func params vararg _ env) = Func params vararg [PrimitiveFunc "null" nullFunc] env
+
+nullFunc :: [LispVal] -> ThrowsError LispVal
+nullFunc _ = return $ Null False
+
+
+-- Parser
+
+whitespace :: Parser ()
+whitespace = skipMany1 space
+
+maybeSpaces :: Parser ()
+maybeSpaces = skipMany space
+
+symbol :: Parser Char
+symbol = oneOf "!$%&|*+-/:<=>?@^_~#" <?> "symbol"
+
+
+-- parse a binary digit, analagous to decDigit, octDigit, hexDigit
+binDigit :: Parser Char
+binDigit = oneOf "01" <?> "binary digit (0 or 1)"
+
+-- analogous to isDigit, isOctdigit, isHexDigit
+isBinDigit :: Char -> Bool
+isBinDigit c = (c == '0' || c == '1')
+
+-- analogous to readDec, readOct, readHex
+readBin :: (Integral a) => ReadS a
+readBin = readInt 2 isBinDigit digitToInt
+
+
+-- Integers, floats, characters and atoms can all start with a # so wrap those with try.
+-- (Maybe left factor the grammar in the future)
+parseExpr :: Parser LispVal
+parseExpr = (try parseFloat   <?> "float")
+        <|> (try parseInteger <?> "int")
+        <|> (try parseChar    <?> "char")
+        <|> (parseAtom        <?> "atom")
+        <|> (parseString      <?> "string")
+        <|> (parseQuoted      <?> "quoted expression")
+        <|> do (char '('      <?> "expression") -- should use between?
+               x <- (try parseList) <|> parseDottedList
+               char ')'
+               return x
+        <|> (parseComment     <?> "comment")
+
+
+parseComment :: Parser LispVal
+parseComment = do skipMany space
+                  char ';'
+                  skipMany $ noneOf "\n\r"
+                  return $ Null False
+
+
+parseAtom :: Parser LispVal
+parseAtom = do first <- letter <|> symbol
+               rest <- many (letter <|> digit <|> symbol)
+               let atom = [first] ++ rest
+               return $ case atom of
+                          "#t" -> Bool True
+                          "#f" -> Bool False
+                          otherwise -> Atom atom
+
+
+parseSign :: Parser Char
+parseSign = do try (char '-')
+           <|> do optional (char '+')
+                  return '+'
+
+applySign :: Char -> LispNum -> LispNum
+applySign sign n = if sign == '-' then negate n else n
+
+-- Parse binary, octal, decimal, and hexadecimal integers according to R5RS (#b, #d, #o, #x),
+-- or parse a regular integer in decimal format.
+parseInteger :: Parser LispVal
+parseInteger = do base <- do { char '#'; oneOf "bdox" } <|> return 'd'
+                  sign <- parseSign
+                  int <- parseDigits base
+                  return . Number $ applySign sign $ Integer . fst . head . (reader base) $ int
+    where reader base = case base of
+                          'b' -> readBin
+                          'd' -> readDec
+                          'o' -> readOct
+                          'x' -> readHex
+
+
+-- Parse a string of digits in the given base.
+parseDigits :: Char -> Parser String
+parseDigits base = many1 d >>= return
+    where d = case base of
+                'b' -> binDigit
+                'd' -> digit
+                'o' -> octDigit
+                'x' -> hexDigit
+
+
+-- Parse floating point numbers, but only in decimal.
+parseFloat :: Parser LispVal
+parseFloat = do optional (string "#d")
+                sign <- parseSign
+                whole <- many1 digit
+                char '.'
+                fract <- many1 digit
+                return . Number $ applySign sign (makeFloat whole fract)
+    where makeFloat whole fract = Float . fst . head . readFloat $ whole ++ "." ++ fract
+
+
+-- Parse a single character according to R5RS (#\a, #\A, #\(, ...).
+parseChar :: Parser LispVal
+parseChar = do char '#' >> char '\\'
+               c <- letter <|> digit <|> symbol <|> oneOf "()[]{} "
+               return $ Char c
+
+
+-- Parse an R5RS compliant string.
+parseString :: Parser LispVal
+parseString = do
+    char '"'
+    x <- many singleChar -- <?> "character"
+    char '"'
+    return $ String x
+
+
+escapedChars :: String
+escapedChars = "n\"\\"
+
+singleChar :: Parser Char
+singleChar = noneOf "\\\""
+         <|> try (do c <- char '\\' >> oneOf escapedChars
+                     if c == 'n' then return '\n' else return c)
+         <|> char '\\'
+
+
+
+-- Parse lists
+parseList :: Parser LispVal
+parseList = liftM List $ sepBy parseExpr whitespace
+
+
+-- Parse lists of the form (head . tail)
+parseDottedList :: Parser LispVal
+parseDottedList = do
+    head <- endBy parseExpr whitespace
+    tail <- char '.' >> whitespace >> parseExpr
+    return $ DottedList head tail
+
+
+-- Parse a quoted expression, ie. '(+ 3 5)
+parseQuoted :: Parser LispVal
+parseQuoted = do
+    char '\''
+    x <- parseExpr
+    return $ List [Atom "quote", x]
+
+
+-- Convert LispVals to strings suitable for display
+showVal :: LispVal -> String
+showVal (Null False) = ""
+showVal (String contents) = "\"" ++ escape contents ++ "\""
+showVal (Char c) = "#\\" ++ [c]
+showVal (Atom name) = name
+showVal (List []) = "()"
+showVal (Number (Integer n)) = show n
+showVal (Number (Float n)) = show n
+showVal (Bool True) = "#t"
+showVal (Bool False) = "#f"
+showVal (List contents) = "(" ++ unwordsList contents ++ ")"
+showVal (DottedList head tail) = "(" ++ unwordsList head ++ " . " ++ showVal tail ++ ")"
+showVal (PrimitiveFunc name _) = "#<primitive:" ++ name ++ ">"
+showVal (Func {params = args, vararg = varargs, body = body, closure = env}) =
+  "(lambda (" ++ unwords(map show args) ++
+      (case varargs of
+          Nothing -> ""
+          Just arg -> " . " ++ arg) ++ ") ...)"
+showVal (Port _) = "#<IO port>"
+showVal (IOFunc name _) = "#<IO primitive:" ++ name ++ ">"
+
+unwordsList :: [LispVal] -> String
+unwordsList = unwords . map showVal
+
+instance Show LispVal where show = showVal
+
+
+-- xs =~ s/from/to/g
+subst :: (Eq a) => [a] -> [a] -> [a] -> [a]
+subst _    _  [       ] = []
+subst from to xs@(a:as) =
+    if isPrefixOf from xs
+        then to ++ drop (length from) xs
+        else a : subst from to as
+
+-- escape a string for display
+escape :: String -> String
+escape s = subst "\n" "\\n" (subst "\"" "\\\"" (subst "\\" "\\\\" s))
+
+-- Evaluation
+eval :: Env -> LispVal -> IOThrowsError LispVal
+eval env (List [Atom "load", String filename]) = do
+    load filename >>= evalExprs env
+    return $ Atom ("Loaded " ++ filename ++ ".")
+eval env (Null _) = return $ Null False
+eval env val@(Char _) = return val
+eval env val@(String _) = return val
+eval env val@(Number _) = return val
+eval env val@(Bool _) = return val
+eval env (Atom id) = getVar env id
+eval env (List []) = return $ List []
+eval env (List [Atom "quote", val]) = return val
+eval env (List (Atom "and" : params)) = lispAnd env params
+eval env (List (Atom "or" : params)) = lispOr env params
+eval env (List (Atom "if" : params)) = lispIf env params
+eval env (List (Atom "cond" : params)) = lispCond env params
+eval env (List [Atom "set!", Atom var, form]) =
+    eval env form >>= setVar env var
+eval env (List [Atom "define", Atom var, form]) =
+    eval env form >>= defineVar env var
+eval env (List (Atom "define" : List (Atom var : params) : body)) =
+    makeNormalFunc env params body >>= defineVar env var
+eval env (List (Atom "define" : DottedList (Atom var : params) varargs : body)) =
+    makeVarargs varargs env params body >>= defineVar env var
+eval env (List (Atom "lambda" : List params : body)) =
+    makeNormalFunc env params body
+eval env (List (Atom "lambda" : DottedList params varargs : body)) =
+    makeVarargs varargs env params body
+eval env (List (Atom "lambda" : varargs@(Atom _) : body)) =
+    makeVarargs varargs env [] body
+
+eval env (List (Atom "let" : List params : body)) = do
+    values <- evalArgs env params
+    (liftIO $ bindVars env $ zip names values) >>= evalBody
+    where evalBody env = liftM last $ evalExprs env body
+          names = argNames params
+
+eval env (List (Atom "let*" : List [List [Atom var, form]] : body)) = do
+    eval env form >>= defineVar env var
+    liftM last $ evalExprs env body
+eval env (List (Atom "let*" : List (List [Atom var, form] : rest) : body)) = do
+    eval env form >>= defineVar env var
+    eval env (List (Atom "let*" : List rest : body))
+
+eval env (List (Atom "letrec" : List params : body)) = do
+     -- bind the names of vars so they are visible to everything within the letrec
+    env <- liftIO $ bindVars env $ zip names emptyValues
+    -- now evaluate the args and set the proper values
+    values <- evalArgs env params
+    setVars env $ zip names values
+    -- ready to evaluate the body
+    liftM last $ evalExprs env body
+    where names = argNames params
+          emptyValues = [emptyValue x | x <- params]
+
+-- R6RS adds letrec*, with fairly obvious semantics
+
+eval env (List (function : args)) = do
+    func <- eval env function
+    argVals <- mapM (eval env) args
+    apply func argVals
+
+-- taken from Arc, (f . (1 2 3)) is the same as (apply f '(1 2 3))
+eval env (DottedList [function] (List args)) = do
+    func <- eval env function
+    argVals <- mapM (eval env) args
+    apply func argVals
+
+eval env badForm = throwError $ BadSpecialForm "Unrecongized special form" badForm
+
+
+evalExprs :: Env -> [LispVal] -> IOThrowsError [LispVal]
+evalExprs env exprs = mapM (eval env) exprs
+
+argNames :: [LispVal] -> [Name]
+argNames params = map (\(List [Atom x, y]) -> x) params
+
+args :: [LispVal] -> [LispVal]
+args params = map (\(List [x, y]) -> y) params
+
+evalArgs :: Env -> [LispVal] -> IOThrowsError [LispVal]
+evalArgs env params = evalExprs env (args params)
+
+
+-- Call primitive functions directly.
+-- Call user-defined functions after ensuring the correct number of arguments are present,
+-- and then evaluating those args in the proper context.
+apply :: LispVal -> [LispVal] -> IOThrowsError LispVal
+apply (PrimitiveFunc _ func) args = liftThrows $ func args
+apply (IOFunc _ func) args = func args
+apply (Func params varargs body closure) args =
+    if num params /= num args && varargs == Nothing
+        then throwError $ NumArgs (num params) args
+        else (liftIO $ bindVars closure $ zip params args) >>= bindVarArgs varargs >>= evalBody
+    where remainingArgs = drop (length params) args
+          num = toInteger . length
+          evalBody env = liftM last $ evalExprs env body
+          bindVarArgs arg env = case arg of
+              Just argName -> liftIO $ bindVars env [(argName, List remainingArgs)]
+              Nothing -> return env
+apply unFunc args = throwError $ NotFunction "Not a function" (show unFunc)
+
+
+-- special forms
+
+lispAnd :: Env -> [LispVal] -> IOThrowsError LispVal
+lispAnd env [pred] = eval env pred
+lispAnd env (pred:rest) = do
+    result <- eval env pred
+    case result of
+        Bool False -> return $ Bool False
+        _ -> lispAnd env rest
+
+lispOr :: Env -> [LispVal] -> IOThrowsError LispVal
+lispOr env [pred] = eval env pred
+lispOr env (pred:rest) = do
+    result <- eval env pred
+    case result of
+        Bool False -> lispOr env rest
+        val -> return val
+
+lispIf :: Env -> [LispVal] -> IOThrowsError LispVal
+lispIf env (pred:conseq:alt) = do
+    result <- eval env pred
+    case result of
+        Bool False -> eval env $ head alt
+        Bool True -> eval env conseq
+        badCond -> throwError $ TypeMismatch "boolean" badCond
+
+lispCond :: Env -> [LispVal] -> IOThrowsError LispVal
+lispCond env (List (Atom "else" : exprs) : []) = liftM last $ evalExprs env exprs
+lispCond env (List (pred:conseq) : rest) = do
+    result <- eval env pred
+    case result of
+        Bool False -> case rest of
+            [] -> return $ Null False
+            _ -> lispCond env rest
+        _ -> liftM last $ evalExprs env conseq
+
+
+primitives :: [(Name, [LispVal] -> ThrowsError LispVal)]
+primitives = [("+", numericBinop (+)),
+              ("-", subtractOp),
+              ("*", numericBinop (*)),
+              ("/", floatBinop (/)),
+              ("mod", integralBinop mod),
+              ("quotient", integralBinop quot),
+              ("remainder", integralBinop rem),
+              ("=", numBoolBinop (==)),
+              ("<", numBoolBinop (<)),
+              (">", numBoolBinop (>)),
+              ("/=", numBoolBinop (/=)),
+              (">=", numBoolBinop (>=)),
+              ("<=", numBoolBinop (<=)),
+              ("&&", boolBoolBinop (&&)),
+              ("||", boolBoolBinop (||)),
+              ("car", car),
+              ("cdr", cdr),
+              ("cons", cons),
+              ("null?", nullBoolUnop),
+              ("eq?", eqv),
+              ("eqv?", eqv),
+              ("equal?", equal),
+              ("string=?", strBoolBinop (==)),
+              ("string<", strBoolBinop (<)),
+              ("string>?", strBoolBinop (>)),
+              ("string<=?", strBoolBinop (<=)),
+              ("string>=?", strBoolBinop (>=)),
+              ("symbol?", symbolBoolUnop),
+              ("list?", listBoolUnop),
+              ("dotted-list?", dottedListBoolUnop),
+              ("number?", numBoolUnop),
+              ("integer?", intBoolUnop),
+              ("float?", floatBoolUnop),
+              ("char?", charBoolUnop),
+              ("string?", strBoolUnop),
+              ("bool?", boolBoolUnop),
+              ("symbol->string", convertSymbolToString),
+              ("string->symbol", convertStringToSymbol),
+              ("string->list", convertStringToList),
+              ("list->string", convertListToString),
+              ("char->integer", convertCharToInt),
+              ("integer->char", convertIntToChar),
+              ("char-upcase", convertCharUpcase),
+              ("char-downcase", convertCharDowncase),
+              ("char-at", charAt),
+              ("ceiling", floatingUnop ceiling),
+              ("floor", floatingUnop floor),
+              ("string-concatenate", stringConcatenate),
+              ("string-slice", stringSlice),
+              ("string-reverse", stringReverse)]
+
+primitiveBindings :: IO Env
+primitiveBindings = nullEnv >>= (flip bindVars $ map (makeFunc IOFunc) ioPrimitives
+                                              ++ map (makeFunc PrimitiveFunc) primitives)
+    where makeFunc constructor (var, func) = (var, constructor var func)
+
+numericBinop :: (LispNum -> LispNum -> LispNum) -> [LispVal] -> ThrowsError LispVal
+numericBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
+numericBinop op params = mapM unpackNum params >>= return . Number . foldl1 op
+
+integralBinop :: (LispInt -> LispInt -> LispInt) -> [LispVal] -> ThrowsError LispVal
+integralBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
+integralBinop op params = mapM unpackInt params >>= return . Number . Integer . foldl1 op
+
+floatBinop :: (LispFloat -> LispFloat -> LispFloat) -> [LispVal] -> ThrowsError LispVal
+floatBinop op singleVal@[_] = throwError $ NumArgs 2 singleVal
+floatBinop op params = mapM unpackFloat params >>= return . Number . Float . foldl1 op
+
+subtractOp :: [LispVal] -> ThrowsError LispVal
+subtractOp num@[_] = unpackNum (head num) >>= return . Number . negate
+subtractOp params = numericBinop (-) params
+
+boolBinop :: (LispVal -> ThrowsError a) -> (a -> a -> Bool) -> [LispVal] -> ThrowsError LispVal
+boolBinop unpacker op singleVal@[_] = throwError $ NumArgs 2 singleVal
+boolBinop unpacker op args = do left <- unpacker $ head args
+                                right <- unpacker $ args !! 1
+                                return $ Bool $ left `op` right
+
+numBoolBinop :: (LispNum -> LispNum -> Bool) -> [LispVal] -> ThrowsError LispVal
+numBoolBinop op params = boolBinop unpackNum op params
+
+strBoolBinop = boolBinop unpackStr
+boolBoolBinop = boolBinop unpackBool
+
+unpackNum :: LispVal -> ThrowsError LispNum
+unpackNum (Number (Integer n)) = return $ Integer n
+unpackNum (Number (Float n)) = return $ Float n
+unpackNum notNum = throwError $ TypeMismatch "number" notNum
+
+unpackInt :: LispVal -> ThrowsError Integer
+unpackInt (Number (Integer n)) = return n
+unpackInt (String n) = let parsed = reads n in
+                          if null parsed
+                              then throwError $ TypeMismatch "integer" $ String n
+                              else return . fst . head $ parsed
+unpackInt (List [n]) = unpackInt n
+unpackInt notInt = throwError $ TypeMismatch "integer" notInt
+
+unpackFloat :: LispVal -> ThrowsError Float
+unpackFloat (Number (Float f)) = return f
+unpackFloat (Number (Integer f)) = return $ fromInteger f
+unpackFloat (String f) = let parsed = reads f in
+                             if null parsed
+                                 then throwError $ TypeMismatch "float" $ String f
+                                 else return . fst . head $ parsed
+unpackFloat (List [f]) = unpackFloat f
+unpackFloat notFloat = throwError $ TypeMismatch "float" notFloat
+
+unpackStr :: LispVal -> ThrowsError String
+unpackStr (String s) = return s
+unpackStr (Number (Integer s)) = return $ show s
+unpackStr (Number (Float 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 processing (and strings now too)
+car :: [LispVal] -> ThrowsError LispVal
+car [List (x : xs)] = return x
+car [DottedList (x : xs) _] = return x
+car [String (c:xs)] = return . Char $ c
+car [badArg] = throwError $ TypeMismatch "pair" badArg
+car badArgs = throwError $ NumArgs 1 badArgs
+
+cdr :: [LispVal] -> ThrowsError LispVal
+cdr [List (x : xs)] = return $ List xs
+cdr [DottedList [xs] x] = return x
+cdr [DottedList (_ : xs) x] = return $ DottedList xs x
+cdr [String (_:rest)] = return $ String rest
+cdr [badArg] = throwError $ TypeMismatch "pair" badArg
+cdr badArgs = throwError $ NumArgs 1 badArgs
+
+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 [Char c, String s] = return $ String (c:s)
+cons [String a, String b] = return $ String (a ++ b)
+cons [x1, x2] = return $ DottedList [x1] x2
+cons badArgs = throwError $ NumArgs 2 badArgs
+
+
+-- equivalence testing
+eqv :: [LispVal] -> ThrowsError LispVal
+eqv [arg1, arg2] = return . Bool $ lispValEq arg1 arg2
+eqv badArgs = throwError $ NumArgs 2 badArgs
+
+-- For any type that is an instance of Eq, you can define an Unpacker that takes a function
+-- from LispVal to that type, and may throw an error.
+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)
+
+
+equal :: [LispVal] -> ThrowsError LispVal
+equal [List arg1, List arg2] = return . Bool $ (length arg1 == length arg2) &&
+                                                   (and $ map equalPair $ zip arg1 arg2)
+    where equalPair (x1, x2) =let (Bool x) = extractValue $ equal [x1, x2] in x
+
+equal [arg1, arg2] = do
+    primitiveEquals <- liftM or $ mapM (unpackEquals arg1 arg2)
+                       [AnyUnpacker unpackNum, AnyUnpacker unpackFloat, AnyUnpacker unpackInt, AnyUnpacker unpackStr, AnyUnpacker unpackBool]
+    return $ Bool $ (primitiveEquals || lispValEq arg1 arg2)
+equal badArgs = throwError $ NumArgs 2 badArgs
+
+
+boolUnop :: (LispVal -> LispVal) -> [LispVal] -> ThrowsError LispVal
+boolUnop op [val] = return . op $ val
+boolUnop op badArgs = throwError $ NumArgs 1 badArgs
+
+symbolBoolUnop = boolUnop isLispSymbol
+listBoolUnop = boolUnop isLispList
+dottedListBoolUnop = boolUnop isLispDottedList
+numBoolUnop = boolUnop isLispNumber
+intBoolUnop = boolUnop isLispInteger
+floatBoolUnop = boolUnop isLispFloat
+charBoolUnop = boolUnop isLispChar
+strBoolUnop = boolUnop isLispString
+boolBoolUnop = boolUnop isLispBool
+nullBoolUnop = boolUnop isNull
+
+floatingUnop :: (LispFloat -> LispInt) -> [LispVal] -> ThrowsError LispVal
+floatingUnop op [Number (Float val)] = return . Number . Integer . op $ val
+floatingUnop op [badArg] = throwError $ TypeMismatch "float" badArg
+floatingUnop op badArgs = throwError $ NumArgs 1 badArgs
+
+-- type identification primitives
+isLispSymbol :: LispVal -> LispVal
+isLispSymbol (Atom _) = Bool True
+isLispSymbol _ = Bool False
+
+isLispList :: LispVal -> LispVal
+isLispList (List _) = Bool True
+isLispList _ = Bool False
+
+isLispDottedList :: LispVal -> LispVal
+isLispDottedList (DottedList _ _) = Bool True
+isLispDottedList _ = Bool False
+
+isLispNumber :: LispVal -> LispVal
+isLispNumber (Number  _) = Bool True
+isLispNumber _ = Bool False
+
+isLispInteger :: LispVal -> LispVal
+isLispInteger (Number (Integer _)) = Bool True
+isLispInteger _ = Bool False
+
+isLispFloat :: LispVal -> LispVal
+isLispFloat (Number (Float _)) = Bool True
+isLispFloat _ = Bool False
+
+isLispChar :: LispVal -> LispVal
+isLispChar (Char _) = Bool True
+isLispChar _ = Bool False
+
+isLispString :: LispVal -> LispVal
+isLispString (String _) = Bool True
+isLispString _ = Bool False
+
+isLispBool :: LispVal -> LispVal
+isLispBool (Bool _) = Bool True
+isLispBool _ = Bool False
+
+isNull :: LispVal -> LispVal
+isNull (List []) = Bool True
+isNull _ = Bool False
+
+-- conversions
+
+conversion :: (LispVal -> ThrowsError LispVal) -> [LispVal] -> ThrowsError LispVal
+conversion func [arg]   = func arg
+conversion _    badArgs = throwError $ NumArgs 1 badArgs
+
+convertSymbolToString = conversion symbolToString
+convertStringToSymbol = conversion stringToSymbol
+convertStringToList = conversion stringToList
+convertListToString = conversion listToString
+convertCharUpcase = conversion charUpcase
+convertCharDowncase = conversion charDowncase
+convertCharToInt = conversion charToInt
+convertIntToChar = conversion intToChar
+
+symbolToString :: LispVal -> ThrowsError LispVal
+symbolToString (Atom a) = return $ String a
+symbolToString badArg = throwError $ TypeMismatch "atom" badArg
+
+stringToSymbol :: LispVal -> ThrowsError LispVal
+stringToSymbol (String s) = return $ Atom s
+stringToSymbol badArg = throwError $ TypeMismatch "string" badArg
+
+stringToList :: LispVal -> ThrowsError LispVal
+stringToList (String s) = return $ str2lst (String s)
+stringToList badArg = throwError $ TypeMismatch "atom" badArg
+
+listToString :: LispVal -> ThrowsError LispVal
+listToString (List l) = return $ lst2str (List l)
+listToString badArg = throwError $ TypeMismatch "list" badArg
+
+charUpcase :: LispVal -> ThrowsError LispVal
+charUpcase (Char c) = return $ Char $ toUpper c
+charUpcase badArg = throwError $ TypeMismatch "char" badArg
+
+charDowncase :: LispVal -> ThrowsError LispVal
+charDowncase (Char c) = return $ Char $ toLower c
+charDowncase badArg = throwError $ TypeMismatch "char" badArg
+
+charToInt :: LispVal -> ThrowsError LispVal
+charToInt (Char c) = return $ Number . Integer . toInteger $ ord c
+charToInt badArg = throwError $ TypeMismatch "char" badArg
+
+intToChar :: LispVal -> ThrowsError LispVal
+intToChar (Number (Integer n)) = return $ Char . chr $ fromInteger n
+intToChar badArg = throwError $ TypeMismatch "integer" badArg
+
+
+-- string functions
+
+lst2str :: LispVal -> LispVal
+lst2str (List l) = String [c | Char c <- l]
+
+str2lst :: LispVal -> LispVal
+str2lst (String s) = List [Char c | c <- s]
+
+charAt :: [LispVal] -> ThrowsError LispVal
+charAt [Number (Integer idx), String s] = return . Char $ s !! (fromInteger idx)
+charAt [badArg, String _] = throwError $ TypeMismatch "integer" badArg
+charAt [Number (Integer _), badArg] = throwError $ TypeMismatch "string" badArg
+charAt badArgs = throwError $ NumArgs 2 badArgs
+
+stringConcatenate :: [LispVal] -> ThrowsError LispVal
+stringConcatenate [List xs] = return . String $ foldl (++) "" strings
+    where strings = [s | String s <- xs]
+stringConcatenate [badArg] = throwError $ TypeMismatch "list" badArg
+stringConcatenate badArgs = throwError $ NumArgs 1 badArgs
+
+stringSlice :: [LispVal] -> ThrowsError LispVal
+stringSlice [String s, Number (Integer start), Number (Integer len)] =
+    return . String $ take (fromInteger len) $ drop (fromInteger start) s
+stringSlice badArgs@[_,_,_] = throwError $ TypeMismatch "string,integer,integer" (List badArgs)
+stringSlice badArgs = throwError $ NumArgs 3 badArgs
+
+stringReverse :: [LispVal] -> ThrowsError LispVal
+stringReverse [String s] = return . String $ reverse s
+stringReverse [badArg] = throwError $ TypeMismatch "string" badArg
+stringReverse badArgs = throwError $ NumArgs 1 badArgs
+
+
+-- error checking
+data LispError = NumArgs Integer [LispVal]
+               | TypeMismatch String LispVal
+               | Parser ParseError
+               | BadSpecialForm String LispVal
+               | NotFunction String String
+               | UnboundVar String String
+               | Default String
+               | FileNotFound String
+
+showError :: LispError -> String
+showError (UnboundVar message varname) = message ++ ": " ++ varname
+showError (BadSpecialForm message form) = message ++ ": " ++ show form
+showError (NotFunction message func) = message ++ ": " ++ func
+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 (FileNotFound filename) = "File not found: " ++ show filename
+
+instance Show LispError where show = showError
+
+instance Error LispError where
+    noMsg = Default "An error has occured"
+    strMsg = Default
+
+type ThrowsError = Either LispError
+
+--XXX what type does trapError have?
+trapError action = catchError action (return . show)
+
+extractValue :: ThrowsError a -> a
+extractValue (Right val) = val
+
+-- REPL (read-eval-print loop)
+
+flushStr :: String -> IO ()
+flushStr str = putStr str >> hFlush stdout
+
+readPrompt :: String -> IO String
+readPrompt prompt = flushStr prompt >> getLine
+
+evalString :: Env -> String -> IO String
+evalString env expr = runIOThrows $ liftM show $ (liftThrows $ readExpr expr) >>= eval env
+
+evalAndPrint :: Env -> String -> IO ()
+evalAndPrint env expr = do
+    result <- evalString env expr
+    if result == ""
+        then return ()
+        else putStrLn result
+
+until_ :: Monad m => (a -> Bool) -> m a -> (a -> m ()) -> m ()
+until_ pred prompt action = do
+  result <- prompt
+  if pred result
+     then return ()
+     else action result >> until_ pred prompt action
+
+runOneThenRepl :: [String] -> IO ()
+runOneThenRepl args = do
+    env <- primitiveBindings >>= flip bindVars [("args", List $ map String $ drop 1 args)]
+    (runIOThrows $ liftM show $ eval env (List [Atom "load", String (args !! 0)]))
+        >>= hPutStrLn stderr
+    runReplWithEnv $ return env
+
+runReplWithEnv :: IO Env -> IO ()
+runReplWithEnv env = do env >>= until_ (== "quit") (readPrompt "> ") . evalAndPrint
+
+runRepl :: IO ()
+runRepl = runReplWithEnv primitiveBindings
+--
+--runOneThenRepl :: [String] -> IO ()
+--runOneThenRepl args = do runOneWithEnv primitiveBindings args >>= runReplWithEnv
+
+
+-- saving state, the environment (a list of strings paired to mutable values)
+type Env = IORef [(String, IORef LispVal)]
+
+nullEnv :: IO Env
+nullEnv = newIORef []
+
+
+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
+
+
+isBound :: Env -> String -> IO Bool
+isBound envRef var = readIORef envRef >>= return . maybe False (const True) . lookup var
+
+getVar :: Env -> String -> IOThrowsError LispVal
+getVar envRef var = do env <- liftIO $ readIORef envRef
+                       maybe (throwError $ UnboundVar "Getting an unbound variable" var)
+                             (liftIO . readIORef)
+                             (lookup var env)
+
+setVar :: Env -> String -> LispVal -> IOThrowsError LispVal
+setVar envRef var value = do env <- liftIO $ readIORef envRef
+                             maybe (throwError $ UnboundVar "Setting an unbound variable" var)
+                                   (liftIO . (flip writeIORef value))
+                                   (lookup var env)
+                             return value
+
+setVars :: Env -> [(String, LispVal)] -> IOThrowsError LispVal
+setVars envRef values = liftM last $ mapM set values
+    where set (var, value) = setVar envRef var value
+
+defineVar :: Env -> String -> LispVal -> IOThrowsError LispVal
+defineVar envRef var value = do
+    alreadyDefined <- liftIO $ isBound envRef var
+    if alreadyDefined
+        then setVar envRef var value >> return value
+        else liftIO $ do
+            valueRef <- newIORef value
+            env <- readIORef envRef
+            writeIORef envRef ((var, valueRef) : env)
+            return value
+
+bindVars :: Env -> [(String, LispVal)] -> IO Env
+bindVars envRef bindings = readIORef envRef >>= extendEnv bindings >>= newIORef
+    where extendEnv bindings env = liftM (++ env) (mapM addBinding bindings)
+          addBinding (var, value) = do ref <- newIORef value
+                                       return (var, ref)
+
+--- XXX types? same as makeFunc, no?
+makeFunc varargs env params body = return $ Func (map showVal params) varargs body env
+makeNormalFunc = makeFunc Nothing
+makeVarargs = makeFunc . Just . showVal
+
+
+ioPrimitives :: [(String, [LispVal] -> IOThrowsError LispVal)]
+ioPrimitives = [("apply", applyProc),
+                ("open-input-file", makePort ReadMode),
+                ("open-output-file", makePort WriteMode),
+                ("close-input-file", closePort),
+                ("close-output-file", closePort),
+                ("read", readProc),
+                ("write", writeProc),
+                ("read-contents", readContents),
+                ("read-all", readAll),
+                ("display", display),
+                ("random", randomInt)]
+
+applyProc :: [LispVal] -> IOThrowsError LispVal
+applyProc [func, List args] = apply func args
+applyProc (func : args) = apply func args
+
+makePort :: IOMode -> [LispVal] -> IOThrowsError LispVal
+makePort mode [String filename] = liftM Port $ liftIO $ openFile filename mode
+
+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
+
+writeProc :: [LispVal] -> IOThrowsError LispVal
+writeProc [obj] = writeProc [obj, Port stdout]
+writeProc [obj, Port port] = liftIO $ hPrint port obj >> (return $ Bool True)
+
+readContents :: [LispVal] -> IOThrowsError LispVal
+readContents [String filename] = liftM String $ liftIO $ readFile filename
+
+load :: String -> IOThrowsError [LispVal]
+load filename = (liftIO $ readFile filename) >>= liftThrows . readExprList
+
+readAll :: [LispVal] -> IOThrowsError LispVal
+readAll [String filename] = liftM List $ load filename
+
+
+-- display values, fallback on showVal since only strings and chars need to be displayed differently
+displayVal :: LispVal -> String
+displayVal (String contents) = contents
+displayVal (Char c) = [c]
+displayVal x = showVal x
+
+
+display :: [LispVal] -> IOThrowsError LispVal
+display [] = return $ Null False
+display (x : xs) = do liftIO . putStr $ displayVal x; display xs
+
+randomInt :: [LispVal] -> IOThrowsError LispVal
+randomInt [Number (Integer high)] = liftM (Number . Integer) $ liftIO num
+    where num = getStdRandom (randomR (0,high-1))
+randomInt [badArg] = throwError $ TypeMismatch "integer" badArg
+randomInt args = throwError $ NumArgs 1 args

stdlib.scm

@@ -0,0 +1,226 @@
+;; the basics
+(define nil ())
+(define null nil)
+(define true  #t)
+(define false #f)
+(define (pair? x) (and (list? x) (not (null? x))))
+(define (not x) (if (eq? #f x) #t #f))
+(define (newline) (display "\n"))
+
+(define (list . objs) objs)
+(define (id obj) obj)
+(define (flip func)
+  (lambda (arg1 arg2) (func arg2 arg1)))
+(define (curry func arg1)
+  (lambda (arg) (func arg1 arg)))
+(define (compose f g)
+  (lambda (arg) (f (apply g arg))))
+
+;; math
+(define zero?       (curry = 0))
+(define negative?   (curry (flip <) 0))
+(define positive?   (curry (flip >) 0))
+(define inc         (curry + 1))
+(define dec         (curry (flip -) 1))
+
+(define (divides? a b)
+  (zero? (remainder b a)))
+
+(define (prime? x)
+  (= x (smallest-divisor x)))
+
+;; this sort of coercion shouldn't be necessary
+(define (odd? num)
+  (cond ((and (float? num) (equal? num (floor num))) (= (mod (floor num) 2) 1))
+        ((float? num) (display "odd? expects an integer, given:" num) #f)
+        (else (= (mod num 2) 1))))
+(define (even? num)
+  (cond ((and (float? num) (equal? num (floor num))) (zero? (mod (floor num) 2)))
+        ((float? num) (display "even? expects an integer, given:" num) #f)
+        (else (zero? (mod num 2)))))
+
+(define (square x)  (* x x))
+(define (abs x)
+  (cond ((< x 0) (- x))
+        (else x)))
+
+;; exponentation using recursion (pretty fast)
+(define (expt-rec b n)
+  (if (zero? n)
+      1
+      (* b (expt-rec b (dec n)))))
+
+;; exponentation using foldl (slowest)
+(define (expt-fold b n)
+  (fold * 1 (fill (range 1 n) b)))
+
+;; exponentation using iteration
+;; (seems a bit slower than the recursive version, but still fast)
+(define (expt-iter b counter . product)
+  (let product (lambda (if (null? product) 1 (car product)))
+    (if (zero? counter)
+        product
+        (expt-iter b (dec counter) (* b product)))))
+
+;; fast exponentation
+(define (fast-expt b n)
+  (cond ((= n 0) 1)
+        ((even? n) (square (fast-expt b (/ n 2))))
+        (else (* b (fast-expt b (- n 1))))))
+(define expt fast-expt)
+
+;; calculate square roots
+(define (sqrt-good-enough? guess x)
+  (let ((delta 0.0001))
+    (< (abs (- (square guess) x))
+       delta)))
+
+(define (sqrt-improve guess x)
+  (average guess (/ x guess)))
+
+(define (sqrt-iter guess x)
+  (if (sqrt-good-enough? guess x)
+      guess
+      (sqrt-iter (sqrt-improve guess x) x)))
+
+(define (sqrt x)
+  (sqrt-iter 1.0 x))
+
+(define (factorial n)
+  (if (<= n 1)
+      1
+      (* n (factorial (- n 1)))))
+(define ! factorial)
+
+;; greatest common denominator
+(define (gcd a b)
+  (if (zero? b)
+      a
+      (gcd b (remainder a b))))
+
+(define (find-divisor n test-divisor)
+  (let ((next (lambda (n)
+                (if (eq? n 2)
+                    3
+                    (+ n 2)))))
+    (cond ((> (square test-divisor) n) n)
+          ((divides? test-divisor n) test-divisor)
+          (else (find-divisor n (next test-divisor))))))
+
+(define (smallest-divisor n)
+    (find-divisor n 2))
+
+(define (expmod base exp m)
+  (cond ((zero? exp) 1)
+        ((even? exp)
+         (remainder (square (expmod base (/ exp 2) m))
+                    m))
+        (else
+         (remainder (* base (expmod base (dec exp) m))
+                    m))))
+
+;; test for prime numbers using Fermat's method
+(define (fermat-test n)
+  (let ((try-it (lambda (a)
+                  (= (expmod a n n) a))))
+    (try-it (inc (random (dec n))))))
+
+;; this runs Fermat's test a given number of times
+(define (fast-prime? n times)
+  (cond ((zero? times) true)
+        ((fermat-test n) (fast-prime? n (dec times)))
+        (else false)))
+
+;; folds
+
+;; SICP calls this accumulate
+(define (foldr func end lst)
+  (if (null? lst)
+      end
+      (func (car lst) (foldr func end (cdr lst)))))
+
+(define (foldl func accum lst)
+  (if (null? lst)
+      accum
+      (foldl func (func accum (car lst)) (cdr lst))))
+
+(define fold foldl)
+(define reduce fold)
+
+(define (unfold func init pred)
+  (if (pred init)
+      (cons init '())
+      (cons init (unfold func (func init) pred))))
+
+(define (sum-list lst)  (fold + 0 lst))
+(define (sum . lst)     (sum-list lst))
+(define (product . lst) (fold * 0 lst))
+(define (average . xs)  (/ (sum-list xs) (length xs)))
+(define avg average)
+
+(define (max first . num-list) (fold (lambda (old new) (if (> old new) old new)) first num-list))
+(define (min first . num-list) (fold (lambda (old new) (if (< old new) old new)) first num-list))
+(define (length lst)           (fold (lambda (x y) (+ x 1)) 0 lst))
+(define (reverse lst)          (fold (flip cons) '() lst))
+(define (nth n lst)            (if (= n 1) (car lst) (nth (- n 1) (cdr lst))))
+
+
+(define (mem-helper pred op)   (lambda (acc next) (if (and (not acc) (pred (op next))) next acc)))
+(define (memq   obj lst)       (fold (mem-helper (curry eq?    obj) id) #f lst))
+(define (memv   obj lst)       (fold (mem-helper (curry eqv?   obj) id) #f lst))
+(define (member obj lst)       (fold (mem-helper (curry equal? obj) id) #f lst))
+(define (assq   obj alist)     (fold (mem-helper (curry eq?    obj) car) #f alist))
+(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 define fold-k (fold w/ continuations) and use it to short-circuit these
+(define (any? pred lst)        (fold (lambda (any-found x) (or any-found (pred x))) #f lst))
+(define (all? pred lst)        (fold (lambda (all-matched x) (and (pred x) all-matched)) #t lst))
+
+;; transformations
+;; (define (map func lst)         (foldr (lambda (x y) (cons (func x) y)) '() lst))
+;; (define (mapr func lst)        (fold (lambda (x y) (cons (func y) x)) '() lst))
+(define (filter pred lst)      (foldr (lambda (x y) (if (pred x) (cons x y) y)) '() lst))
+(define (fill lst n)           (map (lambda (x) n) lst))
+
+;; the more general version of map, similar to mapcar in Lisp
+(define (map func . seqs)
+  (cond ((= 1 (length seqs))
+         (foldr (lambda (x y) (cons (func x) y)) '() (car seqs)))
+        ((null? (car seqs)) nil)
+        (else
+         (cons (apply func (map car seqs))
+               (apply map (cons func (map cdr seqs)))))))
+
+
+(define (caar lst)              (car (car lst)))
+(define (cadr lst)              (car (cdr lst)))
+(define (caddr lst)             (car (cdr (cdr lst))))
+(define (cadddr lst)            (car (cdr (cdr (cdr lst)))))
+
+
+;; like python's range
+;; SICP calls this enumerate-interval ... i prefer range
+(define (range min max)
+  (if (> min max)
+      nil
+      (cons min (range (inc min) max))))
+
+;; recursive method of concatenating 2 lists
+(define (append list1 list2)
+  (if (null? list1)
+      list2
+      (cons (car list1) (append (cdr list1) list2))))
+
+;; string manipulation
+(define (string-map func s)
+  (list->string (map func (string->list s))))
+
+(define (string-upcase s)
+  (string-map char-upcase s))
+
+(define (string-downcase s)
+  (string-map char-downcase s))
+
+(define (string-append . lst)
+  (string-concatenate lst))