Here we define the core logic of the Small Lisp interpreter.

module SmLispInterpret where

import SExpression as SE
import SmLispParse
import qualified Data.Map.Strict as Env
import Control.Applicative
import System.IO (stdout,stderr,hPutStr,hPutStrLn)

Environment Processing Logic

Env.Map is used for function environments, with a tag to distinguish user-defined from built-in functions.

Association lists are used for value-environments.

data FnEntry = UserDef [Identifier] SmLispExpr | 
               BuiltIn ([SE.SExpression] -> Maybe SE.SExpression)

type FnEnv = Env.Map [Char] FnEntry

builtinFnEnv = 
    Env.fromList [("first", BuiltIn SE.first), ("rest", BuiltIn SE.rest), 
                  ("endp", BuiltIn SE.endp), ("cons", BuiltIn SE.cons), 
                  ("eq", BuiltIn SE.eq),
                  ("numberp", BuiltIn SE.numberp), ("symbolp", BuiltIn SE.symbolp), 
                  ("listp", BuiltIn SE.listp), ("eqp", BuiltIn SE.eqp),
                  ("lessp", BuiltIn SE.lessp), ("greaterp", BuiltIn SE.greaterp), 
                  ("plus", BuiltIn SE.plus), ("minus", BuiltIn SE.minus), 
                  ("times", BuiltIn SE.times), ("divide", BuiltIn SE.divide), 
                  ("rem", BuiltIn SE.rem), ("sym-lessp", BuiltIn SE.sym_lessp), 
                  ("explode", BuiltIn SE.explode), ("implode", BuiltIn SE.implode)]

type ValEnv = ([(String, SE.SExpression)], [(String, SE.SExpression)])

builtinValEnv = ([], 
                 [("T", SymAtom "T"), ("F", SymAtom "F"), ("otherwise", SymAtom "T")])

reset_to_global_frame (local, global) = ([], global)

applyValEnv (local, global) name =
    case lookup name local of
        Just a -> Just a
        Nothing -> lookup name global

applyFnEnv fnEnv name = Env.lookup name fnEnv

The Heart of the Interpreter: Evaluation

sl_eval (SExpr a) _ _ = Just a
sl_eval (Variable n) _ valEnv = applyValEnv valEnv n
sl_eval (FnCall n args) fnEnv valEnv = 
    sl_apply n (sequence (map (\e -> sl_eval e fnEnv valEnv) args)) 
               fnEnv (reset_to_global_frame valEnv)
sl_eval (CondExpr clauses) fnEnv valEnv = sl_evcond clauses fnEnv valEnv
sl_eval (LetExpr defs e) fnEnv valEnv = 
    sl_eval e fnEnv (add_associations defs fnEnv valEnv)

add_associations [] fnEnv valEnv = valEnv
add_associations ((Binding n e):more_defs) fnEnv (local, global) = 
    case sl_eval e fnEnv (local, global) of
        Just x -> add_associations more_defs fnEnv ((n, x):local, global)
        Nothing -> add_associations more_defs fnEnv (local, global)

sl_evcond [] _ _ = Nothing
sl_evcond (Clause p e : more_clauses) fnEnv valEnv =
    case sl_eval p fnEnv valEnv of
        Just (SymAtom "T") -> sl_eval e fnEnv valEnv
        Just (SymAtom "F") -> sl_evcond more_clauses fnEnv valEnv
        _ -> Nothing

sl_apply n Nothing fnEnv valEnv = Nothing
sl_apply n (Just args) fnEnv (local, global) =
    case applyFnEnv fnEnv n of
        Just (BuiltIn primitive) -> primitive args
        Just (UserDef parameters expr) -> 
            sl_eval expr fnEnv ((zip parameters args) ++ local), global)
        _-> Nothing

setup_envs_then_eval fnEnv valEnv [] expr = sl_eval expr fnEnv valEnv

setup_envs_then_eval fnEnv valEnv@(local, global) (ConstantDef n e : more_defs) expr =
    case sl_eval e fnEnv valEnv of
        Just sexpr -> 
            setup_envs_then_eval fnEnv (local, (n, sexpr): global) more_defs expr
        Nothing ->  -- on Error, skip and leave n undefined
            setup_envs_then_eval fnEnv valEnv more_defs expr 

setup_envs_then_eval fnEnv valEnv (FunctionDef name args e : more_defs) expr =
    setup_envs_then_eval (Env.insert name (UserDef args e) fnEnv) valEnv more_defs expr


interpret defs expr = setup_envs_then_eval builtinFnEnv builtinValEnv defs expr

smlisp def_text expr_text =
    case (parseProgramText def_text, parseExpressionText expr_text) of
        (Just defs, Just expr) -> interpret defs expr
        _ -> Nothing