OCaml Lisp Interpreter

mlisp.ml

#use "topfind"
#require "sexplib"

module StringMap = Map.Make(String)
module Sexp = Sexplib.Sexp

type atom =
  | AstSymbol of string
  | AstInteger of int
  | AstString of string

type node =
  | AstAtom of atom
  | AstList of node list

type value =
  | Nil 
  | List of value list
  | Integer of int
  | String of string
  | Symbol of string
  | Lambda of (bindings -> value list -> value)
  | Macro of (bindings -> value list -> (bindings * value))

and bindings = value StringMap.t

let rec construct_ast sexp =
  match sexp with
  | Sexp.Atom atom ->
     (match int_of_string_opt atom with
     | Some i -> AstAtom (AstInteger i)
     | None ->
        if String.length atom >= 2 && atom.[0] = '\'' && atom.[String.length atom - 1] = '\''
        then AstAtom (AstString (String.sub atom 1 (String.length atom - 2)))
        else AstAtom (AstSymbol atom))
  | Sexp.List lst ->
     AstList (List.map construct_ast lst)

let rec read_expression ast =
  match ast with
  | AstAtom atom ->
     (match atom with
     | AstInteger x -> Integer x
     | AstSymbol x -> Symbol x
     | AstString x -> String x)
  | AstList lst ->
     List (List.map read_expression lst)

let rec eval bindings value =
  match value with
  | List (rator :: rands) ->
     (match eval bindings rator with
     | (bindings, Lambda f) ->
        (bindings, (f bindings (List.map snd (List.map (eval bindings) rands))))
     | (bindings, Macro f) ->
        (f bindings rands)
     | _ -> failwith "Not a function or macro")
  | List [] ->
     (bindings, Nil)
  | Symbol sym ->
     (match StringMap.find_opt sym bindings with
     | Some binding -> 
        (bindings, binding)
     | None ->
       failwith (String.cat sym " is unbound"))
  | x ->
     (bindings, x) 

let rec print value =
  (match value with
  | Nil -> print_string "Nil "
  | List x -> List.iter print x
  | Integer x -> print_int x; print_string " "
  | String x -> print_string x; print_string " "
  | Symbol x -> print_string x; print_string " "
  | Lambda _ -> print_string "<lambda> "
  | Macro _ -> print_string "<macro> ");
  print_endline ""
     
let plus_impl _bindings rands =
  let rec label rands =
    match rands with
    | (Integer x) :: [] ->
       x
    | (Integer x) :: rest ->
       (x + (label rest))
    | _ ->
       failwith "Invalid arguments"
  in
  Integer (label rands)

let lambda_impl bindings rands =
  match rands with
  | (List params) :: body ->
     (bindings,
     Lambda (fun bindings args ->
         snd (eval
                (List.fold_left2 (fun bindings name value ->
                     match name with
                     | Symbol sym ->
                        StringMap.add sym value bindings
                     | _ -> failwith "Invalid arguments")
                   bindings
                   params
                   args)
                (List.hd body))))
  | _ ->
     failwith "Invalid arguments in lambda"

let if_impl bindings rands =
  match rands with
  | pred :: pos :: neg :: [] ->
     (bindings,
     snd
      (if Nil = (snd (eval bindings pred)) then
         eval bindings neg
       else
         eval bindings pos)
     )
  | _ ->
     failwith "Invalid arguments in if"

let eq_impl _bindings rands =
  let rec label rands =
    match rands with
    | a :: b :: [] ->
       if a = b then
         a
       else
         Nil
    | a :: b :: rest ->
       if a = b then
         label (b :: rest)
       else
         Nil
    | _ ->
       failwith "Invalid arguments in ="
  in
  label rands

let define_impl bindings rands =
  match rands with
  | (Symbol name) :: value :: [] ->
     ((StringMap.add name (snd (eval bindings value)) bindings), Nil)
  | _ ->
       failwith "Invalid arguments in define"
     
let initial_bindings () =
  let bindings = StringMap.add "+" (Lambda plus_impl) StringMap.empty in
  let bindings = StringMap.add "=" (Lambda eq_impl) bindings in
  let bindings = StringMap.add "define" (Macro define_impl) bindings in
  let bindings = StringMap.add "lambda" (Macro lambda_impl) bindings in
  let bindings = StringMap.add "if" (Macro if_impl) bindings in
  bindings

let eval_string bindings str =
  let sexp = Sexplib.Sexp.of_string str in
  let ast = construct_ast sexp in
  let value = read_expression ast in
  eval bindings value

let () =
  let rec label bindings =
    print_string "> ";
    match (eval_string bindings (read_line ())) with
    | (bindings, value) ->
       print value;
       label bindings
  in
  label (initial_bindings ())