From ca51c4f77235d8f9b8606ebc8c255778c83c9050 Mon Sep 17 00:00:00 2001 From: Chouser Date: Wed, 21 Jan 2015 20:53:51 -0500 Subject: OCaml: add step 0 --- .gitignore | 2 ++ Makefile | 4 +++- ocaml/step0_repl.ml | 23 +++++++++++++++++++++++ 3 files changed, 28 insertions(+), 1 deletion(-) create mode 100644 ocaml/step0_repl.ml diff --git a/.gitignore b/.gitignore index 34b9b72..44ee760 100644 --- a/.gitignore +++ b/.gitignore @@ -28,6 +28,8 @@ go/step* go/mal java/target/ java/dependency-reduced-pom.xml +ocaml/*.cmi +ocaml/*.swp rust/target/ rust/mal rust/Cargo.lock diff --git a/Makefile b/Makefile index 572bd25..b3d6278 100644 --- a/Makefile +++ b/Makefile @@ -11,7 +11,7 @@ PYTHON = python # IMPLS = bash c clojure coffee cs go haskell java js lua make mal \ - perl php ps python r racket ruby rust scala vb + ocaml perl php ps python r racket ruby rust scala vb step0 = step0_repl step1 = step1_read_print @@ -60,6 +60,7 @@ js_STEP_TO_PROG = js/$($(1)).js lua_STEP_TO_PROG = lua/$($(1)).lua make_STEP_TO_PROG = make/$($(1)).mk mal_STEP_TO_PROG = mal/$($(1)).mal +ocaml_STEP_TO_PROG = ocaml/$($(1)).ml perl_STEP_TO_PROG = perl/$($(1)).pl php_STEP_TO_PROG = php/$($(1)).php ps_STEP_TO_PROG = ps/$($(1)).ps @@ -84,6 +85,7 @@ js_RUNSTEP = node ../$(2) $(3) lua_RUNSTEP = ../$(2) $(3) make_RUNSTEP = make -f ../$(2) $(3) mal_RUNSTEP = $(call $(MAL_IMPL)_RUNSTEP,$(1),$(call $(MAL_IMPL)_STEP_TO_PROG,stepA),../$(2),") #" +ocaml_RUNSTEP = ocaml ../$(2) $(3) perl_RUNSTEP = perl ../$(2) --raw $(3) php_RUNSTEP = php ../$(2) $(3) ps_RUNSTEP = $(4)gs -q -I./ -dNODISPLAY -- ../$(2) $(3)$(4) diff --git a/ocaml/step0_repl.ml b/ocaml/step0_repl.ml new file mode 100644 index 0000000..e3478f7 --- /dev/null +++ b/ocaml/step0_repl.ml @@ -0,0 +1,23 @@ +(* + To try things at the ocaml repl: + rlwrap ocaml + + To see type signatures of all functions: + ocamlc -i step0_repl.ml + + To run the program: + ocaml step0_repl.ml +*) + +let read str = str +let eval ast any = ast +let print exp = exp +let rep str = print (eval (read str) "") + +let rec main = + try + while true do + print_string "user> "; + print_endline (rep (read_line ())); + done + with End_of_file -> () -- cgit v1.2.3 From 59d10e1bd703f65e12fef85bceef4204f82685fb Mon Sep 17 00:00:00 2001 From: Chouser Date: Thu, 22 Jan 2015 02:59:48 -0500 Subject: Ocaml: Added step 1, missing some optional functionality --- .gitignore | 1 + Makefile | 4 +-- ocaml/Makefile | 16 ++++++++++++ ocaml/printer.ml | 15 +++++++++++ ocaml/reader.ml | 66 +++++++++++++++++++++++++++++++++++++++++++++++ ocaml/step1_read_print.ml | 15 +++++++++++ ocaml/types.ml | 8 ++++++ 7 files changed, 123 insertions(+), 2 deletions(-) create mode 100644 ocaml/Makefile create mode 100644 ocaml/printer.ml create mode 100644 ocaml/reader.ml create mode 100644 ocaml/step1_read_print.ml create mode 100644 ocaml/types.ml diff --git a/.gitignore b/.gitignore index 44ee760..49aa62f 100644 --- a/.gitignore +++ b/.gitignore @@ -29,6 +29,7 @@ go/mal java/target/ java/dependency-reduced-pom.xml ocaml/*.cmi +ocaml/*.cmo ocaml/*.swp rust/target/ rust/mal diff --git a/Makefile b/Makefile index b3d6278..a0b2f7b 100644 --- a/Makefile +++ b/Makefile @@ -60,7 +60,7 @@ js_STEP_TO_PROG = js/$($(1)).js lua_STEP_TO_PROG = lua/$($(1)).lua make_STEP_TO_PROG = make/$($(1)).mk mal_STEP_TO_PROG = mal/$($(1)).mal -ocaml_STEP_TO_PROG = ocaml/$($(1)).ml +ocaml_STEP_TO_PROG = ocaml/$($(1)) perl_STEP_TO_PROG = perl/$($(1)).pl php_STEP_TO_PROG = php/$($(1)).php ps_STEP_TO_PROG = ps/$($(1)).ps @@ -85,7 +85,7 @@ js_RUNSTEP = node ../$(2) $(3) lua_RUNSTEP = ../$(2) $(3) make_RUNSTEP = make -f ../$(2) $(3) mal_RUNSTEP = $(call $(MAL_IMPL)_RUNSTEP,$(1),$(call $(MAL_IMPL)_STEP_TO_PROG,stepA),../$(2),") #" -ocaml_RUNSTEP = ocaml ../$(2) $(3) +ocaml_RUNSTEP = ../$(2) $(3) perl_RUNSTEP = perl ../$(2) --raw $(3) php_RUNSTEP = php ../$(2) $(3) ps_RUNSTEP = $(4)gs -q -I./ -dNODISPLAY -- ../$(2) $(3)$(4) diff --git a/ocaml/Makefile b/ocaml/Makefile new file mode 100644 index 0000000..a46b82a --- /dev/null +++ b/ocaml/Makefile @@ -0,0 +1,16 @@ +STEPS = step0_repl.ml step1_read_print.ml +MODULES = types.ml reader.ml printer.ml +LIBS = str.cma + +BINS = $(STEPS:%.ml=%) + +all: $(BINS) mal oc + +mal: $(word $(words $(BINS)),$(BINS)) + cp $< $@ + +$(BINS): %: %.ml $(MODULES) + ocamlc $(LIBS) $(MODULES) $< -o $@ + +clean: + rm -f $(BINS) mal *.cmi *.cmo diff --git a/ocaml/printer.ml b/ocaml/printer.ml new file mode 100644 index 0000000..30e4415 --- /dev/null +++ b/ocaml/printer.ml @@ -0,0 +1,15 @@ +let join sep xs = + List.fold_left (fun a x -> if a = "" then x else a ^ sep ^ x) "" xs + +let rec pr_str mal_obj = + match mal_obj with + | Types.Int i -> string_of_int i + | Types.Symbol s -> s + | Types.Keyword s -> ":" ^ s + | Types.Nil -> "nil" + | Types.Bool true -> "true" + | Types.Bool false -> "false" + | Types.String s -> "\"" + ^ (Str.global_replace (Str.regexp "\"") "\\\"" s) + ^ "\"" + | Types.MalList xs -> "(" ^ (join " " (List.map pr_str xs)) ^ ")" diff --git a/ocaml/reader.ml b/ocaml/reader.ml new file mode 100644 index 0000000..51ab522 --- /dev/null +++ b/ocaml/reader.ml @@ -0,0 +1,66 @@ +let find_re re str = + List.map (function | Str.Delim x -> x | Str.Text x -> "impossible!") + (List.filter (function | Str.Delim x -> true | Str.Text x -> false) + (Str.full_split re str)) ;; + +let token_re = (Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"\\|;.*\\|[^][ \n{}('\"`,;)]*") + +type reader = { + form : Types.mal_type; + tokens : string list; +} + +type list_reader = { + list_form : Types.mal_type list; + tokens : string list; +} + +let read_atom token = + match token with + | "nil" -> Types.Nil + | "true" -> Types.Bool true + | "false" -> Types.Bool false + | _ -> + match token.[0] with + | '0'..'9' -> Types.Int (int_of_string token) + | '"' -> Types.String (Str.global_replace (Str.regexp "\\\\\\(.\\)") + "\\1" + (String.sub token 1 ((String.length token) - 2))) + | ':' -> Types.Keyword (Str.replace_first (Str.regexp "^:") "" token) + | _ -> Types.Symbol token + +let rec read_list list_reader = + match list_reader.tokens with + | [] -> output_string stderr "expected ')', got EOF\n"; + flush stderr; + raise End_of_file; + | token :: tokens -> + if Str.string_match (Str.regexp "[])}]") token 0 then + {list_form = list_reader.list_form; tokens = tokens} + else + let reader = read_form list_reader.tokens in + read_list {list_form = list_reader.list_form @ [reader.form]; + tokens = reader.tokens} +and read_quote sym tokens = + let reader = read_form tokens in + {form = Types.MalList [ Types.Symbol sym; reader.form ]; + tokens = reader.tokens} +and read_form all_tokens = + match all_tokens with + | [] -> raise End_of_file; + | token :: tokens -> + match token with + | "'" -> read_quote "quote" tokens + | "`" -> read_quote "quasiquote" tokens + | "~" -> read_quote "unquote" tokens + | "~@" -> read_quote "splice-unquote" tokens + | _ -> + match token.[0] with + | '[' | '(' | '{' -> let list_reader = + read_list {list_form = []; tokens = tokens} in + {form = Types.MalList list_reader.list_form; + tokens = list_reader.tokens} + | _ -> {form = read_atom token; tokens = tokens} + +let read_str str = (read_form (List.filter ((<>) "") (find_re token_re str))).form + diff --git a/ocaml/step1_read_print.ml b/ocaml/step1_read_print.ml new file mode 100644 index 0000000..6cbbb16 --- /dev/null +++ b/ocaml/step1_read_print.ml @@ -0,0 +1,15 @@ +let read str = Reader.read_str str +let eval ast any = ast +let print exp = Printer.pr_str exp +let rep str = print (eval (read str) "") + +let rec main = + try + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line); + with End_of_file -> () + done + with End_of_file -> () diff --git a/ocaml/types.ml b/ocaml/types.ml new file mode 100644 index 0000000..92f3030 --- /dev/null +++ b/ocaml/types.ml @@ -0,0 +1,8 @@ +type mal_type = + | MalList of mal_type list + | Int of int + | Symbol of string + | Keyword of string + | Nil + | Bool of bool + | String of string -- cgit v1.2.3 From 921a951fe4d088e60ce25866344bd534420f9ec6 Mon Sep 17 00:00:00 2001 From: Chouser Date: Thu, 22 Jan 2015 02:59:48 -0500 Subject: Ocaml: Add step 2, nothing optional --- ocaml/Makefile | 7 +++++-- ocaml/printer.ml | 1 + ocaml/reader.ml | 26 ++++++++++++-------------- ocaml/step2_eval.ml | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++ ocaml/types.ml | 1 + 5 files changed, 69 insertions(+), 16 deletions(-) create mode 100644 ocaml/step2_eval.ml diff --git a/ocaml/Makefile b/ocaml/Makefile index a46b82a..a526ecf 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -1,14 +1,17 @@ -STEPS = step0_repl.ml step1_read_print.ml +STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml MODULES = types.ml reader.ml printer.ml LIBS = str.cma BINS = $(STEPS:%.ml=%) -all: $(BINS) mal oc +all: $(BINS) mal mal: $(word $(words $(BINS)),$(BINS)) cp $< $@ +repl: $(MODULES) + rlwrap ocaml $(LIBS) $(MODULES:%.ml=%.cmo) + $(BINS): %: %.ml $(MODULES) ocamlc $(LIBS) $(MODULES) $< -o $@ diff --git a/ocaml/printer.ml b/ocaml/printer.ml index 30e4415..e87b3eb 100644 --- a/ocaml/printer.ml +++ b/ocaml/printer.ml @@ -13,3 +13,4 @@ let rec pr_str mal_obj = ^ (Str.global_replace (Str.regexp "\"") "\\\"" s) ^ "\"" | Types.MalList xs -> "(" ^ (join " " (List.map pr_str xs)) ^ ")" + | Types.Fn f -> "" diff --git a/ocaml/reader.ml b/ocaml/reader.ml index 51ab522..c32fa91 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -3,7 +3,7 @@ let find_re re str = (List.filter (function | Str.Delim x -> true | Str.Text x -> false) (Str.full_split re str)) ;; -let token_re = (Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"\\|;.*\\|[^][ \n{}('\"`,;)]*") +let token_re = (Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"\\|;.*\\|[^][ \n{}('\"`,;)]*") type reader = { form : Types.mal_type; @@ -36,11 +36,11 @@ let rec read_list list_reader = raise End_of_file; | token :: tokens -> if Str.string_match (Str.regexp "[])}]") token 0 then - {list_form = list_reader.list_form; tokens = tokens} + {list_form = list_reader.list_form; tokens = tokens} else - let reader = read_form list_reader.tokens in + let reader = read_form list_reader.tokens in read_list {list_form = list_reader.list_form @ [reader.form]; - tokens = reader.tokens} + tokens = reader.tokens} and read_quote sym tokens = let reader = read_form tokens in {form = Types.MalList [ Types.Symbol sym; reader.form ]; @@ -50,17 +50,15 @@ and read_form all_tokens = | [] -> raise End_of_file; | token :: tokens -> match token with - | "'" -> read_quote "quote" tokens - | "`" -> read_quote "quasiquote" tokens - | "~" -> read_quote "unquote" tokens + | "'" -> read_quote "quote" tokens + | "`" -> read_quote "quasiquote" tokens + | "~" -> read_quote "unquote" tokens | "~@" -> read_quote "splice-unquote" tokens - | _ -> - match token.[0] with - | '[' | '(' | '{' -> let list_reader = - read_list {list_form = []; tokens = tokens} in - {form = Types.MalList list_reader.list_form; - tokens = list_reader.tokens} - | _ -> {form = read_atom token; tokens = tokens} + | "[" | "(" | "{" -> let list_reader = + read_list {list_form = []; tokens = tokens} in + {form = Types.MalList list_reader.list_form; + tokens = list_reader.tokens} + | _ -> {form = read_atom token; tokens = tokens} let read_str str = (read_form (List.filter ((<>) "") (find_re token_re str))).form diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml new file mode 100644 index 0000000..4337a11 --- /dev/null +++ b/ocaml/step2_eval.ml @@ -0,0 +1,50 @@ +module Env = + Map.Make ( + String + (*(struct + type t = Types.Symbol + let compare (Types.Symbol a) (Types.Symbol b) = compare a b + end)*) + ) + +let num_fun f = Types.Fn + (function + | [(Types.Int a); (Types.Int b)] -> Types.Int (f a b) + | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) + +let env = ref (List.fold_left (fun a b -> b a) Env.empty + [ Env.add "+" (num_fun ( + )); + Env.add "-" (num_fun ( - )); + Env.add "*" (num_fun ( * )); + Env.add "/" (num_fun ( / )) ]) + +let rec eval_ast ast env = + match ast with + | Types.Symbol s -> + (try Env.find s !env + with Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found"))) + | Types.MalList xs -> Types.MalList (List.map (fun x -> eval x env) xs) + | _ -> ast +and eval ast env = + let result = eval_ast ast env in + match result with + | Types.MalList ((Types.Fn f) :: args) -> (f args) + | _ -> result + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp +let rep str env = print (eval (read str) env) + +let rec main = + try + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + done + with End_of_file -> () diff --git a/ocaml/types.ml b/ocaml/types.ml index 92f3030..60d3725 100644 --- a/ocaml/types.ml +++ b/ocaml/types.ml @@ -6,3 +6,4 @@ type mal_type = | Nil | Bool of bool | String of string + | Fn of (mal_type list -> mal_type) -- cgit v1.2.3 From 81e073cf2044d0e3cfbcc03a81dcba605a945fe5 Mon Sep 17 00:00:00 2001 From: Chouser Date: Thu, 22 Jan 2015 15:55:22 -0500 Subject: Ocaml: made minor fixes, mostly to Makefile --- ocaml/Makefile | 14 ++++++++------ ocaml/step2_eval.ml | 4 ++-- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/ocaml/Makefile b/ocaml/Makefile index a526ecf..c905b2e 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -2,18 +2,20 @@ STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml MODULES = types.ml reader.ml printer.ml LIBS = str.cma -BINS = $(STEPS:%.ml=%) +STEP_BINS = $(STEPS:%.ml=%) +LAST_STEP_BIN = $(word $(words $(STEP_BINS)),$(STEP_BINS)) +MODULE_BINS = $(MODULES:%.ml=%.cmo) -all: $(BINS) mal +all: $(STEP_BINS) mal -mal: $(word $(words $(BINS)),$(BINS)) +mal: $(LAST_STEP_BIN) cp $< $@ repl: $(MODULES) - rlwrap ocaml $(LIBS) $(MODULES:%.ml=%.cmo) + rlwrap ocaml $(LIBS) $(MODULE_BINS) -$(BINS): %: %.ml $(MODULES) +$(STEP_BINS): %: %.ml $(MODULES) ocamlc $(LIBS) $(MODULES) $< -o $@ clean: - rm -f $(BINS) mal *.cmi *.cmo + rm -f $(STEP_BINS) mal *.cmi *.cmo diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml index 4337a11..02866eb 100644 --- a/ocaml/step2_eval.ml +++ b/ocaml/step2_eval.ml @@ -12,7 +12,7 @@ let num_fun f = Types.Fn | [(Types.Int a); (Types.Int b)] -> Types.Int (f a b) | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) -let env = ref (List.fold_left (fun a b -> b a) Env.empty +let repl_env = ref (List.fold_left (fun a b -> b a) Env.empty [ Env.add "+" (num_fun ( + )); Env.add "-" (num_fun ( - )); Env.add "*" (num_fun ( * )); @@ -41,7 +41,7 @@ let rec main = print_string "user> "; let line = read_line () in try - print_endline (rep line env); + print_endline (rep line repl_env); with End_of_file -> () | Invalid_argument x -> output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); -- cgit v1.2.3 From 67736cf90b4f977b4b3ca3801e079040fc9fc0c9 Mon Sep 17 00:00:00 2001 From: Chouser Date: Fri, 23 Jan 2015 08:17:35 -0500 Subject: Ocaml: Add step 3 --- ocaml/Makefile | 4 ++-- ocaml/env.ml | 33 +++++++++++++++++++++++++++++++ ocaml/step3_env.ml | 58 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 93 insertions(+), 2 deletions(-) create mode 100644 ocaml/env.ml create mode 100644 ocaml/step3_env.ml diff --git a/ocaml/Makefile b/ocaml/Makefile index c905b2e..f7df3a7 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -1,5 +1,5 @@ -STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml -MODULES = types.ml reader.ml printer.ml +STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml +MODULES = types.ml reader.ml printer.ml env.ml LIBS = str.cma STEP_BINS = $(STEPS:%.ml=%) diff --git a/ocaml/env.ml b/ocaml/env.ml new file mode 100644 index 0000000..d4388ad --- /dev/null +++ b/ocaml/env.ml @@ -0,0 +1,33 @@ +module Data = Map.Make (String) + +type env = { + outer : env option; + data : Types.mal_type Data.t ref; +} + +let make outer = { outer = outer; data = ref Data.empty } + +let set env sym value = + match sym with + | Types.Symbol key -> env.data := Data.add key value !(env.data) + | _ -> raise (Invalid_argument "set requires a Symbol for its key") + +let rec find env sym = + match sym with + | Types.Symbol key -> + (if Data.mem key !(env.data) then + Some env + else + match env.outer with + | Some outer -> find outer sym + | None -> None) + | _ -> raise (Invalid_argument "find requires a Symbol for its key") + +let get env sym = + match sym with + | Types.Symbol key -> + (match find env sym with + | Some found_env -> Data.find key !(found_env.data) + | None -> raise (Invalid_argument ("Symbol '" ^ key ^ "' not found"))) + | _ -> raise (Invalid_argument "get requires a Symbol for its key") + diff --git a/ocaml/step3_env.ml b/ocaml/step3_env.ml new file mode 100644 index 0000000..862cae6 --- /dev/null +++ b/ocaml/step3_env.ml @@ -0,0 +1,58 @@ +let num_fun f = Types.Fn + (function + | [(Types.Int a); (Types.Int b)] -> Types.Int (f a b) + | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) + +let repl_env = Env.make None + +let init_repl env = begin + Env.set env (Types.Symbol "+") (num_fun ( + )); + Env.set env (Types.Symbol "-") (num_fun ( - )); + Env.set env (Types.Symbol "*") (num_fun ( * )); + Env.set env (Types.Symbol "/") (num_fun ( / )); +end + +let rec eval_ast ast env = + match ast with + | Types.Symbol s -> Env.get env ast + | Types.MalList xs -> Types.MalList (List.map (fun x -> eval x env) xs) + | _ -> ast +and eval ast env = + match ast with + | Types.MalList [(Types.Symbol "def!"); key; expr] -> + let value = (eval expr env) in + Env.set env key value; value + | Types.MalList [(Types.Symbol "let*"); (Types.MalList bindings); body] -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | Types.MalList _ -> + (match eval_ast ast env with + | Types.MalList ((Types.Fn f) :: args) -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | _ -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp +let rep str env = print (eval (read str) env) + +let rec main = + try + init_repl repl_env; + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + done + with End_of_file -> () -- cgit v1.2.3 From 79ba3d608878cf99d4a61960ae0a29e2e4a96745 Mon Sep 17 00:00:00 2001 From: Chouser Date: Fri, 23 Jan 2015 16:55:06 -0500 Subject: Ocaml: Finally fix race conditions in compilation Also, use native compilation for everything except Ocaml REPL. --- .gitignore | 3 +++ ocaml/Makefile | 22 +++++++++++++++------- 2 files changed, 18 insertions(+), 7 deletions(-) diff --git a/.gitignore b/.gitignore index 49aa62f..07d7921 100644 --- a/.gitignore +++ b/.gitignore @@ -31,6 +31,9 @@ java/dependency-reduced-pom.xml ocaml/*.cmi ocaml/*.cmo ocaml/*.swp +ocaml/*.cmx +ocaml/*.o +ocaml/mal_lib.* rust/target/ rust/mal rust/Cargo.lock diff --git a/ocaml/Makefile b/ocaml/Makefile index f7df3a7..5e8b62a 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -1,21 +1,29 @@ STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml MODULES = types.ml reader.ml printer.ml env.ml -LIBS = str.cma +LIBS = str.cmxa +MAL_LIB = mal_lib.cmxa STEP_BINS = $(STEPS:%.ml=%) LAST_STEP_BIN = $(word $(words $(STEP_BINS)),$(STEP_BINS)) -MODULE_BINS = $(MODULES:%.ml=%.cmo) all: $(STEP_BINS) mal mal: $(LAST_STEP_BIN) cp $< $@ -repl: $(MODULES) - rlwrap ocaml $(LIBS) $(MODULE_BINS) +# ocaml repl apparently needs bytecode, not native, compilation. +# Just do it all right here: +repl: + ocamlc -c $(LIBS:%.cmxa=%.cma) $(MODULES) $(STEPS) + rlwrap ocaml $(LIBS:%.cmxa=%.cma) $(MODULES:%.ml=%.cmo) -$(STEP_BINS): %: %.ml $(MODULES) - ocamlc $(LIBS) $(MODULES) $< -o $@ +$(MAL_LIB): $(MODULES) + ocamlopt -a $(MODULES) -o $@ + +$(STEP_BINS): %: %.ml $(MAL_LIB) + ocamlopt $(LIBS) $(MAL_LIB) $< -o $@ clean: - rm -f $(STEP_BINS) mal *.cmi *.cmo + rm -f $(STEP_BINS) mal mal_lib.* *.cmo *.cmx *.cmi *.o + +.PHONY: all repl clean -- cgit v1.2.3 From 9115534dc73fe18a12b3b2ecf436051b76bdd8a4 Mon Sep 17 00:00:00 2001 From: Chouser Date: Fri, 23 Jan 2015 18:11:45 -0500 Subject: Ocaml: Add step 4, but not str fns or optionals. --- ocaml/core.ml | 32 +++++++++++++++++++++++ ocaml/step4_if_fn_do.ml | 67 +++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 99 insertions(+) create mode 100644 ocaml/core.ml create mode 100644 ocaml/step4_if_fn_do.ml diff --git a/ocaml/core.ml b/ocaml/core.ml new file mode 100644 index 0000000..4cec7f1 --- /dev/null +++ b/ocaml/core.ml @@ -0,0 +1,32 @@ +let ns = Env.make None + +let num_fun t f = Types.Fn + (function + | [(Types.Int a); (Types.Int b)] -> t (f a b) + | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) + +let mk_int x = Types.Int x +let mk_bool x = Types.Bool x + +let init env = begin + Env.set env (Types.Symbol "+") (num_fun mk_int ( + )); + Env.set env (Types.Symbol "-") (num_fun mk_int ( - )); + Env.set env (Types.Symbol "*") (num_fun mk_int ( * )); + Env.set env (Types.Symbol "/") (num_fun mk_int ( / )); + Env.set env (Types.Symbol "<") (num_fun mk_bool ( < )); + Env.set env (Types.Symbol "<=") (num_fun mk_bool ( <= )); + Env.set env (Types.Symbol ">") (num_fun mk_bool ( > )); + Env.set env (Types.Symbol ">=") (num_fun mk_bool ( >= )); + + Env.set env (Types.Symbol "list") (Types.Fn (function xs -> Types.MalList xs)); + Env.set env (Types.Symbol "list?") + (Types.Fn (function [Types.MalList _] -> Types.Bool true | _ -> Types.Bool false)); + Env.set env (Types.Symbol "empty?") + (Types.Fn (function [Types.MalList []] -> Types.Bool true | _ -> Types.Bool false)); + Env.set env (Types.Symbol "count") + (Types.Fn (function [Types.MalList xs] -> Types.Int (List.length xs) | _ -> Types.Int 0)); + Env.set env (Types.Symbol "=") + (Types.Fn (function [a; b] -> Types.Bool (a = b) | _ -> Types.Bool false)); + +end + diff --git a/ocaml/step4_if_fn_do.ml b/ocaml/step4_if_fn_do.ml new file mode 100644 index 0000000..1e5e87d --- /dev/null +++ b/ocaml/step4_if_fn_do.ml @@ -0,0 +1,67 @@ +let repl_env = Env.make (Some Core.ns) + +let rec eval_ast ast env = + match ast with + | Types.Symbol s -> Env.get env ast + | Types.MalList xs -> Types.MalList (List.map (fun x -> eval x env) xs) + | _ -> ast +and eval ast env = + match ast with + | Types.MalList [(Types.Symbol "def!"); key; expr] -> + let value = (eval expr env) in + Env.set env key value; value + | Types.MalList [(Types.Symbol "let*"); (Types.MalList bindings); body] -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | Types.MalList ((Types.Symbol "do") :: body) -> + List.fold_left (fun x expr -> eval expr env) Types.Nil body + | Types.MalList [Types.Symbol "if"; test; then_expr; else_expr] -> + if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) + | Types.MalList [Types.Symbol "if"; test; then_expr] -> + if Types.to_bool (eval test env) then (eval then_expr env) else Types.Nil + | Types.MalList [Types.Symbol "fn*"; Types.MalList arg_names; expr] -> + Types.Fn + (function args -> + let sub_env = Env.make (Some env) in + let rec bind_args = (fun a b -> + (match a, b with + | [Types.Symbol "&"; name], args -> Env.set sub_env name (Types.MalList args); + | (name :: names), (arg :: args) -> + Env.set sub_env name arg; + bind_args names args; + | [], [] -> () + | _ -> raise (Invalid_argument "Bad param count in fn call"))) + in (bind_args arg_names args); + eval expr sub_env) + | Types.MalList _ -> + (match eval_ast ast env with + | Types.MalList ((Types.Fn f) :: args) -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | _ -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp +let rep str env = print (eval (read str) env) + +let rec main = + try + Core.init Core.ns; + ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + done + with End_of_file -> () -- cgit v1.2.3 From de04357cd5f2954e2d682abb97ca2b3b90ea75d1 Mon Sep 17 00:00:00 2001 From: Chouser Date: Fri, 23 Jan 2015 20:05:03 -0500 Subject: Ocaml: Add string functions --- ocaml/Makefile | 5 +++-- ocaml/core.ml | 14 ++++++++++++++ ocaml/printer.ml | 14 ++++++++------ ocaml/step1_read_print.ml | 2 +- ocaml/step2_eval.ml | 2 +- ocaml/step3_env.ml | 2 +- ocaml/step4_if_fn_do.ml | 8 ++++---- ocaml/types.ml | 4 ++++ 8 files changed, 36 insertions(+), 15 deletions(-) diff --git a/ocaml/Makefile b/ocaml/Makefile index 5e8b62a..bad3f60 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -1,5 +1,6 @@ -STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml -MODULES = types.ml reader.ml printer.ml env.ml +STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \ + step4_if_fn_do.ml +MODULES = types.ml reader.ml printer.ml env.ml core.ml LIBS = str.cmxa MAL_LIB = mal_lib.cmxa diff --git a/ocaml/core.ml b/ocaml/core.ml index 4cec7f1..c11c9f9 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -28,5 +28,19 @@ let init env = begin Env.set env (Types.Symbol "=") (Types.Fn (function [a; b] -> Types.Bool (a = b) | _ -> Types.Bool false)); + Env.set env (Types.Symbol "pr-str") + (Types.Fn (function xs -> + Types.String (Printer.join " " (List.map (fun s -> Printer.pr_str s true) xs)))); + Env.set env (Types.Symbol "str") + (Types.Fn (function xs -> + Types.String (Printer.join "" (List.map (fun s -> Printer.pr_str s false) xs)))); + Env.set env (Types.Symbol "prn") + (Types.Fn (function xs -> + print_endline (Printer.join " " (List.map (fun s -> Printer.pr_str s true) xs)); + Types.Nil)); + Env.set env (Types.Symbol "println") + (Types.Fn (function xs -> + print_endline (Printer.join " " (List.map (fun s -> Printer.pr_str s false) xs)); + Types.Nil)); end diff --git a/ocaml/printer.ml b/ocaml/printer.ml index e87b3eb..fc9e47b 100644 --- a/ocaml/printer.ml +++ b/ocaml/printer.ml @@ -1,7 +1,7 @@ let join sep xs = List.fold_left (fun a x -> if a = "" then x else a ^ sep ^ x) "" xs -let rec pr_str mal_obj = +let rec pr_str mal_obj print_readably = match mal_obj with | Types.Int i -> string_of_int i | Types.Symbol s -> s @@ -9,8 +9,10 @@ let rec pr_str mal_obj = | Types.Nil -> "nil" | Types.Bool true -> "true" | Types.Bool false -> "false" - | Types.String s -> "\"" - ^ (Str.global_replace (Str.regexp "\"") "\\\"" s) - ^ "\"" - | Types.MalList xs -> "(" ^ (join " " (List.map pr_str xs)) ^ ")" - | Types.Fn f -> "" + | Types.String s -> + if print_readably + then "\"" ^ (Str.global_replace (Str.regexp "\\([\"\\]\\)") "\\\\\\1" s) ^ "\"" + else s + | Types.MalList xs -> + "(" ^ (join " " (List.map (fun s -> pr_str s print_readably) xs)) ^ ")" + | Types.Fn f -> "#" diff --git a/ocaml/step1_read_print.ml b/ocaml/step1_read_print.ml index 6cbbb16..1735e11 100644 --- a/ocaml/step1_read_print.ml +++ b/ocaml/step1_read_print.ml @@ -1,6 +1,6 @@ let read str = Reader.read_str str let eval ast any = ast -let print exp = Printer.pr_str exp +let print exp = Printer.pr_str exp true let rep str = print (eval (read str) "") let rec main = diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml index 02866eb..af8667c 100644 --- a/ocaml/step2_eval.ml +++ b/ocaml/step2_eval.ml @@ -32,7 +32,7 @@ and eval ast env = | _ -> result let read str = Reader.read_str str -let print exp = Printer.pr_str exp +let print exp = Printer.pr_str exp true let rep str env = print (eval (read str) env) let rec main = diff --git a/ocaml/step3_env.ml b/ocaml/step3_env.ml index 862cae6..d7939bf 100644 --- a/ocaml/step3_env.ml +++ b/ocaml/step3_env.ml @@ -39,7 +39,7 @@ and eval ast env = | _ -> eval_ast ast env let read str = Reader.read_str str -let print exp = Printer.pr_str exp +let print exp = Printer.pr_str exp true let rep str env = print (eval (read str) env) let rec main = diff --git a/ocaml/step4_if_fn_do.ml b/ocaml/step4_if_fn_do.ml index 1e5e87d..6580dd6 100644 --- a/ocaml/step4_if_fn_do.ml +++ b/ocaml/step4_if_fn_do.ml @@ -30,15 +30,15 @@ and eval ast env = Types.Fn (function args -> let sub_env = Env.make (Some env) in - let rec bind_args = (fun a b -> + let rec bind_args a b = (match a, b with | [Types.Symbol "&"; name], args -> Env.set sub_env name (Types.MalList args); | (name :: names), (arg :: args) -> Env.set sub_env name arg; bind_args names args; | [], [] -> () - | _ -> raise (Invalid_argument "Bad param count in fn call"))) - in (bind_args arg_names args); + | _ -> raise (Invalid_argument "Bad param count in fn call")) + in bind_args arg_names args; eval expr sub_env) | Types.MalList _ -> (match eval_ast ast env with @@ -47,7 +47,7 @@ and eval ast env = | _ -> eval_ast ast env let read str = Reader.read_str str -let print exp = Printer.pr_str exp +let print exp = Printer.pr_str exp true let rep str env = print (eval (read str) env) let rec main = diff --git a/ocaml/types.ml b/ocaml/types.ml index 60d3725..badfee3 100644 --- a/ocaml/types.ml +++ b/ocaml/types.ml @@ -7,3 +7,7 @@ type mal_type = | Bool of bool | String of string | Fn of (mal_type list -> mal_type) + +let to_bool x = match x with + | Nil | Bool false -> false + | _ -> true -- cgit v1.2.3 From f2f11f6279e1b242ba75136cd037fabdd176118a Mon Sep 17 00:00:00 2001 From: Chouser Date: Fri, 23 Jan 2015 22:54:15 -0500 Subject: Ocaml: rename Types.MalList to Types.List --- ocaml/core.ml | 8 ++++---- ocaml/printer.ml | 2 +- ocaml/reader.ml | 4 ++-- ocaml/step2_eval.ml | 4 ++-- ocaml/step3_env.ml | 10 +++++----- ocaml/step4_if_fn_do.ml | 20 ++++++++++---------- ocaml/types.ml | 2 +- 7 files changed, 25 insertions(+), 25 deletions(-) diff --git a/ocaml/core.ml b/ocaml/core.ml index c11c9f9..db3424a 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -18,13 +18,13 @@ let init env = begin Env.set env (Types.Symbol ">") (num_fun mk_bool ( > )); Env.set env (Types.Symbol ">=") (num_fun mk_bool ( >= )); - Env.set env (Types.Symbol "list") (Types.Fn (function xs -> Types.MalList xs)); + Env.set env (Types.Symbol "list") (Types.Fn (function xs -> Types.List xs)); Env.set env (Types.Symbol "list?") - (Types.Fn (function [Types.MalList _] -> Types.Bool true | _ -> Types.Bool false)); + (Types.Fn (function [Types.List _] -> Types.Bool true | _ -> Types.Bool false)); Env.set env (Types.Symbol "empty?") - (Types.Fn (function [Types.MalList []] -> Types.Bool true | _ -> Types.Bool false)); + (Types.Fn (function [Types.List []] -> Types.Bool true | _ -> Types.Bool false)); Env.set env (Types.Symbol "count") - (Types.Fn (function [Types.MalList xs] -> Types.Int (List.length xs) | _ -> Types.Int 0)); + (Types.Fn (function [Types.List xs] -> Types.Int (List.length xs) | _ -> Types.Int 0)); Env.set env (Types.Symbol "=") (Types.Fn (function [a; b] -> Types.Bool (a = b) | _ -> Types.Bool false)); diff --git a/ocaml/printer.ml b/ocaml/printer.ml index fc9e47b..59c025d 100644 --- a/ocaml/printer.ml +++ b/ocaml/printer.ml @@ -13,6 +13,6 @@ let rec pr_str mal_obj print_readably = if print_readably then "\"" ^ (Str.global_replace (Str.regexp "\\([\"\\]\\)") "\\\\\\1" s) ^ "\"" else s - | Types.MalList xs -> + | Types.List xs -> "(" ^ (join " " (List.map (fun s -> pr_str s print_readably) xs)) ^ ")" | Types.Fn f -> "#" diff --git a/ocaml/reader.ml b/ocaml/reader.ml index c32fa91..58e72fe 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -43,7 +43,7 @@ let rec read_list list_reader = tokens = reader.tokens} and read_quote sym tokens = let reader = read_form tokens in - {form = Types.MalList [ Types.Symbol sym; reader.form ]; + {form = Types.List [ Types.Symbol sym; reader.form ]; tokens = reader.tokens} and read_form all_tokens = match all_tokens with @@ -56,7 +56,7 @@ and read_form all_tokens = | "~@" -> read_quote "splice-unquote" tokens | "[" | "(" | "{" -> let list_reader = read_list {list_form = []; tokens = tokens} in - {form = Types.MalList list_reader.list_form; + {form = Types.List list_reader.list_form; tokens = list_reader.tokens} | _ -> {form = read_atom token; tokens = tokens} diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml index af8667c..d5ec9a3 100644 --- a/ocaml/step2_eval.ml +++ b/ocaml/step2_eval.ml @@ -23,12 +23,12 @@ let rec eval_ast ast env = | Types.Symbol s -> (try Env.find s !env with Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found"))) - | Types.MalList xs -> Types.MalList (List.map (fun x -> eval x env) xs) + | Types.List xs -> Types.List (List.map (fun x -> eval x env) xs) | _ -> ast and eval ast env = let result = eval_ast ast env in match result with - | Types.MalList ((Types.Fn f) :: args) -> (f args) + | Types.List ((Types.Fn f) :: args) -> (f args) | _ -> result let read str = Reader.read_str str diff --git a/ocaml/step3_env.ml b/ocaml/step3_env.ml index d7939bf..3f64cae 100644 --- a/ocaml/step3_env.ml +++ b/ocaml/step3_env.ml @@ -15,14 +15,14 @@ end let rec eval_ast ast env = match ast with | Types.Symbol s -> Env.get env ast - | Types.MalList xs -> Types.MalList (List.map (fun x -> eval x env) xs) + | Types.List xs -> Types.List (List.map (fun x -> eval x env) xs) | _ -> ast and eval ast env = match ast with - | Types.MalList [(Types.Symbol "def!"); key; expr] -> + | Types.List [(Types.Symbol "def!"); key; expr] -> let value = (eval expr env) in Env.set env key value; value - | Types.MalList [(Types.Symbol "let*"); (Types.MalList bindings); body] -> + | Types.List [(Types.Symbol "let*"); (Types.List bindings); body] -> (let sub_env = Env.make (Some env) in let rec bind_pairs = (function | sym :: expr :: more -> @@ -32,9 +32,9 @@ and eval ast env = | [] -> ()) in bind_pairs bindings; eval body sub_env) - | Types.MalList _ -> + | Types.List _ -> (match eval_ast ast env with - | Types.MalList ((Types.Fn f) :: args) -> f args + | Types.List ((Types.Fn f) :: args) -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env diff --git a/ocaml/step4_if_fn_do.ml b/ocaml/step4_if_fn_do.ml index 6580dd6..bf8a5ab 100644 --- a/ocaml/step4_if_fn_do.ml +++ b/ocaml/step4_if_fn_do.ml @@ -3,14 +3,14 @@ let repl_env = Env.make (Some Core.ns) let rec eval_ast ast env = match ast with | Types.Symbol s -> Env.get env ast - | Types.MalList xs -> Types.MalList (List.map (fun x -> eval x env) xs) + | Types.List xs -> Types.List (List.map (fun x -> eval x env) xs) | _ -> ast and eval ast env = match ast with - | Types.MalList [(Types.Symbol "def!"); key; expr] -> + | Types.List [(Types.Symbol "def!"); key; expr] -> let value = (eval expr env) in Env.set env key value; value - | Types.MalList [(Types.Symbol "let*"); (Types.MalList bindings); body] -> + | Types.List [(Types.Symbol "let*"); (Types.List bindings); body] -> (let sub_env = Env.make (Some env) in let rec bind_pairs = (function | sym :: expr :: more -> @@ -20,19 +20,19 @@ and eval ast env = | [] -> ()) in bind_pairs bindings; eval body sub_env) - | Types.MalList ((Types.Symbol "do") :: body) -> + | Types.List ((Types.Symbol "do") :: body) -> List.fold_left (fun x expr -> eval expr env) Types.Nil body - | Types.MalList [Types.Symbol "if"; test; then_expr; else_expr] -> + | Types.List [Types.Symbol "if"; test; then_expr; else_expr] -> if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) - | Types.MalList [Types.Symbol "if"; test; then_expr] -> + | Types.List [Types.Symbol "if"; test; then_expr] -> if Types.to_bool (eval test env) then (eval then_expr env) else Types.Nil - | Types.MalList [Types.Symbol "fn*"; Types.MalList arg_names; expr] -> + | Types.List [Types.Symbol "fn*"; Types.List arg_names; expr] -> Types.Fn (function args -> let sub_env = Env.make (Some env) in let rec bind_args a b = (match a, b with - | [Types.Symbol "&"; name], args -> Env.set sub_env name (Types.MalList args); + | [Types.Symbol "&"; name], args -> Env.set sub_env name (Types.List args); | (name :: names), (arg :: args) -> Env.set sub_env name arg; bind_args names args; @@ -40,9 +40,9 @@ and eval ast env = | _ -> raise (Invalid_argument "Bad param count in fn call")) in bind_args arg_names args; eval expr sub_env) - | Types.MalList _ -> + | Types.List _ -> (match eval_ast ast env with - | Types.MalList ((Types.Fn f) :: args) -> f args + | Types.List ((Types.Fn f) :: args) -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env diff --git a/ocaml/types.ml b/ocaml/types.ml index badfee3..34dba05 100644 --- a/ocaml/types.ml +++ b/ocaml/types.ml @@ -1,5 +1,5 @@ type mal_type = - | MalList of mal_type list + | List of mal_type list | Int of int | Symbol of string | Keyword of string -- cgit v1.2.3 From b7ffcab96166f15d6203551ffbc487da5076f92e Mon Sep 17 00:00:00 2001 From: Chouser Date: Sat, 24 Jan 2015 00:44:51 -0500 Subject: Ocaml: Add read, print for vector, map --- ocaml/printer.ml | 14 +++++++++++++- ocaml/reader.ml | 10 +++++++++- ocaml/types.ml | 2 ++ 3 files changed, 24 insertions(+), 2 deletions(-) diff --git a/ocaml/printer.ml b/ocaml/printer.ml index 59c025d..1257a69 100644 --- a/ocaml/printer.ml +++ b/ocaml/printer.ml @@ -1,7 +1,16 @@ let join sep xs = List.fold_left (fun a x -> if a = "" then x else a ^ sep ^ x) "" xs -let rec pr_str mal_obj print_readably = +let rec pr_pairs xs str print_readably = match xs with + | k :: v :: more -> pr_pairs more ((if str = "" then str else (str ^ ", ")) + ^ (pr_str k print_readably) + ^ " " + ^ (pr_str v print_readably)) + print_readably + | _ :: [] -> raise (Invalid_argument "Partition requires even number of items") + | [] -> str + +and pr_str mal_obj print_readably = match mal_obj with | Types.Int i -> string_of_int i | Types.Symbol s -> s @@ -15,4 +24,7 @@ let rec pr_str mal_obj print_readably = else s | Types.List xs -> "(" ^ (join " " (List.map (fun s -> pr_str s print_readably) xs)) ^ ")" + | Types.Vector xs -> + "[" ^ (join " " (List.map (fun s -> pr_str s print_readably) xs)) ^ "]" + | Types.Map xs -> "{" ^ pr_pairs xs "" print_readably ^ "}" | Types.Fn f -> "#" diff --git a/ocaml/reader.ml b/ocaml/reader.ml index 58e72fe..c452e05 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -54,10 +54,18 @@ and read_form all_tokens = | "`" -> read_quote "quasiquote" tokens | "~" -> read_quote "unquote" tokens | "~@" -> read_quote "splice-unquote" tokens - | "[" | "(" | "{" -> let list_reader = + | "(" -> let list_reader = read_list {list_form = []; tokens = tokens} in {form = Types.List list_reader.list_form; tokens = list_reader.tokens} + | "{" -> let list_reader = + read_list {list_form = []; tokens = tokens} in + {form = Types.Map list_reader.list_form; + tokens = list_reader.tokens} + | "[" -> let list_reader = + read_list {list_form = []; tokens = tokens} in + {form = Types.Vector list_reader.list_form; + tokens = list_reader.tokens} | _ -> {form = read_atom token; tokens = tokens} let read_str str = (read_form (List.filter ((<>) "") (find_re token_re str))).form diff --git a/ocaml/types.ml b/ocaml/types.ml index 34dba05..6440580 100644 --- a/ocaml/types.ml +++ b/ocaml/types.ml @@ -1,5 +1,7 @@ type mal_type = | List of mal_type list + | Vector of mal_type list + | Map of mal_type list | Int of int | Symbol of string | Keyword of string -- cgit v1.2.3 From a878f3bb778513c0cc8bbeb1a8ff61664e43de29 Mon Sep 17 00:00:00 2001 From: Chouser Date: Sun, 25 Jan 2015 23:30:37 -0500 Subject: Ocaml: Use a real map type T.Map is now a real OCaml binary-tree map, and supports arbitrary mal value types for both keys and values. Metadata support is provided in the data objects, but not yet in the printer, reader, or core library. --- ocaml/core.ml | 70 ++++++++++++++++++++++++++----------------------- ocaml/env.ml | 8 +++--- ocaml/printer.ml | 51 +++++++++++++++++------------------ ocaml/reader.ml | 26 ++++++++++-------- ocaml/step2_eval.ml | 12 +++++---- ocaml/step3_env.ml | 26 +++++++++--------- ocaml/step4_if_fn_do.ml | 30 +++++++++++---------- ocaml/types.ml | 55 +++++++++++++++++++++++++++++--------- 8 files changed, 160 insertions(+), 118 deletions(-) diff --git a/ocaml/core.ml b/ocaml/core.ml index db3424a..95e2f4c 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -1,46 +1,50 @@ +module T = Types.Types let ns = Env.make None -let num_fun t f = Types.Fn +let num_fun t f = T.Fn (function - | [(Types.Int a); (Types.Int b)] -> t (f a b) + | [(T.Int a); (T.Int b)] -> t (f a b) | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) -let mk_int x = Types.Int x -let mk_bool x = Types.Bool x +let mk_int x = T.Int x +let mk_bool x = T.Bool x let init env = begin - Env.set env (Types.Symbol "+") (num_fun mk_int ( + )); - Env.set env (Types.Symbol "-") (num_fun mk_int ( - )); - Env.set env (Types.Symbol "*") (num_fun mk_int ( * )); - Env.set env (Types.Symbol "/") (num_fun mk_int ( / )); - Env.set env (Types.Symbol "<") (num_fun mk_bool ( < )); - Env.set env (Types.Symbol "<=") (num_fun mk_bool ( <= )); - Env.set env (Types.Symbol ">") (num_fun mk_bool ( > )); - Env.set env (Types.Symbol ">=") (num_fun mk_bool ( >= )); + Env.set env (Types.symbol "+") (num_fun mk_int ( + )); + Env.set env (Types.symbol "-") (num_fun mk_int ( - )); + Env.set env (Types.symbol "*") (num_fun mk_int ( * )); + Env.set env (Types.symbol "/") (num_fun mk_int ( / )); + Env.set env (Types.symbol "<") (num_fun mk_bool ( < )); + Env.set env (Types.symbol "<=") (num_fun mk_bool ( <= )); + Env.set env (Types.symbol ">") (num_fun mk_bool ( > )); + Env.set env (Types.symbol ">=") (num_fun mk_bool ( >= )); - Env.set env (Types.Symbol "list") (Types.Fn (function xs -> Types.List xs)); - Env.set env (Types.Symbol "list?") - (Types.Fn (function [Types.List _] -> Types.Bool true | _ -> Types.Bool false)); - Env.set env (Types.Symbol "empty?") - (Types.Fn (function [Types.List []] -> Types.Bool true | _ -> Types.Bool false)); - Env.set env (Types.Symbol "count") - (Types.Fn (function [Types.List xs] -> Types.Int (List.length xs) | _ -> Types.Int 0)); - Env.set env (Types.Symbol "=") - (Types.Fn (function [a; b] -> Types.Bool (a = b) | _ -> Types.Bool false)); + Env.set env (Types.symbol "list") (T.Fn (function xs -> Types.list xs)); + Env.set env (Types.symbol "list?") + (T.Fn (function [T.List _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "empty?") + (T.Fn (function [T.List {T.value = []}] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "count") + (T.Fn (function [T.List {T.value = xs}] -> T.Int (List.length xs) | _ -> T.Int 0)); + Env.set env (Types.symbol "=") + (T.Fn (function [a; b] -> T.Bool (a = b) | _ -> T.Bool false)); - Env.set env (Types.Symbol "pr-str") - (Types.Fn (function xs -> - Types.String (Printer.join " " (List.map (fun s -> Printer.pr_str s true) xs)))); - Env.set env (Types.Symbol "str") - (Types.Fn (function xs -> - Types.String (Printer.join "" (List.map (fun s -> Printer.pr_str s false) xs)))); - Env.set env (Types.Symbol "prn") - (Types.Fn (function xs -> + Env.set env (Types.symbol "pr-str") + (T.Fn (function xs -> + T.String (Printer.join " " (List.map (fun s -> Printer.pr_str s true) xs)))); + Env.set env (Types.symbol "str") + (T.Fn (function xs -> + T.String (Printer.join "" (List.map (fun s -> Printer.pr_str s false) xs)))); + Env.set env (Types.symbol "prn") + (T.Fn (function xs -> print_endline (Printer.join " " (List.map (fun s -> Printer.pr_str s true) xs)); - Types.Nil)); - Env.set env (Types.Symbol "println") - (Types.Fn (function xs -> + T.Nil)); + Env.set env (Types.symbol "println") + (T.Fn (function xs -> print_endline (Printer.join " " (List.map (fun s -> Printer.pr_str s false) xs)); - Types.Nil)); + T.Nil)); + + Env.set env (Types.symbol "compare") + (T.Fn (function [a; b] -> T.Int (compare a b))); end diff --git a/ocaml/env.ml b/ocaml/env.ml index d4388ad..97f9cc8 100644 --- a/ocaml/env.ml +++ b/ocaml/env.ml @@ -1,3 +1,4 @@ +module T = Types.Types module Data = Map.Make (String) type env = { @@ -9,12 +10,12 @@ let make outer = { outer = outer; data = ref Data.empty } let set env sym value = match sym with - | Types.Symbol key -> env.data := Data.add key value !(env.data) + | T.Symbol { T.value = key } -> env.data := Data.add key value !(env.data) | _ -> raise (Invalid_argument "set requires a Symbol for its key") let rec find env sym = match sym with - | Types.Symbol key -> + | T.Symbol { T.value = key } -> (if Data.mem key !(env.data) then Some env else @@ -25,9 +26,8 @@ let rec find env sym = let get env sym = match sym with - | Types.Symbol key -> + | T.Symbol { T.value = key } -> (match find env sym with | Some found_env -> Data.find key !(found_env.data) | None -> raise (Invalid_argument ("Symbol '" ^ key ^ "' not found"))) | _ -> raise (Invalid_argument "get requires a Symbol for its key") - diff --git a/ocaml/printer.ml b/ocaml/printer.ml index 1257a69..3e09019 100644 --- a/ocaml/printer.ml +++ b/ocaml/printer.ml @@ -1,30 +1,27 @@ +module T = Types.Types + let join sep xs = List.fold_left (fun a x -> if a = "" then x else a ^ sep ^ x) "" xs -let rec pr_pairs xs str print_readably = match xs with - | k :: v :: more -> pr_pairs more ((if str = "" then str else (str ^ ", ")) - ^ (pr_str k print_readably) - ^ " " - ^ (pr_str v print_readably)) - print_readably - | _ :: [] -> raise (Invalid_argument "Partition requires even number of items") - | [] -> str - -and pr_str mal_obj print_readably = - match mal_obj with - | Types.Int i -> string_of_int i - | Types.Symbol s -> s - | Types.Keyword s -> ":" ^ s - | Types.Nil -> "nil" - | Types.Bool true -> "true" - | Types.Bool false -> "false" - | Types.String s -> - if print_readably - then "\"" ^ (Str.global_replace (Str.regexp "\\([\"\\]\\)") "\\\\\\1" s) ^ "\"" - else s - | Types.List xs -> - "(" ^ (join " " (List.map (fun s -> pr_str s print_readably) xs)) ^ ")" - | Types.Vector xs -> - "[" ^ (join " " (List.map (fun s -> pr_str s print_readably) xs)) ^ "]" - | Types.Map xs -> "{" ^ pr_pairs xs "" print_readably ^ "}" - | Types.Fn f -> "#" +let rec pr_str mal_obj print_readably = + let r = print_readably in + match mal_obj with + | T.Int i -> string_of_int i + | T.Symbol { T.value = s } -> s + | T.Keyword s -> ":" ^ s + | T.Nil -> "nil" + | T.Bool true -> "true" + | T.Bool false -> "false" + | T.String s -> + if r + then "\"" ^ (Str.global_replace (Str.regexp "\\([\"\\]\\)") "\\\\\\1" s) ^ "\"" + else s + | T.List { T.value = xs } -> + "(" ^ (join " " (List.map (fun s -> pr_str s r) xs)) ^ ")" + | T.Vector { T.value = xs } -> + "[" ^ (join " " (List.map (fun s -> pr_str s r) xs)) ^ "]" + | T.Map { T.value = xs } -> + (Types.MalMap.fold (fun k v s -> s ^ (if s = "" then "{" else ", ") ^ (pr_str k r) + ^ " " ^ (pr_str v r)) xs "") + ^ "}" + | T.Fn f -> "#" diff --git a/ocaml/reader.ml b/ocaml/reader.ml index c452e05..6827597 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -1,3 +1,6 @@ +module T = Types.Types + (* ^file ^module *) + let find_re re str = List.map (function | Str.Delim x -> x | Str.Text x -> "impossible!") (List.filter (function | Str.Delim x -> true | Str.Text x -> false) @@ -17,17 +20,17 @@ type list_reader = { let read_atom token = match token with - | "nil" -> Types.Nil - | "true" -> Types.Bool true - | "false" -> Types.Bool false + | "nil" -> T.Nil + | "true" -> T.Bool true + | "false" -> T.Bool false | _ -> match token.[0] with - | '0'..'9' -> Types.Int (int_of_string token) - | '"' -> Types.String (Str.global_replace (Str.regexp "\\\\\\(.\\)") + | '0'..'9' -> T.Int (int_of_string token) + | '"' -> T.String (Str.global_replace (Str.regexp "\\\\\\(.\\)") "\\1" (String.sub token 1 ((String.length token) - 2))) - | ':' -> Types.Keyword (Str.replace_first (Str.regexp "^:") "" token) - | _ -> Types.Symbol token + | ':' -> T.Keyword (Str.replace_first (Str.regexp "^:") "" token) + | _ -> Types.symbol token let rec read_list list_reader = match list_reader.tokens with @@ -43,7 +46,7 @@ let rec read_list list_reader = tokens = reader.tokens} and read_quote sym tokens = let reader = read_form tokens in - {form = Types.List [ Types.Symbol sym; reader.form ]; + {form = Types.list [ Types.symbol sym; reader.form ]; tokens = reader.tokens} and read_form all_tokens = match all_tokens with @@ -54,17 +57,18 @@ and read_form all_tokens = | "`" -> read_quote "quasiquote" tokens | "~" -> read_quote "unquote" tokens | "~@" -> read_quote "splice-unquote" tokens + | "@" -> read_quote "deref" tokens | "(" -> let list_reader = read_list {list_form = []; tokens = tokens} in - {form = Types.List list_reader.list_form; + {form = Types.list list_reader.list_form; tokens = list_reader.tokens} | "{" -> let list_reader = read_list {list_form = []; tokens = tokens} in - {form = Types.Map list_reader.list_form; + {form = Types.list_into_map Types.MalMap.empty list_reader.list_form; tokens = list_reader.tokens} | "[" -> let list_reader = read_list {list_form = []; tokens = tokens} in - {form = Types.Vector list_reader.list_form; + {form = Types.vector list_reader.list_form; tokens = list_reader.tokens} | _ -> {form = read_atom token; tokens = tokens} diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml index d5ec9a3..7be4a3e 100644 --- a/ocaml/step2_eval.ml +++ b/ocaml/step2_eval.ml @@ -1,3 +1,5 @@ +module T = Types.Types + module Env = Map.Make ( String @@ -7,9 +9,9 @@ module Env = end)*) ) -let num_fun f = Types.Fn +let num_fun f = T.Fn (function - | [(Types.Int a); (Types.Int b)] -> Types.Int (f a b) + | [(T.Int a); (T.Int b)] -> T.Int (f a b) | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) let repl_env = ref (List.fold_left (fun a b -> b a) Env.empty @@ -20,15 +22,15 @@ let repl_env = ref (List.fold_left (fun a b -> b a) Env.empty let rec eval_ast ast env = match ast with - | Types.Symbol s -> + | T.Symbol { T.value = s } -> (try Env.find s !env with Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found"))) - | Types.List xs -> Types.List (List.map (fun x -> eval x env) xs) + | T.List { T.value = xs } -> Types.list (List.map (fun x -> eval x env) xs) | _ -> ast and eval ast env = let result = eval_ast ast env in match result with - | Types.List ((Types.Fn f) :: args) -> (f args) + | T.List { T.value = ((T.Fn f) :: args) } -> (f args) | _ -> result let read str = Reader.read_str str diff --git a/ocaml/step3_env.ml b/ocaml/step3_env.ml index 3f64cae..3bb0be0 100644 --- a/ocaml/step3_env.ml +++ b/ocaml/step3_env.ml @@ -1,28 +1,30 @@ -let num_fun f = Types.Fn +module T = Types.Types + +let num_fun f = T.Fn (function - | [(Types.Int a); (Types.Int b)] -> Types.Int (f a b) + | [(T.Int a); (T.Int b)] -> T.Int (f a b) | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) let repl_env = Env.make None let init_repl env = begin - Env.set env (Types.Symbol "+") (num_fun ( + )); - Env.set env (Types.Symbol "-") (num_fun ( - )); - Env.set env (Types.Symbol "*") (num_fun ( * )); - Env.set env (Types.Symbol "/") (num_fun ( / )); + Env.set env (Types.symbol "+") (num_fun ( + )); + Env.set env (Types.symbol "-") (num_fun ( - )); + Env.set env (Types.symbol "*") (num_fun ( * )); + Env.set env (Types.symbol "/") (num_fun ( / )); end let rec eval_ast ast env = match ast with - | Types.Symbol s -> Env.get env ast - | Types.List xs -> Types.List (List.map (fun x -> eval x env) xs) + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs } -> Types.list (List.map (fun x -> eval x env) xs) | _ -> ast and eval ast env = match ast with - | Types.List [(Types.Symbol "def!"); key; expr] -> + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> let value = (eval expr env) in Env.set env key value; value - | Types.List [(Types.Symbol "let*"); (Types.List bindings); body] -> + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> (let sub_env = Env.make (Some env) in let rec bind_pairs = (function | sym :: expr :: more -> @@ -32,9 +34,9 @@ and eval ast env = | [] -> ()) in bind_pairs bindings; eval body sub_env) - | Types.List _ -> + | T.List _ -> (match eval_ast ast env with - | Types.List ((Types.Fn f) :: args) -> f args + | T.List { T.value = ((T.Fn f) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env diff --git a/ocaml/step4_if_fn_do.ml b/ocaml/step4_if_fn_do.ml index bf8a5ab..72ac09d 100644 --- a/ocaml/step4_if_fn_do.ml +++ b/ocaml/step4_if_fn_do.ml @@ -1,16 +1,18 @@ +module T = Types.Types + let repl_env = Env.make (Some Core.ns) let rec eval_ast ast env = match ast with - | Types.Symbol s -> Env.get env ast - | Types.List xs -> Types.List (List.map (fun x -> eval x env) xs) + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs } -> Types.list (List.map (fun x -> eval x env) xs) | _ -> ast and eval ast env = match ast with - | Types.List [(Types.Symbol "def!"); key; expr] -> + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> let value = (eval expr env) in Env.set env key value; value - | Types.List [(Types.Symbol "let*"); (Types.List bindings); body] -> + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> (let sub_env = Env.make (Some env) in let rec bind_pairs = (function | sym :: expr :: more -> @@ -20,19 +22,19 @@ and eval ast env = | [] -> ()) in bind_pairs bindings; eval body sub_env) - | Types.List ((Types.Symbol "do") :: body) -> - List.fold_left (fun x expr -> eval expr env) Types.Nil body - | Types.List [Types.Symbol "if"; test; then_expr; else_expr] -> + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) - | Types.List [Types.Symbol "if"; test; then_expr] -> - if Types.to_bool (eval test env) then (eval then_expr env) else Types.Nil - | Types.List [Types.Symbol "fn*"; Types.List arg_names; expr] -> - Types.Fn + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + T.Fn (function args -> let sub_env = Env.make (Some env) in let rec bind_args a b = (match a, b with - | [Types.Symbol "&"; name], args -> Env.set sub_env name (Types.List args); + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); | (name :: names), (arg :: args) -> Env.set sub_env name arg; bind_args names args; @@ -40,9 +42,9 @@ and eval ast env = | _ -> raise (Invalid_argument "Bad param count in fn call")) in bind_args arg_names args; eval expr sub_env) - | Types.List _ -> + | T.List _ -> (match eval_ast ast env with - | Types.List ((Types.Fn f) :: args) -> f args + | T.List { T.value = ((T.Fn f) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env diff --git a/ocaml/types.ml b/ocaml/types.ml index 6440580..287cc88 100644 --- a/ocaml/types.ml +++ b/ocaml/types.ml @@ -1,15 +1,46 @@ -type mal_type = - | List of mal_type list - | Vector of mal_type list - | Map of mal_type list - | Int of int - | Symbol of string - | Keyword of string - | Nil - | Bool of bool - | String of string - | Fn of (mal_type list -> mal_type) +module rec Types + : sig + type 'a with_meta = { value : 'a; meta : t } + and t = + | List of t list with_meta + | Vector of t list with_meta + | Map of t MalMap.t with_meta + | Int of int + | Symbol of string with_meta + | Keyword of string + | Nil + | Bool of bool + | String of string + | Fn of (t list -> t) + end = Types + +and MalValue + : sig + type t = Types.t + val compare : t -> t -> int + end + = struct + type t = Types.t + let compare = Pervasives.compare + end + +and MalMap + : Map.S with type key = MalValue.t + = Map.Make(MalValue) let to_bool x = match x with - | Nil | Bool false -> false + | Types.Nil | Types.Bool false -> false | _ -> true + +type mal_type = MalValue.t + +let list x = Types.List { Types.value = x; meta = Types.Nil } +let map x = Types.Map { Types.value = x; meta = Types.Nil } +let vector x = Types.Vector { Types.value = x; meta = Types.Nil } +let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil } + +let rec list_into_map target source = + match source with + | k :: v :: more -> list_into_map (MalMap.add k v target) more + | [] -> map target + | _ :: [] -> raise (Invalid_argument "Literal maps must contain an even number of forms") -- cgit v1.2.3 From e64878d0af10d7e391e2070ddd02756042bec7b9 Mon Sep 17 00:00:00 2001 From: Chouser Date: Mon, 26 Jan 2015 19:16:23 -0500 Subject: Ocaml: add meta, with-meta, and ^ reader support --- ocaml/core.ml | 6 +++++- ocaml/printer.ml | 8 ++++++++ ocaml/reader.ml | 24 ++++++++++++++++++------ 3 files changed, 31 insertions(+), 7 deletions(-) diff --git a/ocaml/core.ml b/ocaml/core.ml index 95e2f4c..f86c3e7 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -45,6 +45,10 @@ let init env = begin T.Nil)); Env.set env (Types.symbol "compare") - (T.Fn (function [a; b] -> T.Int (compare a b))); + (T.Fn (function [a; b] -> T.Int (compare a b) | _ -> T.Nil)); + Env.set env (Types.symbol "with-meta") + (T.Fn (function [a; b] -> Reader.with_meta a b | _ -> T.Nil)); + Env.set env (Types.symbol "meta") + (T.Fn (function [x] -> Printer.meta x | _ -> T.Nil)); end diff --git a/ocaml/printer.ml b/ocaml/printer.ml index 3e09019..d63e5f0 100644 --- a/ocaml/printer.ml +++ b/ocaml/printer.ml @@ -3,6 +3,14 @@ module T = Types.Types let join sep xs = List.fold_left (fun a x -> if a = "" then x else a ^ sep ^ x) "" xs +let meta obj = + match obj with + | T.List { T.meta = meta } -> meta + | T.Map { T.meta = meta } -> meta + | T.Vector { T.meta = meta } -> meta + | T.Symbol { T.meta = meta } -> meta + | _ -> T.Nil + let rec pr_str mal_obj print_readably = let r = print_readably in match mal_obj with diff --git a/ocaml/reader.ml b/ocaml/reader.ml index 6827597..a6c2366 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -32,6 +32,14 @@ let read_atom token = | ':' -> T.Keyword (Str.replace_first (Str.regexp "^:") "" token) | _ -> Types.symbol token +let with_meta obj meta = + match obj with + | T.List { T.value = value } -> T.List { T.value = value; T.meta = meta }; + | T.Map { T.value = value } -> T.Map { T.value = value; T.meta = meta }; + | T.Vector { T.value = value } -> T.Vector { T.value = value; T.meta = meta }; + | T.Symbol { T.value = value } -> T.Symbol { T.value = value; T.meta = meta }; + | _ -> raise (Invalid_argument "metadata not supported on this type") + let rec read_list list_reader = match list_reader.tokens with | [] -> output_string stderr "expected ')', got EOF\n"; @@ -58,16 +66,20 @@ and read_form all_tokens = | "~" -> read_quote "unquote" tokens | "~@" -> read_quote "splice-unquote" tokens | "@" -> read_quote "deref" tokens - | "(" -> let list_reader = - read_list {list_form = []; tokens = tokens} in + | "^" -> + let meta = read_form tokens in + let value = read_form meta.tokens in + {form = with_meta value.form meta.form; tokens = value.tokens} + | "(" -> + let list_reader = read_list {list_form = []; tokens = tokens} in {form = Types.list list_reader.list_form; tokens = list_reader.tokens} - | "{" -> let list_reader = - read_list {list_form = []; tokens = tokens} in + | "{" -> + let list_reader = read_list {list_form = []; tokens = tokens} in {form = Types.list_into_map Types.MalMap.empty list_reader.list_form; tokens = list_reader.tokens} - | "[" -> let list_reader = - read_list {list_form = []; tokens = tokens} in + | "[" -> + let list_reader = read_list {list_form = []; tokens = tokens} in {form = Types.vector list_reader.list_form; tokens = list_reader.tokens} | _ -> {form = read_atom token; tokens = tokens} -- cgit v1.2.3 From 04e33074cc516fe4b79a6319c7a211002902a846 Mon Sep 17 00:00:00 2001 From: Chouser Date: Mon, 26 Jan 2015 23:05:13 -0500 Subject: Ocaml: All optional tests passing up thru step 4 --- ocaml/core.ml | 6 +++++- ocaml/reader.ml | 4 +++- ocaml/step2_eval.ml | 16 +++++++++++++--- ocaml/step3_env.ml | 15 +++++++++++++-- ocaml/step4_if_fn_do.ml | 18 +++++++++++++++--- 5 files changed, 49 insertions(+), 10 deletions(-) diff --git a/ocaml/core.ml b/ocaml/core.ml index f86c3e7..5cf06ba 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -27,7 +27,11 @@ let init env = begin Env.set env (Types.symbol "count") (T.Fn (function [T.List {T.value = xs}] -> T.Int (List.length xs) | _ -> T.Int 0)); Env.set env (Types.symbol "=") - (T.Fn (function [a; b] -> T.Bool (a = b) | _ -> T.Bool false)); + (T.Fn (function + | [T.List a; T.Vector b] -> T.Bool (a = b) + | [T.Vector a; T.List b] -> T.Bool (a = b) + | [a; b] -> T.Bool (a = b) + | _ -> T.Bool false)); Env.set env (Types.symbol "pr-str") (T.Fn (function xs -> diff --git a/ocaml/reader.ml b/ocaml/reader.ml index a6c2366..9754444 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -69,7 +69,9 @@ and read_form all_tokens = | "^" -> let meta = read_form tokens in let value = read_form meta.tokens in - {form = with_meta value.form meta.form; tokens = value.tokens} + {(*form = with_meta value.form meta.form;*) + form = Types.list [Types.symbol "with-meta"; value.form; meta.form]; + tokens = value.tokens} | "(" -> let list_reader = read_list {list_form = []; tokens = tokens} in {form = Types.list list_reader.list_form; diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml index 7be4a3e..50751f9 100644 --- a/ocaml/step2_eval.ml +++ b/ocaml/step2_eval.ml @@ -23,9 +23,19 @@ let repl_env = ref (List.fold_left (fun a b -> b a) Env.empty let rec eval_ast ast env = match ast with | T.Symbol { T.value = s } -> - (try Env.find s !env - with Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found"))) - | T.List { T.value = xs } -> Types.list (List.map (fun x -> eval x env) xs) + (try Env.find s !env + with Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found"))) + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add (eval k env) (eval v env) m) + xs + Types.MalMap.empty)} | _ -> ast and eval ast env = let result = eval_ast ast env in diff --git a/ocaml/step3_env.ml b/ocaml/step3_env.ml index 3bb0be0..856a786 100644 --- a/ocaml/step3_env.ml +++ b/ocaml/step3_env.ml @@ -17,14 +17,25 @@ end let rec eval_ast ast env = match ast with | T.Symbol s -> Env.get env ast - | T.List { T.value = xs } -> Types.list (List.map (fun x -> eval x env) xs) + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add (eval k env) (eval v env) m) + xs + Types.MalMap.empty)} | _ -> ast and eval ast env = match ast with | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> let value = (eval expr env) in Env.set env key value; value - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> (let sub_env = Env.make (Some env) in let rec bind_pairs = (function | sym :: expr :: more -> diff --git a/ocaml/step4_if_fn_do.ml b/ocaml/step4_if_fn_do.ml index 72ac09d..a16649a 100644 --- a/ocaml/step4_if_fn_do.ml +++ b/ocaml/step4_if_fn_do.ml @@ -5,14 +5,25 @@ let repl_env = Env.make (Some Core.ns) let rec eval_ast ast env = match ast with | T.Symbol s -> Env.get env ast - | T.List { T.value = xs } -> Types.list (List.map (fun x -> eval x env) xs) + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add (eval k env) (eval v env) m) + xs + Types.MalMap.empty)} | _ -> ast and eval ast env = match ast with | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> let value = (eval expr env) in Env.set env key value; value - | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> (let sub_env = Env.make (Some env) in let rec bind_pairs = (function | sym :: expr :: more -> @@ -28,7 +39,8 @@ and eval ast env = if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil - | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> T.Fn (function args -> let sub_env = Env.make (Some env) in -- cgit v1.2.3 From 44d4e31fc8387a52918992ed40bd4b20d7646f39 Mon Sep 17 00:00:00 2001 From: Chouser Date: Tue, 27 Jan 2015 11:30:05 -0500 Subject: Ocaml: Add step 5, TCO worked automatically in Ocaml --- Makefile | 1 + ocaml/Makefile | 2 +- ocaml/step5_tco.ml | 1 + 3 files changed, 3 insertions(+), 1 deletion(-) create mode 120000 ocaml/step5_tco.ml diff --git a/Makefile b/Makefile index a0b2f7b..63fd693 100644 --- a/Makefile +++ b/Makefile @@ -34,6 +34,7 @@ EXCLUDE_TESTS += test^go^step5 # test completes, even at 100,000 EXCLUDE_TESTS += test^php^step5 # test completes, even at 100,000 EXCLUDE_TESTS += test^ruby^step5 # test completes, even at 100,000 EXCLUDE_TESTS += test^rust^step5 # no catching stack overflows +EXCLUDE_TESTS += test^ocaml^step5 # test completes, even at 1,000,000 # interop tests now implemented yet EXCLUDE_TESTS += test^cs^stepA test^java^stepA test^mal^stepA \ diff --git a/ocaml/Makefile b/ocaml/Makefile index bad3f60..299b2c4 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -1,5 +1,5 @@ STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \ - step4_if_fn_do.ml + step4_if_fn_do.ml step5_tco.ml MODULES = types.ml reader.ml printer.ml env.ml core.ml LIBS = str.cmxa MAL_LIB = mal_lib.cmxa diff --git a/ocaml/step5_tco.ml b/ocaml/step5_tco.ml new file mode 120000 index 0000000..ab0ca0b --- /dev/null +++ b/ocaml/step5_tco.ml @@ -0,0 +1 @@ +step4_if_fn_do.ml \ No newline at end of file -- cgit v1.2.3 From cc916d9d819d17cc47d34321440bf5a2683eac2e Mon Sep 17 00:00:00 2001 From: Chouser Date: Wed, 28 Jan 2015 08:24:52 -0500 Subject: Ocaml: Use builtin String.concat instead of own join fun --- ocaml/core.ml | 8 ++++---- ocaml/printer.ml | 7 ++----- 2 files changed, 6 insertions(+), 9 deletions(-) diff --git a/ocaml/core.ml b/ocaml/core.ml index 5cf06ba..f901228 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -35,17 +35,17 @@ let init env = begin Env.set env (Types.symbol "pr-str") (T.Fn (function xs -> - T.String (Printer.join " " (List.map (fun s -> Printer.pr_str s true) xs)))); + T.String (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs)))); Env.set env (Types.symbol "str") (T.Fn (function xs -> - T.String (Printer.join "" (List.map (fun s -> Printer.pr_str s false) xs)))); + T.String (String.concat "" (List.map (fun s -> Printer.pr_str s false) xs)))); Env.set env (Types.symbol "prn") (T.Fn (function xs -> - print_endline (Printer.join " " (List.map (fun s -> Printer.pr_str s true) xs)); + print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs)); T.Nil)); Env.set env (Types.symbol "println") (T.Fn (function xs -> - print_endline (Printer.join " " (List.map (fun s -> Printer.pr_str s false) xs)); + print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s false) xs)); T.Nil)); Env.set env (Types.symbol "compare") diff --git a/ocaml/printer.ml b/ocaml/printer.ml index d63e5f0..8e71376 100644 --- a/ocaml/printer.ml +++ b/ocaml/printer.ml @@ -1,8 +1,5 @@ module T = Types.Types -let join sep xs = - List.fold_left (fun a x -> if a = "" then x else a ^ sep ^ x) "" xs - let meta obj = match obj with | T.List { T.meta = meta } -> meta @@ -25,9 +22,9 @@ let rec pr_str mal_obj print_readably = then "\"" ^ (Str.global_replace (Str.regexp "\\([\"\\]\\)") "\\\\\\1" s) ^ "\"" else s | T.List { T.value = xs } -> - "(" ^ (join " " (List.map (fun s -> pr_str s r) xs)) ^ ")" + "(" ^ (String.concat " " (List.map (fun s -> pr_str s r) xs)) ^ ")" | T.Vector { T.value = xs } -> - "[" ^ (join " " (List.map (fun s -> pr_str s r) xs)) ^ "]" + "[" ^ (String.concat " " (List.map (fun s -> pr_str s r) xs)) ^ "]" | T.Map { T.value = xs } -> (Types.MalMap.fold (fun k v s -> s ^ (if s = "" then "{" else ", ") ^ (pr_str k r) ^ " " ^ (pr_str v r)) xs "") -- cgit v1.2.3 From 16b177329cac77136b236dfb3645e4be4e3df297 Mon Sep 17 00:00:00 2001 From: Chouser Date: Wed, 28 Jan 2015 08:27:32 -0500 Subject: Ocaml: fix string escaping and printing --- ocaml/printer.ml | 6 +++++- ocaml/reader.ml | 13 ++++++++++--- 2 files changed, 15 insertions(+), 4 deletions(-) diff --git a/ocaml/printer.ml b/ocaml/printer.ml index 8e71376..fe025af 100644 --- a/ocaml/printer.ml +++ b/ocaml/printer.ml @@ -19,7 +19,11 @@ let rec pr_str mal_obj print_readably = | T.Bool false -> "false" | T.String s -> if r - then "\"" ^ (Str.global_replace (Str.regexp "\\([\"\\]\\)") "\\\\\\1" s) ^ "\"" + then "\"" ^ (Reader.gsub (Str.regexp "\\([\"\\\n]\\)") + (function + | "\n" -> "\\n" + | x -> "\\" ^ x) + s) ^ "\"" else s | T.List { T.value = xs } -> "(" ^ (String.concat " " (List.map (fun s -> pr_str s r) xs)) ^ ")" diff --git a/ocaml/reader.ml b/ocaml/reader.ml index 9754444..96404aa 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -6,6 +6,11 @@ let find_re re str = (List.filter (function | Str.Delim x -> true | Str.Text x -> false) (Str.full_split re str)) ;; +let gsub re f str = + String.concat + "" (List.map (function | Str.Delim x -> f x | Str.Text x -> x) + (Str.full_split re str)) + let token_re = (Str.regexp "~@\\|[][{}()'`~^@]\\|\"\\(\\\\.\\|[^\"]\\)*\"\\|;.*\\|[^][ \n{}('\"`,;)]*") type reader = { @@ -26,9 +31,11 @@ let read_atom token = | _ -> match token.[0] with | '0'..'9' -> T.Int (int_of_string token) - | '"' -> T.String (Str.global_replace (Str.regexp "\\\\\\(.\\)") - "\\1" - (String.sub token 1 ((String.length token) - 2))) + | '"' -> T.String (gsub (Str.regexp "\\\\.") + (function + | "\\n" -> "\n" + | x -> String.sub x 1 1) + (String.sub token 1 ((String.length token) - 2))) | ':' -> T.Keyword (Str.replace_first (Str.regexp "^:") "" token) | _ -> Types.symbol token -- cgit v1.2.3 From 387da0bba9e58e35c6ab24a131b445d4330a8520 Mon Sep 17 00:00:00 2001 From: Chouser Date: Wed, 28 Jan 2015 09:06:53 -0500 Subject: Ocaml: fix list and comment parsing --- ocaml/reader.ml | 23 ++++++++++++++--------- 1 file changed, 14 insertions(+), 9 deletions(-) diff --git a/ocaml/reader.ml b/ocaml/reader.ml index 96404aa..0bb4328 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -47,18 +47,21 @@ let with_meta obj meta = | T.Symbol { T.value = value } -> T.Symbol { T.value = value; T.meta = meta }; | _ -> raise (Invalid_argument "metadata not supported on this type") -let rec read_list list_reader = +let rec read_list eol list_reader = match list_reader.tokens with - | [] -> output_string stderr "expected ')', got EOF\n"; + | [] -> output_string stderr ("expected '" ^ eol ^ "', got EOF\n"); flush stderr; raise End_of_file; | token :: tokens -> - if Str.string_match (Str.regexp "[])}]") token 0 then + if Str.string_match (Str.regexp eol) token 0 then {list_form = list_reader.list_form; tokens = tokens} + else if token.[0] = ';' then + read_list eol { list_form = list_reader.list_form; + tokens = tokens } else let reader = read_form list_reader.tokens in - read_list {list_form = list_reader.list_form @ [reader.form]; - tokens = reader.tokens} + read_list eol {list_form = list_reader.list_form @ [reader.form]; + tokens = reader.tokens} and read_quote sym tokens = let reader = read_form tokens in {form = Types.list [ Types.symbol sym; reader.form ]; @@ -80,18 +83,20 @@ and read_form all_tokens = form = Types.list [Types.symbol "with-meta"; value.form; meta.form]; tokens = value.tokens} | "(" -> - let list_reader = read_list {list_form = []; tokens = tokens} in + let list_reader = read_list ")" {list_form = []; tokens = tokens} in {form = Types.list list_reader.list_form; tokens = list_reader.tokens} | "{" -> - let list_reader = read_list {list_form = []; tokens = tokens} in + let list_reader = read_list "}" {list_form = []; tokens = tokens} in {form = Types.list_into_map Types.MalMap.empty list_reader.list_form; tokens = list_reader.tokens} | "[" -> - let list_reader = read_list {list_form = []; tokens = tokens} in + let list_reader = read_list "]" {list_form = []; tokens = tokens} in {form = Types.vector list_reader.list_form; tokens = list_reader.tokens} - | _ -> {form = read_atom token; tokens = tokens} + | _ -> if token.[0] = ';' + then read_form tokens + else {form = read_atom token; tokens = tokens} let read_str str = (read_form (List.filter ((<>) "") (find_re token_re str))).form -- cgit v1.2.3 From f64fac7bd1bcdfb0061dc983be4bd578f6d55856 Mon Sep 17 00:00:00 2001 From: Chouser Date: Wed, 28 Jan 2015 09:07:21 -0500 Subject: Ocaml: Add step 6 --- ocaml/step6_file.ml | 93 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 93 insertions(+) create mode 100644 ocaml/step6_file.ml diff --git a/ocaml/step6_file.ml b/ocaml/step6_file.ml new file mode 100644 index 0000000..af87eb0 --- /dev/null +++ b/ocaml/step6_file.ml @@ -0,0 +1,93 @@ +module T = Types.Types + +let repl_env = Env.make (Some Core.ns) + +let rec eval_ast ast env = + match ast with + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add (eval k env) (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + match ast with + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> + let value = (eval expr env) in + Env.set env key value; value + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + T.Fn + (function args -> + let sub_env = Env.make (Some env) in + let rec bind_args a b = + (match a, b with + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); + | (name :: names), (arg :: args) -> + Env.set sub_env name arg; + bind_args names args; + | [], [] -> () + | _ -> raise (Invalid_argument "Bad param count in fn call")) + in bind_args arg_names args; + eval expr sub_env) + | T.List _ -> + (match eval_ast ast env with + | T.List { T.value = ((T.Fn f) :: args) } -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | _ -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + Core.init Core.ns; + Env.set repl_env (Types.symbol "*ARGV*") + (Types.list (if Array.length Sys.argv > 1 + then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) + else [])); + Env.set repl_env (Types.symbol "eval") + (T.Fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); + let code = "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" + in print_endline code; ignore (rep code repl_env); + ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); + + if Array.length Sys.argv > 1 then + ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) + else + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + done + with End_of_file -> () -- cgit v1.2.3 From 776cf577064c2676e33987546f10c2be80b26344 Mon Sep 17 00:00:00 2001 From: Chouser Date: Wed, 28 Jan 2015 13:13:44 -0500 Subject: Ocaml: Finish adding step 6 --- ocaml/Makefile | 2 +- ocaml/reader.ml | 9 ++++++++- 2 files changed, 9 insertions(+), 2 deletions(-) diff --git a/ocaml/Makefile b/ocaml/Makefile index 299b2c4..ced6df4 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -1,5 +1,5 @@ STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \ - step4_if_fn_do.ml step5_tco.ml + step4_if_fn_do.ml step5_tco.ml step6_file.ml MODULES = types.ml reader.ml printer.ml env.ml core.ml LIBS = str.cmxa MAL_LIB = mal_lib.cmxa diff --git a/ocaml/reader.ml b/ocaml/reader.ml index 0bb4328..36f0b2a 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -1,10 +1,17 @@ module T = Types.Types (* ^file ^module *) +let slurp filename = + let chan = open_in filename in + let b = Buffer.create 27 in + Buffer.add_channel b chan (in_channel_length chan) ; + close_in chan ; + Buffer.contents b + let find_re re str = List.map (function | Str.Delim x -> x | Str.Text x -> "impossible!") (List.filter (function | Str.Delim x -> true | Str.Text x -> false) - (Str.full_split re str)) ;; + (Str.full_split re str)) let gsub re f str = String.concat -- cgit v1.2.3 From efb850b5d5f8072c95fd0dc67383ffa308504f7b Mon Sep 17 00:00:00 2001 From: Chouser Date: Wed, 28 Jan 2015 23:43:21 -0500 Subject: Ocaml: Add step 7 --- ocaml/Makefile | 2 +- ocaml/core.ml | 22 +++++++++++ ocaml/step7_quote.ml | 108 +++++++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 131 insertions(+), 1 deletion(-) create mode 100644 ocaml/step7_quote.ml diff --git a/ocaml/Makefile b/ocaml/Makefile index ced6df4..be51a88 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -1,5 +1,5 @@ STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \ - step4_if_fn_do.ml step5_tco.ml step6_file.ml + step4_if_fn_do.ml step5_tco.ml step6_file.ml step7_quote.ml MODULES = types.ml reader.ml printer.ml env.ml core.ml LIBS = str.cmxa MAL_LIB = mal_lib.cmxa diff --git a/ocaml/core.ml b/ocaml/core.ml index f901228..a5131ce 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -9,6 +9,13 @@ let num_fun t f = T.Fn let mk_int x = T.Int x let mk_bool x = T.Bool x +let seq = function + | T.List { T.value = xs } -> xs + | T.Vector { T.value = xs } -> xs + | T.Map { T.value = xs } -> + Types.MalMap.fold (fun k v list -> k :: v :: list) xs [] + | _ -> [] + let init env = begin Env.set env (Types.symbol "+") (num_fun mk_int ( + )); Env.set env (Types.symbol "-") (num_fun mk_int ( - )); @@ -54,5 +61,20 @@ let init env = begin (T.Fn (function [a; b] -> Reader.with_meta a b | _ -> T.Nil)); Env.set env (Types.symbol "meta") (T.Fn (function [x] -> Printer.meta x | _ -> T.Nil)); + + Env.set env (Types.symbol "read-string") + (T.Fn (function [T.String x] -> Reader.read_str x | _ -> T.Nil)); + Env.set env (Types.symbol "slurp") + (T.Fn (function [T.String x] -> T.String (Reader.slurp x) | _ -> T.Nil)); + + Env.set env (Types.symbol "cons") + (T.Fn (function [x; xs] -> Types.list (x :: (seq xs)) | _ -> T.Nil)); + Env.set env (Types.symbol "concat") + (T.Fn (let rec concat = + function + | x :: y :: more -> concat ((Types.list ((seq x) @ (seq y))) :: more) + | [x] -> x + | [] -> Types.list [] + in concat)); end diff --git a/ocaml/step7_quote.ml b/ocaml/step7_quote.ml new file mode 100644 index 0000000..d8b4518 --- /dev/null +++ b/ocaml/step7_quote.ml @@ -0,0 +1,108 @@ +module T = Types.Types + +let repl_env = Env.make (Some Core.ns) + +let rec quasiquote ast = + match ast with + | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast + | T.Vector { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast + | T.List { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } + | T.Vector { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } -> + Types.list [Types.symbol "concat"; head; quasiquote (Types.list tail)] + | T.List { T.value = head :: tail } + | T.Vector { T.value = head :: tail } -> + Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] + | ast -> Types.list [Types.symbol "quote"; ast] + +let rec eval_ast ast env = + match ast with + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add (eval k env) (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + match ast with + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> + let value = (eval expr env) in + Env.set env key value; value + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + T.Fn + (function args -> + let sub_env = Env.make (Some env) in + let rec bind_args a b = + (match a, b with + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); + | (name :: names), (arg :: args) -> + Env.set sub_env name arg; + bind_args names args; + | [], [] -> () + | _ -> raise (Invalid_argument "Bad param count in fn call")) + in bind_args arg_names args; + eval expr sub_env) + | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast + | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> + eval (quasiquote ast) env + | T.List _ -> + (match eval_ast ast env with + | T.List { T.value = ((T.Fn f) :: args) } -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | _ -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + Core.init Core.ns; + Env.set repl_env (Types.symbol "*ARGV*") + (Types.list (if Array.length Sys.argv > 1 + then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) + else [])); + Env.set repl_env (Types.symbol "eval") + (T.Fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); + let code = "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" + in ignore (rep code repl_env); + ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); + + if Array.length Sys.argv > 1 then + ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) + else + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + done + with End_of_file -> () -- cgit v1.2.3 From fb21afa71b4f73fa9c05c47e6b1c0f45d2144069 Mon Sep 17 00:00:00 2001 From: Chouser Date: Wed, 29 Jan 2014 20:05:05 -0500 Subject: OCaml: Add Step 8 --- ocaml/Makefile | 3 +- ocaml/core.ml | 63 +++++++++++++---------- ocaml/step2_eval.ml | 4 +- ocaml/step3_env.ml | 4 +- ocaml/step4_if_fn_do.ml | 4 +- ocaml/step6_file.ml | 6 +-- ocaml/step7_quote.ml | 6 +-- ocaml/step8_macros.ml | 129 ++++++++++++++++++++++++++++++++++++++++++++++++ ocaml/types.ml | 4 +- 9 files changed, 183 insertions(+), 40 deletions(-) create mode 100644 ocaml/step8_macros.ml diff --git a/ocaml/Makefile b/ocaml/Makefile index be51a88..b52c69b 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -1,5 +1,6 @@ STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \ - step4_if_fn_do.ml step5_tco.ml step6_file.ml step7_quote.ml + step4_if_fn_do.ml step5_tco.ml step6_file.ml step7_quote.ml \ + step8_macros.ml MODULES = types.ml reader.ml printer.ml env.ml core.ml LIBS = str.cmxa MAL_LIB = mal_lib.cmxa diff --git a/ocaml/core.ml b/ocaml/core.ml index a5131ce..98f8c8c 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -1,7 +1,7 @@ module T = Types.Types let ns = Env.make None -let num_fun t f = T.Fn +let num_fun t f = Types.fn (function | [(T.Int a); (T.Int b)] -> t (f a b) | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) @@ -26,55 +26,66 @@ let init env = begin Env.set env (Types.symbol ">") (num_fun mk_bool ( > )); Env.set env (Types.symbol ">=") (num_fun mk_bool ( >= )); - Env.set env (Types.symbol "list") (T.Fn (function xs -> Types.list xs)); + Env.set env (Types.symbol "list") (Types.fn (function xs -> Types.list xs)); Env.set env (Types.symbol "list?") - (T.Fn (function [T.List _] -> T.Bool true | _ -> T.Bool false)); + (Types.fn (function [T.List _] -> T.Bool true | _ -> T.Bool false)); Env.set env (Types.symbol "empty?") - (T.Fn (function [T.List {T.value = []}] -> T.Bool true | _ -> T.Bool false)); + (Types.fn (function [T.List {T.value = []}] -> T.Bool true | _ -> T.Bool false)); Env.set env (Types.symbol "count") - (T.Fn (function [T.List {T.value = xs}] -> T.Int (List.length xs) | _ -> T.Int 0)); + (Types.fn (function [T.List {T.value = xs}] -> T.Int (List.length xs) | _ -> T.Int 0)); Env.set env (Types.symbol "=") - (T.Fn (function - | [T.List a; T.Vector b] -> T.Bool (a = b) - | [T.Vector a; T.List b] -> T.Bool (a = b) - | [a; b] -> T.Bool (a = b) - | _ -> T.Bool false)); + (Types.fn (function + | [T.List a; T.Vector b] -> T.Bool (a = b) + | [T.Vector a; T.List b] -> T.Bool (a = b) + | [a; b] -> T.Bool (a = b) + | _ -> T.Bool false)); Env.set env (Types.symbol "pr-str") - (T.Fn (function xs -> + (Types.fn (function xs -> T.String (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs)))); Env.set env (Types.symbol "str") - (T.Fn (function xs -> + (Types.fn (function xs -> T.String (String.concat "" (List.map (fun s -> Printer.pr_str s false) xs)))); Env.set env (Types.symbol "prn") - (T.Fn (function xs -> + (Types.fn (function xs -> print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s true) xs)); T.Nil)); Env.set env (Types.symbol "println") - (T.Fn (function xs -> + (Types.fn (function xs -> print_endline (String.concat " " (List.map (fun s -> Printer.pr_str s false) xs)); T.Nil)); Env.set env (Types.symbol "compare") - (T.Fn (function [a; b] -> T.Int (compare a b) | _ -> T.Nil)); + (Types.fn (function [a; b] -> T.Int (compare a b) | _ -> T.Nil)); Env.set env (Types.symbol "with-meta") - (T.Fn (function [a; b] -> Reader.with_meta a b | _ -> T.Nil)); + (Types.fn (function [a; b] -> Reader.with_meta a b | _ -> T.Nil)); Env.set env (Types.symbol "meta") - (T.Fn (function [x] -> Printer.meta x | _ -> T.Nil)); + (Types.fn (function [x] -> Printer.meta x | _ -> T.Nil)); Env.set env (Types.symbol "read-string") - (T.Fn (function [T.String x] -> Reader.read_str x | _ -> T.Nil)); + (Types.fn (function [T.String x] -> Reader.read_str x | _ -> T.Nil)); Env.set env (Types.symbol "slurp") - (T.Fn (function [T.String x] -> T.String (Reader.slurp x) | _ -> T.Nil)); + (Types.fn (function [T.String x] -> T.String (Reader.slurp x) | _ -> T.Nil)); Env.set env (Types.symbol "cons") - (T.Fn (function [x; xs] -> Types.list (x :: (seq xs)) | _ -> T.Nil)); + (Types.fn (function [x; xs] -> Types.list (x :: (seq xs)) | _ -> T.Nil)); Env.set env (Types.symbol "concat") - (T.Fn (let rec concat = - function - | x :: y :: more -> concat ((Types.list ((seq x) @ (seq y))) :: more) - | [x] -> x - | [] -> Types.list [] - in concat)); + (Types.fn (let rec concat = + function + | x :: y :: more -> concat ((Types.list ((seq x) @ (seq y))) :: more) + | [x] -> x + | [] -> Types.list [] + in concat)); + + Env.set env (Types.symbol "nth") + (Types.fn (function [xs; T.Int i] -> List.nth (seq xs) i | _ -> T.Nil)); + Env.set env (Types.symbol "first") + (Types.fn (function + | [xs] -> (match seq xs with x :: _ -> x | _ -> T.Nil) + | _ -> T.Nil)); + Env.set env (Types.symbol "rest") + (Types.fn (function + | [xs] -> Types.list (match seq xs with _ :: xs -> xs | _ -> []) + | _ -> T.Nil)); end diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml index 50751f9..62de875 100644 --- a/ocaml/step2_eval.ml +++ b/ocaml/step2_eval.ml @@ -9,7 +9,7 @@ module Env = end)*) ) -let num_fun f = T.Fn +let num_fun f = Types.fn (function | [(T.Int a); (T.Int b)] -> T.Int (f a b) | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) @@ -40,7 +40,7 @@ let rec eval_ast ast env = and eval ast env = let result = eval_ast ast env in match result with - | T.List { T.value = ((T.Fn f) :: args) } -> (f args) + | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> (f args) | _ -> result let read str = Reader.read_str str diff --git a/ocaml/step3_env.ml b/ocaml/step3_env.ml index 856a786..442b4e4 100644 --- a/ocaml/step3_env.ml +++ b/ocaml/step3_env.ml @@ -1,6 +1,6 @@ module T = Types.Types -let num_fun f = T.Fn +let num_fun f = Types.fn (function | [(T.Int a); (T.Int b)] -> T.Int (f a b) | _ -> raise (Invalid_argument "Numeric args required for this Mal builtin")) @@ -47,7 +47,7 @@ and eval ast env = eval body sub_env) | T.List _ -> (match eval_ast ast env with - | T.List { T.value = ((T.Fn f) :: args) } -> f args + | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env diff --git a/ocaml/step4_if_fn_do.ml b/ocaml/step4_if_fn_do.ml index a16649a..7172070 100644 --- a/ocaml/step4_if_fn_do.ml +++ b/ocaml/step4_if_fn_do.ml @@ -41,7 +41,7 @@ and eval ast env = if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> - T.Fn + Types.fn (function args -> let sub_env = Env.make (Some env) in let rec bind_args a b = @@ -56,7 +56,7 @@ and eval ast env = eval expr sub_env) | T.List _ -> (match eval_ast ast env with - | T.List { T.value = ((T.Fn f) :: args) } -> f args + | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env diff --git a/ocaml/step6_file.ml b/ocaml/step6_file.ml index af87eb0..6eedd71 100644 --- a/ocaml/step6_file.ml +++ b/ocaml/step6_file.ml @@ -41,7 +41,7 @@ and eval ast env = if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> - T.Fn + Types.fn (function args -> let sub_env = Env.make (Some env) in let rec bind_args a b = @@ -56,7 +56,7 @@ and eval ast env = eval expr sub_env) | T.List _ -> (match eval_ast ast env with - | T.List { T.value = ((T.Fn f) :: args) } -> f args + | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env @@ -72,7 +72,7 @@ let rec main = then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) else [])); Env.set repl_env (Types.symbol "eval") - (T.Fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); + (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); let code = "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" in print_endline code; ignore (rep code repl_env); ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); diff --git a/ocaml/step7_quote.ml b/ocaml/step7_quote.ml index d8b4518..e9907cc 100644 --- a/ocaml/step7_quote.ml +++ b/ocaml/step7_quote.ml @@ -53,7 +53,7 @@ and eval ast env = if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> - T.Fn + Types.fn (function args -> let sub_env = Env.make (Some env) in let rec bind_args a b = @@ -71,7 +71,7 @@ and eval ast env = eval (quasiquote ast) env | T.List _ -> (match eval_ast ast env with - | T.List { T.value = ((T.Fn f) :: args) } -> f args + | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env @@ -87,7 +87,7 @@ let rec main = then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) else [])); Env.set repl_env (Types.symbol "eval") - (T.Fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); + (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); let code = "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" in ignore (rep code repl_env); ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); diff --git a/ocaml/step8_macros.ml b/ocaml/step8_macros.ml new file mode 100644 index 0000000..5febf6c --- /dev/null +++ b/ocaml/step8_macros.ml @@ -0,0 +1,129 @@ +module T = Types.Types + +let repl_env = Env.make (Some Core.ns) + +let rec quasiquote ast = + match ast with + | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast + | T.Vector { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast + | T.List { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } + | T.Vector { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } -> + Types.list [Types.symbol "concat"; head; quasiquote (Types.list tail)] + | T.List { T.value = head :: tail } + | T.Vector { T.value = head :: tail } -> + Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] + | ast -> Types.list [Types.symbol "quote"; ast] + +let rec macroexpand ast env = + match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.f = f; T.is_macro = true } -> macroexpand (f args) env + | _ -> ast) + | _ -> ast + +let rec eval_ast ast env = + match ast with + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add (eval k env) (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + match macroexpand ast env with + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> + let value = (eval expr env) in + Env.set env key value; value + | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> + (match (eval expr env) with + | T.Fn { T.f = f } -> + let fn = T.Fn { T.f = f; is_macro = true } in + Env.set env key fn; fn + | _ -> raise (Invalid_argument "devmacro! value must be a fn")) + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + Types.fn + (function args -> + let sub_env = Env.make (Some env) in + let rec bind_args a b = + (match a, b with + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); + | (name :: names), (arg :: args) -> + Env.set sub_env name arg; + bind_args names args; + | [], [] -> () + | _ -> raise (Invalid_argument "Bad param count in fn call")) + in bind_args arg_names args; + eval expr sub_env) + | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast + | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> + eval (quasiquote ast) env + | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> + macroexpand ast env + | T.List _ as ast -> + (match eval_ast ast env with + | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | ast -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + Core.init Core.ns; + Env.set repl_env (Types.symbol "*ARGV*") + (Types.list (if Array.length Sys.argv > 1 + then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) + else [])); + Env.set repl_env (Types.symbol "eval") + (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); + + ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" repl_env); + ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); + ignore (rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" repl_env); + ignore (rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" repl_env); + + if Array.length Sys.argv > 1 then + ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) + else + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + | _ -> + output_string stderr ("Erroringness!\n"); + flush stderr + done + with End_of_file -> () diff --git a/ocaml/types.ml b/ocaml/types.ml index 287cc88..1cec691 100644 --- a/ocaml/types.ml +++ b/ocaml/types.ml @@ -1,6 +1,7 @@ module rec Types : sig type 'a with_meta = { value : 'a; meta : t } + and fn_rec = { f : (t list -> t); is_macro : bool } and t = | List of t list with_meta | Vector of t list with_meta @@ -11,7 +12,7 @@ module rec Types | Nil | Bool of bool | String of string - | Fn of (t list -> t) + | Fn of fn_rec end = Types and MalValue @@ -38,6 +39,7 @@ let list x = Types.List { Types.value = x; meta = Types.Nil } let map x = Types.Map { Types.value = x; meta = Types.Nil } let vector x = Types.Vector { Types.value = x; meta = Types.Nil } let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil } +let fn f = Types.Fn { Types.f = f; Types.is_macro = false } let rec list_into_map target source = match source with -- cgit v1.2.3 From ecd3b6d8e551dd87934142b0323d9b75134bbea9 Mon Sep 17 00:00:00 2001 From: Chouser Date: Thu, 29 Jan 2015 23:29:54 -0500 Subject: OCaml: Add step 9 --- ocaml/Makefile | 2 +- ocaml/core.ml | 107 +++++++++++++++++++++++++++++++++- ocaml/env.ml | 2 +- ocaml/printer.ml | 6 +- ocaml/reader.ml | 9 +-- ocaml/step2_eval.ml | 11 +++- ocaml/step3_env.ml | 11 +++- ocaml/step4_if_fn_do.ml | 11 +++- ocaml/step6_file.ml | 11 +++- ocaml/step7_quote.ml | 11 +++- ocaml/step8_macros.ml | 17 ++++-- ocaml/step9_try.ml | 148 ++++++++++++++++++++++++++++++++++++++++++++++++ ocaml/types.ml | 18 +++--- 13 files changed, 326 insertions(+), 38 deletions(-) create mode 100644 ocaml/step9_try.ml diff --git a/ocaml/Makefile b/ocaml/Makefile index b52c69b..a7c78fd 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -1,6 +1,6 @@ STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \ step4_if_fn_do.ml step5_tco.ml step6_file.ml step7_quote.ml \ - step8_macros.ml + step8_macros.ml step9_try.ml MODULES = types.ml reader.ml printer.ml env.ml core.ml LIBS = str.cmxa MAL_LIB = mal_lib.cmxa diff --git a/ocaml/core.ml b/ocaml/core.ml index 98f8c8c..49041d8 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -16,6 +16,38 @@ let seq = function Types.MalMap.fold (fun k v list -> k :: v :: list) xs [] | _ -> [] +let rec assoc = function + | c :: k :: v :: (_ :: _ as xs) -> assoc ((assoc [c; k; v]) :: xs) + | [T.Map { T.value = m; T.meta = meta }; k; v] + -> T.Map { T.value = (Types.MalMap.add k v m); + T.meta = meta; + T.is_macro = false} + | _ -> T.Nil + +let rec dissoc = function + | c :: x :: (_ :: _ as xs) -> dissoc ((dissoc [c; x]) :: xs) + | [T.Map { T.value = m; T.meta = meta }; k] + -> T.Map { T.value = (Types.MalMap.remove k m); + T.meta = meta; + T.is_macro = false} + | _ -> T.Nil + +let rec conj = function + | c :: x :: (_ :: _ as xs) -> conj ((conj [c; x]) :: xs) + | [T.Map { T.value = c; T.meta = meta }; T.Vector { T.value = [k; v] }] + -> T.Map { T.value = (Types.MalMap.add k v c); + T.meta = meta; + T.is_macro = false} + | [T.List { T.value = c; T.meta = meta }; x ] + -> T.List { T.value = x :: c; + T.meta = meta; + T.is_macro = false} + | [T.Vector { T.value = c; T.meta = meta }; x ] + -> T.Vector { T.value = c @ [x]; + T.meta = meta; + T.is_macro = false} + | _ -> T.Nil + let init env = begin Env.set env (Types.symbol "+") (num_fun mk_int ( + )); Env.set env (Types.symbol "-") (num_fun mk_int ( - )); @@ -29,6 +61,9 @@ let init env = begin Env.set env (Types.symbol "list") (Types.fn (function xs -> Types.list xs)); Env.set env (Types.symbol "list?") (Types.fn (function [T.List _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "vector") (Types.fn (function xs -> Types.vector xs)); + Env.set env (Types.symbol "vector?") + (Types.fn (function [T.Vector _] -> T.Bool true | _ -> T.Bool false)); Env.set env (Types.symbol "empty?") (Types.fn (function [T.List {T.value = []}] -> T.Bool true | _ -> T.Bool false)); Env.set env (Types.symbol "count") @@ -87,5 +122,75 @@ let init env = begin (Types.fn (function | [xs] -> Types.list (match seq xs with _ :: xs -> xs | _ -> []) | _ -> T.Nil)); -end + Env.set env (Types.symbol "symbol") + (Types.fn (function [T.String x] -> Types.symbol x | _ -> T.Nil)); + Env.set env (Types.symbol "symbol?") + (Types.fn (function [T.Symbol _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "keyword") + (Types.fn (function [T.String x] -> T.Keyword x | _ -> T.Nil)); + Env.set env (Types.symbol "keyword?") + (Types.fn (function [T.Keyword _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "nil?") + (Types.fn (function [T.Nil] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "true?") + (Types.fn (function [T.Bool true] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "false?") + (Types.fn (function [T.Bool false] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "sequential?") + (Types.fn (function [T.List _] | [T.Vector _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "apply") + (Types.fn (function + | (T.Fn { T.value = f } :: apply_args) -> + (match List.rev apply_args with + | last_arg :: rev_args -> + f ((List.rev rev_args) @ (seq last_arg)) + | [] -> f []) + | _ -> raise (Invalid_argument "First arg to apply must be a fn"))); + Env.set env (Types.symbol "map") + (Types.fn (function + | [T.Fn { T.value = f }; xs] -> + Types.list (List.map (fun x -> f [x]) (seq xs)) + | _ -> T.Nil)); + Env.set env (Types.symbol "readline") + (Types.fn (function + | [T.String x] -> print_string x; T.String (read_line ()) + | _ -> T.String (read_line ()))); + + Env.set env (Types.symbol "map?") + (Types.fn (function [T.Map _] -> T.Bool true | _ -> T.Bool false)); + Env.set env (Types.symbol "hash-map") + (Types.fn (function xs -> Types.list_into_map Types.MalMap.empty xs)); + Env.set env (Types.symbol "assoc") (Types.fn assoc); + Env.set env (Types.symbol "dissoc") (Types.fn dissoc); + Env.set env (Types.symbol "get") + (Types.fn (function + | [T.Map { T.value = m }; k] + -> (try Types.MalMap.find k m with _ -> T.Nil) + | _ -> T.Nil)); + Env.set env (Types.symbol "keys") + (Types.fn (function + | [T.Map { T.value = m }] + -> Types.list (Types.MalMap.fold (fun k _ c -> k :: c) m []) + | _ -> T.Nil)); + Env.set env (Types.symbol "vals") + (Types.fn (function + | [T.Map { T.value = m }] + -> Types.list (Types.MalMap.fold (fun _ v c -> v :: c) m []) + | _ -> T.Nil)); + Env.set env (Types.symbol "contains?") + (Types.fn (function + | [T.Map { T.value = m }; k] -> T.Bool (Types.MalMap.mem k m) + | _ -> T.Bool false)); + Env.set env (Types.symbol "conj") (Types.fn conj); + + Env.set env (Types.symbol "atom") + (Types.fn (function [x] -> T.Atom (ref x) | _ -> T.Nil)); + Env.set env (Types.symbol "deref") + (Types.fn (function [T.Atom x] -> !x | _ -> T.Nil)); + Env.set env (Types.symbol "reset!") + (Types.fn (function [T.Atom x; v] -> x := v; v | _ -> T.Nil)); + Env.set env (Types.symbol "swap!") + (Types.fn (function T.Atom x :: T.Fn { T.value = f } :: args + -> let v = f (!x :: args) in x := v; v | _ -> T.Nil)); +end diff --git a/ocaml/env.ml b/ocaml/env.ml index 97f9cc8..cb32360 100644 --- a/ocaml/env.ml +++ b/ocaml/env.ml @@ -29,5 +29,5 @@ let get env sym = | T.Symbol { T.value = key } -> (match find env sym with | Some found_env -> Data.find key !(found_env.data) - | None -> raise (Invalid_argument ("Symbol '" ^ key ^ "' not found"))) + | None -> raise (Invalid_argument ("'" ^ key ^ "' not found"))) | _ -> raise (Invalid_argument "get requires a Symbol for its key") diff --git a/ocaml/printer.ml b/ocaml/printer.ml index fe025af..135c3ce 100644 --- a/ocaml/printer.ml +++ b/ocaml/printer.ml @@ -6,6 +6,7 @@ let meta obj = | T.Map { T.meta = meta } -> meta | T.Vector { T.meta = meta } -> meta | T.Symbol { T.meta = meta } -> meta + | T.Fn { T.meta = meta } -> meta | _ -> T.Nil let rec pr_str mal_obj print_readably = @@ -30,7 +31,8 @@ let rec pr_str mal_obj print_readably = | T.Vector { T.value = xs } -> "[" ^ (String.concat " " (List.map (fun s -> pr_str s r) xs)) ^ "]" | T.Map { T.value = xs } -> - (Types.MalMap.fold (fun k v s -> s ^ (if s = "" then "{" else ", ") ^ (pr_str k r) - ^ " " ^ (pr_str v r)) xs "") + "{" ^ (Types.MalMap.fold (fun k v s -> s ^ (if s = "" then "" else ", ") ^ (pr_str k r) + ^ " " ^ (pr_str v r)) xs "") ^ "}" | T.Fn f -> "#" + | T.Atom x -> "(atom " ^ (pr_str !x r) ^ ")" diff --git a/ocaml/reader.ml b/ocaml/reader.ml index 36f0b2a..cf8c141 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -48,10 +48,11 @@ let read_atom token = let with_meta obj meta = match obj with - | T.List { T.value = value } -> T.List { T.value = value; T.meta = meta }; - | T.Map { T.value = value } -> T.Map { T.value = value; T.meta = meta }; - | T.Vector { T.value = value } -> T.Vector { T.value = value; T.meta = meta }; - | T.Symbol { T.value = value } -> T.Symbol { T.value = value; T.meta = meta }; + | T.List { T.value = v } -> T.List { T.value = v; T.meta = meta; T.is_macro = false }; + | T.Map { T.value = v } -> T.Map { T.value = v; T.meta = meta; T.is_macro = false }; + | T.Vector { T.value = v } -> T.Vector { T.value = v; T.meta = meta; T.is_macro = false }; + | T.Symbol { T.value = v } -> T.Symbol { T.value = v; T.meta = meta; T.is_macro = false }; + | T.Fn { T.value = v } -> T.Fn { T.value = v; T.meta = meta; T.is_macro = false }; | _ -> raise (Invalid_argument "metadata not supported on this type") let rec read_list eol list_reader = diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml index 62de875..b7f0793 100644 --- a/ocaml/step2_eval.ml +++ b/ocaml/step2_eval.ml @@ -26,11 +26,16 @@ let rec eval_ast ast env = (try Env.find s !env with Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found"))) | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; + T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) @@ -40,7 +45,7 @@ let rec eval_ast ast env = and eval ast env = let result = eval_ast ast env in match result with - | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> (f args) + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> (f args) | _ -> result let read str = Reader.read_str str diff --git a/ocaml/step3_env.ml b/ocaml/step3_env.ml index 442b4e4..4334c39 100644 --- a/ocaml/step3_env.ml +++ b/ocaml/step3_env.ml @@ -18,11 +18,16 @@ let rec eval_ast ast env = match ast with | T.Symbol s -> Env.get env ast | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; + T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) @@ -47,7 +52,7 @@ and eval ast env = eval body sub_env) | T.List _ -> (match eval_ast ast env with - | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env diff --git a/ocaml/step4_if_fn_do.ml b/ocaml/step4_if_fn_do.ml index 7172070..abbcdab 100644 --- a/ocaml/step4_if_fn_do.ml +++ b/ocaml/step4_if_fn_do.ml @@ -6,11 +6,16 @@ let rec eval_ast ast env = match ast with | T.Symbol s -> Env.get env ast | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; + T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) @@ -56,7 +61,7 @@ and eval ast env = eval expr sub_env) | T.List _ -> (match eval_ast ast env with - | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env diff --git a/ocaml/step6_file.ml b/ocaml/step6_file.ml index 6eedd71..09ef28a 100644 --- a/ocaml/step6_file.ml +++ b/ocaml/step6_file.ml @@ -6,11 +6,16 @@ let rec eval_ast ast env = match ast with | T.Symbol s -> Env.get env ast | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; + T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) @@ -56,7 +61,7 @@ and eval ast env = eval expr sub_env) | T.List _ -> (match eval_ast ast env with - | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env diff --git a/ocaml/step7_quote.ml b/ocaml/step7_quote.ml index e9907cc..5807b28 100644 --- a/ocaml/step7_quote.ml +++ b/ocaml/step7_quote.ml @@ -18,11 +18,16 @@ let rec eval_ast ast env = match ast with | T.Symbol s -> Env.get env ast | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; + T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) @@ -71,7 +76,7 @@ and eval ast env = eval (quasiquote ast) env | T.List _ -> (match eval_ast ast env with - | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | _ -> eval_ast ast env diff --git a/ocaml/step8_macros.ml b/ocaml/step8_macros.ml index 5febf6c..6077b76 100644 --- a/ocaml/step8_macros.ml +++ b/ocaml/step8_macros.ml @@ -18,7 +18,7 @@ let rec macroexpand ast env = match ast with | T.List { T.value = s :: args } -> (match (try Env.get env s with _ -> T.Nil) with - | T.Fn { T.f = f; T.is_macro = true } -> macroexpand (f args) env + | T.Fn { T.value = f; T.is_macro = true } -> macroexpand (f args) env | _ -> ast) | _ -> ast @@ -26,11 +26,16 @@ let rec eval_ast ast env = match ast with | T.Symbol s -> Env.get env ast | T.List { T.value = xs; T.meta = meta } - -> T.List { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} | T.Vector { T.value = xs; T.meta = meta } - -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; + T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) @@ -44,8 +49,8 @@ and eval ast env = Env.set env key value; value | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> (match (eval expr env) with - | T.Fn { T.f = f } -> - let fn = T.Fn { T.f = f; is_macro = true } in + | T.Fn { T.value = f; T.meta = meta } -> + let fn = T.Fn { T.value = f; is_macro = true; meta = meta } in Env.set env key fn; fn | _ -> raise (Invalid_argument "devmacro! value must be a fn")) | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } @@ -87,7 +92,7 @@ and eval ast env = macroexpand ast env | T.List _ as ast -> (match eval_ast ast env with - | T.List { T.value = ((T.Fn { T.f = f }) :: args) } -> f args + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args | _ -> raise (Invalid_argument "Cannot invoke non-function")) | ast -> eval_ast ast env diff --git a/ocaml/step9_try.ml b/ocaml/step9_try.ml new file mode 100644 index 0000000..462ab3a --- /dev/null +++ b/ocaml/step9_try.ml @@ -0,0 +1,148 @@ +module T = Types.Types + +let repl_env = Env.make (Some Core.ns) + +let rec quasiquote ast = + match ast with + | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast + | T.Vector { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast + | T.List { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } + | T.Vector { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } -> + Types.list [Types.symbol "concat"; head; quasiquote (Types.list tail)] + | T.List { T.value = head :: tail } + | T.Vector { T.value = head :: tail } -> + Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] + | ast -> Types.list [Types.symbol "quote"; ast] + +let rec macroexpand ast env = + match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.value = f; T.is_macro = true } -> macroexpand (f args) env + | _ -> ast) + | _ -> ast + +let rec eval_ast ast env = + match ast with + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.is_macro = false; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add (eval k env) (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + match macroexpand ast env with + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> + let value = (eval expr env) in + Env.set env key value; value + | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> + (match (eval expr env) with + | T.Fn { T.value = f; T.meta = meta } -> + let fn = T.Fn { T.value = f; is_macro = true; meta = meta } in + Env.set env key fn; fn + | _ -> raise (Invalid_argument "devmacro! value must be a fn")) + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + Types.fn + (function args -> + let sub_env = Env.make (Some env) in + let rec bind_args a b = + (match a, b with + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); + | (name :: names), (arg :: args) -> + Env.set sub_env name arg; + bind_args names args; + | [], [] -> () + | _ -> raise (Invalid_argument "Bad param count in fn call")) + in bind_args arg_names args; + eval expr sub_env) + | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast + | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> + eval (quasiquote ast) env + | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> + macroexpand ast env + | T.List { T.value = [T.Symbol { T.value = "throw" }; ast] } -> + raise (Types.MalExn (eval ast env)) + | T.List { T.value = [T.Symbol { T.value = "try*" }; scary ; + T.List { T.value = [T.Symbol { T.value = "catch*" }; + local ; handler]}]} -> + (try (eval scary env) + with exn -> + let value = match exn with + | Types.MalExn value -> value + | Invalid_argument msg -> T.String msg + | _ -> (T.String "OCaml exception") in + let sub_env = Env.make (Some env) in + Env.set sub_env local value; + eval handler sub_env) + | T.List _ as ast -> + (match eval_ast ast env with + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | ast -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + Core.init Core.ns; + Env.set repl_env (Types.symbol "*ARGV*") + (Types.list (if Array.length Sys.argv > 1 + then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) + else [])); + Env.set repl_env (Types.symbol "eval") + (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); + + ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" repl_env); + ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); + ignore (rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" repl_env); + ignore (rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" repl_env); + + if Array.length Sys.argv > 1 then + ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) + else + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + | _ -> + output_string stderr ("Erroringness!\n"); + flush stderr + done + with End_of_file -> () diff --git a/ocaml/types.ml b/ocaml/types.ml index 1cec691..75fade7 100644 --- a/ocaml/types.ml +++ b/ocaml/types.ml @@ -1,7 +1,6 @@ module rec Types : sig - type 'a with_meta = { value : 'a; meta : t } - and fn_rec = { f : (t list -> t); is_macro : bool } + type 'a with_meta = { value : 'a; meta : t; is_macro : bool } and t = | List of t list with_meta | Vector of t list with_meta @@ -12,7 +11,8 @@ module rec Types | Nil | Bool of bool | String of string - | Fn of fn_rec + | Fn of (t list -> t) with_meta + | Atom of t ref end = Types and MalValue @@ -29,17 +29,19 @@ and MalMap : Map.S with type key = MalValue.t = Map.Make(MalValue) +exception MalExn of Types.t + let to_bool x = match x with | Types.Nil | Types.Bool false -> false | _ -> true type mal_type = MalValue.t -let list x = Types.List { Types.value = x; meta = Types.Nil } -let map x = Types.Map { Types.value = x; meta = Types.Nil } -let vector x = Types.Vector { Types.value = x; meta = Types.Nil } -let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil } -let fn f = Types.Fn { Types.f = f; Types.is_macro = false } +let list x = Types.List { Types.value = x; meta = Types.Nil; Types.is_macro = false } +let map x = Types.Map { Types.value = x; meta = Types.Nil; Types.is_macro = false } +let vector x = Types.Vector { Types.value = x; meta = Types.Nil; Types.is_macro = false } +let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil; Types.is_macro = false } +let fn f = Types.Fn { Types.value = f; meta = Types.Nil; Types.is_macro = false } let rec list_into_map target source = match source with -- cgit v1.2.3 From fd3adc525489857e2db66fd905e829d38364f777 Mon Sep 17 00:00:00 2001 From: Chouser Date: Fri, 30 Jan 2015 00:17:57 -0500 Subject: OCaml: self-hosting --- ocaml/Makefile | 2 +- ocaml/core.ml | 10 +++- ocaml/step9_try.ml | 2 - ocaml/stepA_interop.ml | 148 +++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 158 insertions(+), 4 deletions(-) create mode 100644 ocaml/stepA_interop.ml diff --git a/ocaml/Makefile b/ocaml/Makefile index a7c78fd..e5b0ac2 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -1,6 +1,6 @@ STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \ step4_if_fn_do.ml step5_tco.ml step6_file.ml step7_quote.ml \ - step8_macros.ml step9_try.ml + step8_macros.ml step9_try.ml stepA_interop.ml MODULES = types.ml reader.ml printer.ml env.ml core.ml LIBS = str.cmxa MAL_LIB = mal_lib.cmxa diff --git a/ocaml/core.ml b/ocaml/core.ml index 49041d8..19763fa 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -49,6 +49,9 @@ let rec conj = function | _ -> T.Nil let init env = begin + Env.set env (Types.symbol "throw") + (Types.fn (function [ast] -> raise (Types.MalExn ast) | _ -> T.Nil)); + Env.set env (Types.symbol "+") (num_fun mk_int ( + )); Env.set env (Types.symbol "-") (num_fun mk_int ( - )); Env.set env (Types.symbol "*") (num_fun mk_int ( * )); @@ -67,7 +70,10 @@ let init env = begin Env.set env (Types.symbol "empty?") (Types.fn (function [T.List {T.value = []}] -> T.Bool true | _ -> T.Bool false)); Env.set env (Types.symbol "count") - (Types.fn (function [T.List {T.value = xs}] -> T.Int (List.length xs) | _ -> T.Int 0)); + (Types.fn (function + | [T.List {T.value = xs}] + | [T.Vector {T.value = xs}] -> T.Int (List.length xs) + | _ -> T.Int 0)); Env.set env (Types.symbol "=") (Types.fn (function | [T.List a; T.Vector b] -> T.Bool (a = b) @@ -184,6 +190,8 @@ let init env = begin | _ -> T.Bool false)); Env.set env (Types.symbol "conj") (Types.fn conj); + Env.set env (Types.symbol "atom?") + (Types.fn (function [T.Atom _] -> T.Bool true | _ -> T.Bool false)); Env.set env (Types.symbol "atom") (Types.fn (function [x] -> T.Atom (ref x) | _ -> T.Nil)); Env.set env (Types.symbol "deref") diff --git a/ocaml/step9_try.ml b/ocaml/step9_try.ml index 462ab3a..37c41ac 100644 --- a/ocaml/step9_try.ml +++ b/ocaml/step9_try.ml @@ -90,8 +90,6 @@ and eval ast env = eval (quasiquote ast) env | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> macroexpand ast env - | T.List { T.value = [T.Symbol { T.value = "throw" }; ast] } -> - raise (Types.MalExn (eval ast env)) | T.List { T.value = [T.Symbol { T.value = "try*" }; scary ; T.List { T.value = [T.Symbol { T.value = "catch*" }; local ; handler]}]} -> diff --git a/ocaml/stepA_interop.ml b/ocaml/stepA_interop.ml new file mode 100644 index 0000000..1b2e98d --- /dev/null +++ b/ocaml/stepA_interop.ml @@ -0,0 +1,148 @@ +module T = Types.Types + +let repl_env = Env.make (Some Core.ns) + +let rec quasiquote ast = + match ast with + | T.List { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast + | T.Vector { T.value = [T.Symbol {T.value = "unquote"}; ast] } -> ast + | T.List { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } + | T.Vector { T.value = T.List { T.value = [T.Symbol {T.value = "splice-unquote"}; head]} :: tail } -> + Types.list [Types.symbol "concat"; head; quasiquote (Types.list tail)] + | T.List { T.value = head :: tail } + | T.Vector { T.value = head :: tail } -> + Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] + | ast -> Types.list [Types.symbol "quote"; ast] + +let rec macroexpand ast env = + match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.value = f; T.is_macro = true } -> macroexpand (f args) env + | _ -> ast) + | _ -> ast + +let rec eval_ast ast env = + match ast with + | T.Symbol s -> Env.get env ast + | T.List { T.value = xs; T.meta = meta } + -> T.List { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} + | T.Vector { T.value = xs; T.meta = meta } + -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); + T.meta = meta; + T.is_macro = false} + | T.Map { T.value = xs; T.meta = meta } + -> T.Map {T.meta = meta; + T.is_macro = false; + T.value = (Types.MalMap.fold + (fun k v m + -> Types.MalMap.add (eval k env) (eval v env) m) + xs + Types.MalMap.empty)} + | _ -> ast +and eval ast env = + match macroexpand ast env with + | T.List { T.value = [(T.Symbol { T.value = "def!" }); key; expr] } -> + let value = (eval expr env) in + Env.set env key value; value + | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> + (match (eval expr env) with + | T.Fn { T.value = f; T.meta = meta } -> + let fn = T.Fn { T.value = f; is_macro = true; meta = meta } in + Env.set env key fn; fn + | _ -> raise (Invalid_argument "devmacro! value must be a fn")) + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } + | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> + (let sub_env = Env.make (Some env) in + let rec bind_pairs = (function + | sym :: expr :: more -> + Env.set sub_env sym (eval expr sub_env); + bind_pairs more + | _::[] -> raise (Invalid_argument "let* bindings must be an even number of forms") + | [] -> ()) + in bind_pairs bindings; + eval body sub_env) + | T.List { T.value = ((T.Symbol { T.value = "do" }) :: body) } -> + List.fold_left (fun x expr -> eval expr env) T.Nil body + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr; else_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else (eval else_expr env) + | T.List { T.value = [T.Symbol { T.value = "if" }; test; then_expr] } -> + if Types.to_bool (eval test env) then (eval then_expr env) else T.Nil + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.Vector { T.value = arg_names }; expr] } + | T.List { T.value = [T.Symbol { T.value = "fn*" }; T.List { T.value = arg_names }; expr] } -> + Types.fn + (function args -> + let sub_env = Env.make (Some env) in + let rec bind_args a b = + (match a, b with + | [T.Symbol { T.value = "&" }; name], args -> Env.set sub_env name (Types.list args); + | (name :: names), (arg :: args) -> + Env.set sub_env name arg; + bind_args names args; + | [], [] -> () + | _ -> raise (Invalid_argument "Bad param count in fn call")) + in bind_args arg_names args; + eval expr sub_env) + | T.List { T.value = [T.Symbol { T.value = "quote" }; ast] } -> ast + | T.List { T.value = [T.Symbol { T.value = "quasiquote" }; ast] } -> + eval (quasiquote ast) env + | T.List { T.value = [T.Symbol { T.value = "macroexpand" }; ast] } -> + macroexpand ast env + | T.List { T.value = [T.Symbol { T.value = "try*" }; scary ; + T.List { T.value = [T.Symbol { T.value = "catch*" }; + local ; handler]}]} -> + (try (eval scary env) + with exn -> + let value = match exn with + | Types.MalExn value -> value + | Invalid_argument msg -> T.String msg + | _ -> (T.String "OCaml exception") in + let sub_env = Env.make (Some env) in + Env.set sub_env local value; + eval handler sub_env) + | T.List _ as ast -> + (match eval_ast ast env with + | T.List { T.value = ((T.Fn { T.value = f }) :: args) } -> f args + | _ -> raise (Invalid_argument "Cannot invoke non-function")) + | ast -> eval_ast ast env + +let read str = Reader.read_str str +let print exp = Printer.pr_str exp true +let rep str env = print (eval (read str) env) + +let rec main = + try + Core.init Core.ns; + Env.set repl_env (Types.symbol "*ARGV*") + (Types.list (if Array.length Sys.argv > 1 + then (List.map (fun x -> T.String x) (List.tl (List.tl (Array.to_list Sys.argv)))) + else [])); + Env.set repl_env (Types.symbol "eval") + (Types.fn (function [ast] -> eval ast repl_env | _ -> T.Nil)); + + ignore (rep "(def! *host-language* \"ocaml\")" repl_env); + ignore (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))" repl_env); + ignore (rep "(def! not (fn* (a) (if a false true)))" repl_env); + ignore (rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))" repl_env); + ignore (rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))" repl_env); + + if Array.length Sys.argv > 1 then + ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) + else + ignore (rep "(println (str \"Mal [\" *host-language* \"]\"))" repl_env); + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + | _ -> + output_string stderr ("Erroringness!\n"); + flush stderr + done + with End_of_file -> () -- cgit v1.2.3 From 2b8e0ea42046505635e8f4c9d96e594c595948c2 Mon Sep 17 00:00:00 2001 From: Chouser Date: Fri, 30 Jan 2015 09:10:24 -0500 Subject: OCaml: put macro flag in metadata rather than special type field --- ocaml/core.ml | 16 ++++++---------- ocaml/reader.ml | 11 ++++++----- ocaml/step2_eval.ml | 7 ++----- ocaml/step3_env.ml | 7 ++----- ocaml/step4_if_fn_do.ml | 7 ++----- ocaml/step6_file.ml | 7 ++----- ocaml/step7_quote.ml | 7 ++----- ocaml/step8_macros.ml | 34 ++++++++++++++++++++++------------ ocaml/step9_try.ml | 32 +++++++++++++++++++++----------- ocaml/stepA_interop.ml | 32 +++++++++++++++++++++----------- ocaml/types.ml | 12 ++++++------ 11 files changed, 92 insertions(+), 80 deletions(-) diff --git a/ocaml/core.ml b/ocaml/core.ml index 19763fa..6d7b014 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -18,34 +18,30 @@ let seq = function let rec assoc = function | c :: k :: v :: (_ :: _ as xs) -> assoc ((assoc [c; k; v]) :: xs) + | [T.Nil; k; v] -> Types.map (Types.MalMap.add k v Types.MalMap.empty) | [T.Map { T.value = m; T.meta = meta }; k; v] -> T.Map { T.value = (Types.MalMap.add k v m); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | _ -> T.Nil let rec dissoc = function | c :: x :: (_ :: _ as xs) -> dissoc ((dissoc [c; x]) :: xs) | [T.Map { T.value = m; T.meta = meta }; k] -> T.Map { T.value = (Types.MalMap.remove k m); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | _ -> T.Nil let rec conj = function | c :: x :: (_ :: _ as xs) -> conj ((conj [c; x]) :: xs) | [T.Map { T.value = c; T.meta = meta }; T.Vector { T.value = [k; v] }] -> T.Map { T.value = (Types.MalMap.add k v c); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | [T.List { T.value = c; T.meta = meta }; x ] -> T.List { T.value = x :: c; - T.meta = meta; - T.is_macro = false} + T.meta = meta } | [T.Vector { T.value = c; T.meta = meta }; x ] -> T.Vector { T.value = c @ [x]; - T.meta = meta; - T.is_macro = false} + T.meta = meta } | _ -> T.Nil let init env = begin diff --git a/ocaml/reader.ml b/ocaml/reader.ml index cf8c141..7456cf8 100644 --- a/ocaml/reader.ml +++ b/ocaml/reader.ml @@ -48,11 +48,12 @@ let read_atom token = let with_meta obj meta = match obj with - | T.List { T.value = v } -> T.List { T.value = v; T.meta = meta; T.is_macro = false }; - | T.Map { T.value = v } -> T.Map { T.value = v; T.meta = meta; T.is_macro = false }; - | T.Vector { T.value = v } -> T.Vector { T.value = v; T.meta = meta; T.is_macro = false }; - | T.Symbol { T.value = v } -> T.Symbol { T.value = v; T.meta = meta; T.is_macro = false }; - | T.Fn { T.value = v } -> T.Fn { T.value = v; T.meta = meta; T.is_macro = false }; + | T.List { T.value = v } + -> T.List { T.value = v; T.meta = meta }; | T.Map { T.value = v } + -> T.Map { T.value = v; T.meta = meta }; | T.Vector { T.value = v } + -> T.Vector { T.value = v; T.meta = meta }; | T.Symbol { T.value = v } + -> T.Symbol { T.value = v; T.meta = meta }; | T.Fn { T.value = v } + -> T.Fn { T.value = v; T.meta = meta }; | _ -> raise (Invalid_argument "metadata not supported on this type") let rec read_list eol list_reader = diff --git a/ocaml/step2_eval.ml b/ocaml/step2_eval.ml index b7f0793..3778292 100644 --- a/ocaml/step2_eval.ml +++ b/ocaml/step2_eval.ml @@ -27,15 +27,12 @@ let rec eval_ast ast env = with Not_found -> raise (Invalid_argument ("Symbol '" ^ s ^ "' not found"))) | T.List { T.value = xs; T.meta = meta } -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Vector { T.value = xs; T.meta = meta } -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; - T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) diff --git a/ocaml/step3_env.ml b/ocaml/step3_env.ml index 4334c39..73d4236 100644 --- a/ocaml/step3_env.ml +++ b/ocaml/step3_env.ml @@ -19,15 +19,12 @@ let rec eval_ast ast env = | T.Symbol s -> Env.get env ast | T.List { T.value = xs; T.meta = meta } -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Vector { T.value = xs; T.meta = meta } -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; - T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) diff --git a/ocaml/step4_if_fn_do.ml b/ocaml/step4_if_fn_do.ml index abbcdab..f08aa55 100644 --- a/ocaml/step4_if_fn_do.ml +++ b/ocaml/step4_if_fn_do.ml @@ -7,15 +7,12 @@ let rec eval_ast ast env = | T.Symbol s -> Env.get env ast | T.List { T.value = xs; T.meta = meta } -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Vector { T.value = xs; T.meta = meta } -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; - T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) diff --git a/ocaml/step6_file.ml b/ocaml/step6_file.ml index 09ef28a..e9d48d3 100644 --- a/ocaml/step6_file.ml +++ b/ocaml/step6_file.ml @@ -7,15 +7,12 @@ let rec eval_ast ast env = | T.Symbol s -> Env.get env ast | T.List { T.value = xs; T.meta = meta } -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Vector { T.value = xs; T.meta = meta } -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; - T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) diff --git a/ocaml/step7_quote.ml b/ocaml/step7_quote.ml index 5807b28..3291f48 100644 --- a/ocaml/step7_quote.ml +++ b/ocaml/step7_quote.ml @@ -19,15 +19,12 @@ let rec eval_ast ast env = | T.Symbol s -> Env.get env ast | T.List { T.value = xs; T.meta = meta } -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Vector { T.value = xs; T.meta = meta } -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; - T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) diff --git a/ocaml/step8_macros.ml b/ocaml/step8_macros.ml index 6077b76..7f61c59 100644 --- a/ocaml/step8_macros.ml +++ b/ocaml/step8_macros.ml @@ -14,28 +14,38 @@ let rec quasiquote ast = Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] | ast -> Types.list [Types.symbol "quote"; ast] -let rec macroexpand ast env = +let kw_macro = T.Keyword "macro" + +let is_macro_call ast env = match ast with | T.List { T.value = s :: args } -> (match (try Env.get env s with _ -> T.Nil) with - | T.Fn { T.value = f; T.is_macro = true } -> macroexpand (f args) env - | _ -> ast) - | _ -> ast + | T.Fn { T.meta = T.Map { T.value = meta } } + -> Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta) + | _ -> false) + | _ -> false + +let rec macroexpand ast env = + if is_macro_call ast env + then match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.value = f } -> macroexpand (f args) env + | _ -> ast) + | _ -> ast + else ast let rec eval_ast ast env = match ast with | T.Symbol s -> Env.get env ast | T.List { T.value = xs; T.meta = meta } -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Vector { T.value = xs; T.meta = meta } -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; - T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) @@ -50,9 +60,9 @@ and eval ast env = | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> (match (eval expr env) with | T.Fn { T.value = f; T.meta = meta } -> - let fn = T.Fn { T.value = f; is_macro = true; meta = meta } in - Env.set env key fn; fn - | _ -> raise (Invalid_argument "devmacro! value must be a fn")) + let fn = T.Fn { T.value = f; meta = Core.assoc [meta; kw_macro; (T.Bool true)]} + in Env.set env key fn; fn + | _ -> raise (Invalid_argument "defmacro! value must be a fn")) | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> (let sub_env = Env.make (Some env) in diff --git a/ocaml/step9_try.ml b/ocaml/step9_try.ml index 37c41ac..dd220db 100644 --- a/ocaml/step9_try.ml +++ b/ocaml/step9_try.ml @@ -14,28 +14,38 @@ let rec quasiquote ast = Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] | ast -> Types.list [Types.symbol "quote"; ast] -let rec macroexpand ast env = +let kw_macro = T.Keyword "macro" + +let is_macro_call ast env = match ast with | T.List { T.value = s :: args } -> (match (try Env.get env s with _ -> T.Nil) with - | T.Fn { T.value = f; T.is_macro = true } -> macroexpand (f args) env - | _ -> ast) - | _ -> ast + | T.Fn { T.meta = T.Map { T.value = meta } } + -> Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta) + | _ -> false) + | _ -> false + +let rec macroexpand ast env = + if is_macro_call ast env + then match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.value = f } -> macroexpand (f args) env + | _ -> ast) + | _ -> ast + else ast let rec eval_ast ast env = match ast with | T.Symbol s -> Env.get env ast | T.List { T.value = xs; T.meta = meta } -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Vector { T.value = xs; T.meta = meta } -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; - T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) @@ -50,8 +60,8 @@ and eval ast env = | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> (match (eval expr env) with | T.Fn { T.value = f; T.meta = meta } -> - let fn = T.Fn { T.value = f; is_macro = true; meta = meta } in - Env.set env key fn; fn + let fn = T.Fn { T.value = f; meta = Core.assoc [meta; kw_macro; (T.Bool true)]} + in Env.set env key fn; fn | _ -> raise (Invalid_argument "devmacro! value must be a fn")) | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> diff --git a/ocaml/stepA_interop.ml b/ocaml/stepA_interop.ml index 1b2e98d..e159de4 100644 --- a/ocaml/stepA_interop.ml +++ b/ocaml/stepA_interop.ml @@ -14,28 +14,38 @@ let rec quasiquote ast = Types.list [Types.symbol "cons"; quasiquote head; quasiquote (Types.list tail) ] | ast -> Types.list [Types.symbol "quote"; ast] -let rec macroexpand ast env = +let kw_macro = T.Keyword "macro" + +let is_macro_call ast env = match ast with | T.List { T.value = s :: args } -> (match (try Env.get env s with _ -> T.Nil) with - | T.Fn { T.value = f; T.is_macro = true } -> macroexpand (f args) env - | _ -> ast) - | _ -> ast + | T.Fn { T.meta = T.Map { T.value = meta } } + -> Types.MalMap.mem kw_macro meta && Types.to_bool (Types.MalMap.find kw_macro meta) + | _ -> false) + | _ -> false + +let rec macroexpand ast env = + if is_macro_call ast env + then match ast with + | T.List { T.value = s :: args } -> + (match (try Env.get env s with _ -> T.Nil) with + | T.Fn { T.value = f } -> macroexpand (f args) env + | _ -> ast) + | _ -> ast + else ast let rec eval_ast ast env = match ast with | T.Symbol s -> Env.get env ast | T.List { T.value = xs; T.meta = meta } -> T.List { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Vector { T.value = xs; T.meta = meta } -> T.Vector { T.value = (List.map (fun x -> eval x env) xs); - T.meta = meta; - T.is_macro = false} + T.meta = meta } | T.Map { T.value = xs; T.meta = meta } -> T.Map {T.meta = meta; - T.is_macro = false; T.value = (Types.MalMap.fold (fun k v m -> Types.MalMap.add (eval k env) (eval v env) m) @@ -50,8 +60,8 @@ and eval ast env = | T.List { T.value = [(T.Symbol { T.value = "defmacro!" }); key; expr] } -> (match (eval expr env) with | T.Fn { T.value = f; T.meta = meta } -> - let fn = T.Fn { T.value = f; is_macro = true; meta = meta } in - Env.set env key fn; fn + let fn = T.Fn { T.value = f; meta = Core.assoc [meta; kw_macro; (T.Bool true)]} + in Env.set env key fn; fn | _ -> raise (Invalid_argument "devmacro! value must be a fn")) | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.Vector { T.value = bindings }); body] } | T.List { T.value = [(T.Symbol { T.value = "let*" }); (T.List { T.value = bindings }); body] } -> diff --git a/ocaml/types.ml b/ocaml/types.ml index 75fade7..9df9761 100644 --- a/ocaml/types.ml +++ b/ocaml/types.ml @@ -1,6 +1,6 @@ module rec Types : sig - type 'a with_meta = { value : 'a; meta : t; is_macro : bool } + type 'a with_meta = { value : 'a; meta : t } and t = | List of t list with_meta | Vector of t list with_meta @@ -37,11 +37,11 @@ let to_bool x = match x with type mal_type = MalValue.t -let list x = Types.List { Types.value = x; meta = Types.Nil; Types.is_macro = false } -let map x = Types.Map { Types.value = x; meta = Types.Nil; Types.is_macro = false } -let vector x = Types.Vector { Types.value = x; meta = Types.Nil; Types.is_macro = false } -let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil; Types.is_macro = false } -let fn f = Types.Fn { Types.value = f; meta = Types.Nil; Types.is_macro = false } +let list x = Types.List { Types.value = x; meta = Types.Nil } +let map x = Types.Map { Types.value = x; meta = Types.Nil } +let vector x = Types.Vector { Types.value = x; meta = Types.Nil } +let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil } +let fn f = Types.Fn { Types.value = f; meta = Types.Nil } let rec list_into_map target source = match source with -- cgit v1.2.3 From f5fc0c98ee9c140077469146bbc9d8a77fdb02f3 Mon Sep 17 00:00:00 2001 From: Chouser Date: Fri, 30 Jan 2015 12:38:32 -0500 Subject: OCaml: Add time-ms --- ocaml/Makefile | 2 +- ocaml/core.ml | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/ocaml/Makefile b/ocaml/Makefile index e5b0ac2..72d159a 100644 --- a/ocaml/Makefile +++ b/ocaml/Makefile @@ -2,7 +2,7 @@ STEPS = step0_repl.ml step1_read_print.ml step2_eval.ml step3_env.ml \ step4_if_fn_do.ml step5_tco.ml step6_file.ml step7_quote.ml \ step8_macros.ml step9_try.ml stepA_interop.ml MODULES = types.ml reader.ml printer.ml env.ml core.ml -LIBS = str.cmxa +LIBS = str.cmxa unix.cmxa MAL_LIB = mal_lib.cmxa STEP_BINS = $(STEPS:%.ml=%) diff --git a/ocaml/core.ml b/ocaml/core.ml index 6d7b014..20f68b6 100644 --- a/ocaml/core.ml +++ b/ocaml/core.ml @@ -197,4 +197,7 @@ let init env = begin Env.set env (Types.symbol "swap!") (Types.fn (function T.Atom x :: T.Fn { T.value = f } :: args -> let v = f (!x :: args) in x := v; v | _ -> T.Nil)); + + Env.set env (Types.symbol "time-ms") + (Types.fn (function _ -> T.Int (truncate (1000.0 *. Unix.gettimeofday ())))); end -- cgit v1.2.3 From 1ac37587be54c9b3d51d042796f303d9f8e03594 Mon Sep 17 00:00:00 2001 From: Chouser Date: Fri, 30 Jan 2015 12:38:44 -0500 Subject: OCaml: Fix stepA command-line script running --- ocaml/stepA_interop.ml | 31 ++++++++++++++++--------------- 1 file changed, 16 insertions(+), 15 deletions(-) diff --git a/ocaml/stepA_interop.ml b/ocaml/stepA_interop.ml index e159de4..1aab28a 100644 --- a/ocaml/stepA_interop.ml +++ b/ocaml/stepA_interop.ml @@ -140,19 +140,20 @@ let rec main = if Array.length Sys.argv > 1 then ignore (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env) - else - ignore (rep "(println (str \"Mal [\" *host-language* \"]\"))" repl_env); - while true do - print_string "user> "; - let line = read_line () in - try - print_endline (rep line repl_env); - with End_of_file -> () - | Invalid_argument x -> - output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); - flush stderr - | _ -> - output_string stderr ("Erroringness!\n"); - flush stderr - done + else begin + ignore (rep "(println (str \"Mal [\" *host-language* \"]\"))" repl_env); + while true do + print_string "user> "; + let line = read_line () in + try + print_endline (rep line repl_env); + with End_of_file -> () + | Invalid_argument x -> + output_string stderr ("Invalid_argument exception: " ^ x ^ "\n"); + flush stderr + | _ -> + output_string stderr ("Erroringness!\n"); + flush stderr + done + end with End_of_file -> () -- cgit v1.2.3 From bc6448bce925d18ecb893e8e8ee10d2b2178b31a Mon Sep 17 00:00:00 2001 From: Chouser Date: Fri, 30 Jan 2015 12:53:52 -0500 Subject: OCaml: add to README.md --- README.md | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/README.md b/README.md index a4f74a2..f0963ea 100644 --- a/README.md +++ b/README.md @@ -18,6 +18,7 @@ Mal is implemented in 22 different languages: * Lua * GNU Make * mal itself +* OCaml * Perl * PHP * Postscript @@ -179,6 +180,14 @@ cd make make -f stepX_YYY.mk ``` +### OCaml 4.01.0 + +``` +cd ocaml +make +./stepX_YYY +``` + ### Perl 5.8 For readline line editing support, install Term::ReadLine::Perl or -- cgit v1.2.3