Initial import

.depend

@@ -0,0 +1,8 @@
+builtins.cmo: sexp.cmo environment.cmo
+builtins.cmx: sexp.cmx environment.cmx
+environment.cmo: sexp.cmo
+environment.cmx: sexp.cmx
+main.cmo: builtins.cmo
+main.cmx: builtins.cmx
+sexp.cmo:
+sexp.cmx:

Makefile

@@ -0,0 +1,43 @@
+OCAMLC=ocamlc
+OCAMLOPT=ocamlopt
+OCAMLDEP=ocamldep
+INCLUDES=
+OCAMLFLAGS=$(INCLUDES) -g
+OCAMLOPTFLAGS=$(INCLUDES)
+
+MAIN_OBJS=sexp.cmo parser.cmo lexer.cmo environment.cmo builtins.cmo main.cmo
+
+tiny_lisp: .depend $(MAIN_OBJS)
+	$(OCAMLC) -o tiny_lisp $(OCAMLFLAGS) $(MAIN_OBJS)
+
+.SUFFIXES: .ml .mli .cmo .cmi .cmx .mll .mly
+
+.mll.ml:
+	ocamllex $<
+.mly.ml:
+	ocamlyacc $<
+.ml.cmo:
+	$(OCAMLC) $(OCAMLFLAGS) -c $<
+
+.mli.cmi:
+	$(OCAMLC) $(OCAMLFLAGS) -c $<
+
+.ml.cmx:
+	$(OCAMLOPT) $(OCAMLOPTFLAGS) -c $<
+
+clean:
+	rm -f tiny_lisp
+	rm -f *~
+	rm -f *.cm[iox]
+	rm -f parser.ml parser.mli
+	rm -f lexer.ml
+
+parser.cmo : parser.cmi
+parser.mli : parser.mly
+parser.ml : parser.mly
+
+
+.depend:
+	$(OCAMLDEP) $(INCLUDES) *.mli *.ml *.mly *.mll > .depend
+
+include .depend

README

@@ -0,0 +1,6 @@
+Quick and dirty implementation of JMC's Lisp:
+
+http://www.paulgraham.com/rootsoflisp.html
+
+Based on < http://nakkaya.com/2010/08/24/a-micro-manual-for-lisp-implemented-in-c/ >
+

builtins.ml

@@ -0,0 +1,140 @@
+open Sexp
+open Environment
+
+let tee = (Atom "#T")
+
+let nil = cons Null Null
+
+let fn_car args _ = car (car args)
+
+let fn_cdr args _ = cdr (car args)
+
+let fn_quote args _ = car args
+
+let fn_cons args _ =
+  let lst = cons (car args) Null  in
+
+  let rec loop a =
+    match a with
+        Cons (_) ->
+          begin
+            append lst (car a) ;
+            loop (cdr a)
+          end
+      | _ -> lst
+  in
+    loop (car (cdr args))
+
+
+let fn_equal args _ =
+  let first = car args in
+  let second = car (cdr args) in
+    if (name first) = (name second) then
+      tee
+    else
+      nil
+
+let fn_atom args _ =
+  match (car args) with
+      Atom (_) -> tee
+    | _ -> nil
+
+let rec fn_lambda args env =
+  let lambda = (car args) in
+  let rest = (cdr args) in
+    match lambda with
+        Lambda (largs, lsexp) ->           
+          let lst = interleave largs rest in
+          let sexp = replace_atom lsexp lst in            
+            eval sexp env
+      | _ -> invalid_arg "Argument to lambda must be a Lambda"          
+and eval sexp env =
+  match sexp with
+      Null -> nil
+    | Cons (_) ->
+        (match (car sexp) with
+             Atom ("LAMBDA") ->
+               let largs = car (cdr sexp) in
+               let lsexp = car (cdr (cdr sexp)) in
+                 Lambda (largs, lsexp)                    
+           | _ ->
+               let acc = cons (eval (car sexp) env) Null in
+               let rec loop s =
+                 match s with
+                     Cons (_) ->
+                       append acc (eval (car s) env) ;
+                       loop (cdr s)
+                   | _ -> ()
+               in
+                 loop (cdr sexp) ;
+                 eval_fn acc env)
+    | _ ->
+        let v = lookup (name sexp) env in
+          match v with
+              Null -> sexp
+            | _ -> v                          
+
+and eval_fn sexp env =
+  let symbol = car sexp in
+  let args = cdr sexp in
+    match symbol with
+        Lambda (_) ->
+          fn_lambda sexp env
+      | Func (fn) ->
+          (fn args env)
+      | _ -> sexp  
+
+
+let fn_cond args env =
+  let rec loop a =
+    match a with
+        Cons (_) ->
+          begin
+            let lst = car a in
+            let pred = (if (car lst) != nil then
+                          eval (car lst) env
+                        else
+                          nil)
+            in
+            let ret = car (cdr lst) in
+              if pred != nil then
+                eval ret env
+              else
+                loop (cdr a)
+          end
+      | _ -> nil
+  in
+    loop args
+
+let fn_label args env =
+  append env
+    (cons (Atom (name (car args)))
+       (cons (car (cdr args)) Null)) ;
+  tee
+
+let rec lisp_print sexp =
+  match sexp with
+      Null -> ()
+    | Cons (_) ->
+        begin
+          Printf.printf "(" ;
+          lisp_print (car sexp) ;
+          let rec loop s =
+            match s with
+                Cons (_) ->
+                  Printf.printf " " ;
+                  lisp_print (car s) ;
+                  loop (cdr s)
+              | _ -> ()
+          in
+            loop (cdr sexp) ;
+            Printf.printf ")" ;
+        end
+    | Atom (n) ->
+        Printf.printf "%s" n
+    | Lambda (largs, lsexp) ->
+        Printf.printf "#" ;
+        lisp_print largs ;
+        lisp_print lsexp
+    | _ ->
+        Printf.printf "Error."                                

environment.ml

@@ -0,0 +1,84 @@
+open Sexp
+
+let append lst o =
+  let rec loop ptr =
+    match (cdr ptr) with
+        Cons (_) -> loop (cdr ptr)
+      | _ ->
+          match ptr with
+              Cons (c) ->
+                c.cdr <- cons o Null
+            | _ -> invalid_arg "Append needs a cdr"
+  in
+    loop lst
+
+let lookup n env =
+  let rec loop tmp =
+    match tmp with
+        Cons (_) ->
+          let item = car tmp in
+          let nm = car item in
+          let v = car (cdr item) in
+
+            if (name nm) = n then
+              v
+            else
+              loop (cdr tmp)
+
+      | _ -> Null
+  in
+    loop env
+
+let rec replace_atom sexp rep =
+  match sexp with
+      Cons (_) ->
+        begin 
+          let lst = (cons (replace_atom (car sexp) rep) Null) in
+          let rec loop s =
+            match s with
+                Cons(_) ->
+                  begin 
+                    append lst (replace_atom (car s) rep) ;
+                    loop (cdr s)
+                  end
+              | _ -> ()
+          in
+            loop (cdr sexp);
+            lst
+        end
+    | _ ->
+        let rec loop tmp =
+          match tmp with
+              Cons (_) ->
+                begin
+                  let item = (car tmp) in
+                  let atom = (car item) in
+                  let replacement = (car (cdr item)) in
+                    if (name atom) = (name sexp) then
+                      replacement
+                    else
+                      loop (cdr tmp)
+                end
+            | _ -> sexp
+        in
+          loop rep      
+
+let interleave c1 c2 =
+  let lst = cons (cons (car c1) (cons (car c2) Null)) Null in
+  let c1' = cdr c1 in
+  let c2' = cdr c2 in
+
+  let rec loop a b =
+    match a with
+        Cons (_) ->
+          begin
+            append lst (cons (car a) (cons (car b) Null)) ;
+            loop (cdr a) (cdr b)
+          end
+      | _ -> ()
+
+  in
+    loop c1' c2' ;
+    lst        
+
+

lexer.mll

@@ -0,0 +1,14 @@
+{
+  open Parser
+  exception Eof
+}
+
+rule token = parse
+    [' ' '\t' '\n'] { token lexbuf }
+  | '(' { LPAREN }
+  | ')' { RPAREN }
+  | ';' [^ '\n']* { token lexbuf } (* comments *)
+  | ['A'-'z' '0'-'9' '*']+ { NAME(Lexing.lexeme lexbuf) }
+  | eof { raise Eof }
+
+

main.ml

@@ -0,0 +1,40 @@
+open Builtins
+open Environment
+open Sexp
+
+let lisp_read inp =
+  let lexbuf = Lexing.from_channel inp in
+    Parser.main Lexer.token lexbuf
+
+let make_cell n fn =
+  (cons (Atom n) (cons (Func fn) Null))
+
+let init_env () =
+  let env = cons (make_cell "QUOTE" fn_quote) Null in
+  let cells =
+    [ make_cell "CAR" fn_car ;
+      make_cell "CDR" fn_cdr ;
+      make_cell "CONS" fn_cons ;
+      make_cell "EQUAL" fn_equal ;
+      make_cell "ATOM" fn_atom ;
+      make_cell "COND" fn_cond ;
+      make_cell "LAMBDA" fn_lambda ;
+      make_cell "LABEL" fn_label ]
+  in
+    List.iter (append env) cells ;
+    env
+
+let _ =
+  let env = init_env () in
+  let chin = stdin 
+  in
+    while true do
+      (try
+         Printf.printf "> " ;
+         lisp_print (eval (lisp_read chin) env) 
+       with
+           Parsing.Parse_error -> Printf.printf "Parser error" 
+         | Lexer.Eof -> exit 0);
+      Printf.printf "\n"            
+    done
+

parser.mly

@@ -0,0 +1,29 @@
+%token <string> NAME
+%token LPAREN RPAREN EOF
+%start main
+%type <Sexp.t> main
+
+%%
+
+main:
+  sexp { $1 }
+  ;
+
+sexp:
+  list { $1 }
+| atom { $1 }
+;
+
+list:
+  LPAREN RPAREN { Sexp.Null }
+| LPAREN inside_list RPAREN { $2 }
+
+inside_list:
+  | sexp { Sexp.cons $1 Sexp.Null } 
+  | sexp inside_list { Sexp.cons $1 $2 }
+;
+
+atom: NAME { Sexp.Atom $1 }
+;
+
+

sexp.ml

@@ -0,0 +1,25 @@
+type ('a, 'b) cell = { mutable car: 'a; mutable cdr: 'b }
+
+type t = Atom of string
+         | Cons of (t, t) cell
+         | Func of (t -> t -> t)
+         | Lambda of t * t
+         | Null
+
+let car o =
+  match o with
+      Cons (c) -> c.car
+    | _ -> invalid_arg "Argument to car must be a Cons!"
+
+let cdr o =
+  match o with
+      Cons (c) -> c.cdr
+    | _ -> invalid_arg "Argument to cdr must be a Cons!"
+
+let cons first second = Cons { car = first ; cdr = second }
+
+let name o =
+  match o with
+      Atom (s) -> s
+    | _ -> invalid_arg "Argument to name must be an Atom!"
+