shithub: martian9

--- a/core.ml

+++ b/core.ml

@@ -17,7 +17,20 @@

 let mk_num x = Types.number x

 let mk_bool x = T.Bool x

+let seq = function

+  | T.List { T.value = xs } -> xs

+  | T.Vector { T.value = xs } -> xs

+  | _ -> []

+;;

 let init env =

+  Env.set

+    env

+    (Types.symbol "*arguments*")

+    (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 env (Types.symbol "+") (number_compare mk_num ( +. ));

   Env.set env (Types.symbol "-") (number_compare mk_num ( -. ));

   Env.set env (Types.symbol "*") (number_compare mk_num ( *. ));

@@ -59,5 +72,41 @@

     (Types.proc (function

         | [ T.List { T.value = xs } ] | [ T.Vector { T.value = xs } ] ->

           Types.number (float_of_int (List.length xs))

-        | _ -> Types.number 0.))

+        | _ -> Types.number 0.));

+  Env.set

+    env

+    (Types.symbol "display")

+    (Types.proc (function xs ->

+         T.String (String.concat " " (List.map (fun s -> Printer.print s false) xs))));

+  Env.set

+    env

+    (Types.symbol "string")

+    (Types.proc (function xs ->

+         T.String (String.concat "" (List.map (fun s -> Printer.print s false) xs))));

+  Env.set

+    env

+    (Types.symbol "read-string")

+    (Types.proc (function

+        | [ T.String x ] -> Reader.read x

+        | _ -> T.Nil));

+  Env.set

+    env

+    (Types.symbol "slurp")

+    (Types.proc (function

+        | [ T.String x ] -> T.String (Reader.slurp x)

+        | _ -> T.Nil));

+  Env.set env (Types.symbol "cons") (Types.proc (function xs -> Types.list xs));

+  (* | x :: xs -> Types.pair x xs

+   * | _ -> T.Nil)); *)

+  Env.set

+    env

+    (Types.symbol "concat")

+    (Types.proc

+       (let rec concat = function

+          | x :: y :: more -> concat (Types.list (seq x @ seq y) :: more)

+          | [ (T.List _ as x) ] -> x

+          | [ x ] -> Types.list (seq x)

+          | [] -> Types.list []

+        in

+        concat))

;;

--- a/env.ml

+++ b/env.ml

@@ -31,6 +31,6 @@

   | T.Symbol { T.value = key } ->

     (match find env sym with

     | Some found_env -> Data.find key !(found_env.data)

-    | None -> raise (Invalid_argument ("'" ^ key ^ "' not found")))

+    | None -> raise (Invalid_argument ("unknown symbol '" ^ key ^ "'")))

   | _ -> raise (Invalid_argument "get: not a symbol")

;;

--- a/m9.ml

+++ b/m9.ml

@@ -14,6 +14,23 @@

 let repl_env = Env.make (Some Core.base)

+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 = "unquote-splicing" }; head ] } :: tail

+      }

+  | T.Vector

+      { T.value =

+          T.List { T.value = [ T.Symbol { T.value = "unquote-splicing" }; 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

@@ -74,6 +91,9 @@

     if Types.to_bool (eval cond env) then eval then_expr env else eval else_expr env

   | T.List { T.value = [ T.Symbol { T.value = "if" }; cond; then_expr ] } ->

     if Types.to_bool (eval cond env) then eval then_expr env else T.Nil

+  | 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.Proc { T.value = f } :: args } -> f args

@@ -82,7 +102,7 @@

;;

 let nameplate = "Martian9 Scheme v0.1"

-let read str = Reader.read_str str

+let read str = Reader.read str

 let print exp = Printer.print exp true

 let rep str env = print (eval (read str) env)

@@ -89,16 +109,30 @@

 let rec main =

try

     Core.init Core.base;

-    print_endline nameplate;

-    while true do

-      print_string "m9> ";

-      let line = read_line () in

-      try print_endline (rep line repl_env) with

-      | End_of_file -> ()

-      | Invalid_argument x ->

-        output_string stderr ("Invalid argument: " ^ x ^ "\n");

-        flush stderr

-    done

+    Env.set

+      repl_env

+      (Types.symbol "eval")

+      (Types.proc (function

+          | [ ast ] -> eval ast repl_env

+          | _ -> T.Nil));

+    ignore

+      (rep

+         "(define load-file (lambda (f) (eval (read-string (string \"(begin \" (slurp f) \

+          \")\")))))"

+         repl_env);

+    if Array.length Sys.argv > 1

+    then print_endline (rep ("(load-file \"" ^ Sys.argv.(1) ^ "\")") repl_env)

+    else (

+      print_endline nameplate;

+      while true do

+        print_string "m9> ";

+        let line = read_line () in

+        try print_endline (rep line repl_env) with

+        | End_of_file -> ()

+        | Invalid_argument x ->

+          output_string stderr ("Invalid argument: " ^ x ^ "\n");

+          flush stderr

+      done)

   with

   | End_of_file -> ()

;;

--- a/mkfile

+++ b/mkfile

@@ -1,14 +1,14 @@

 BIN=m9

-# $BIN: types.cmx env.cmx core.cmx printer.cmx reader.cmx $BIN.cmx

-# 	ocamlopt -o $target str.cmxa $prereq

+FILES=\

+	types.ml\

+	env.ml\

+	reader.ml\

+	printer.ml\

+	core.ml

-$BIN: types.cmo env.cmo core.cmo printer.cmo reader.cmo $BIN.cmo

-	ocamlc -o $target str.cma $prereq

-$BIN.cmo : core.cmo printer.cmo reader.cmo

-env.cmo printer.cmo reader.cmo : types.cmo

-core.cmo : env.cmo

+$BIN:

+	ocamlc str.cma -o $target $FILES m9.ml

 %.cmx : %.ml

 	ocamlopt -c $stem.ml

--- a/notes.org

+++ b/notes.org

@@ -1,8 +1,14 @@

 * First things:

-** implement cons

+** TODO need an "unspecified" type?

+** TODO (display) should return unspecified

+** TODO implement (cons)

 Pairs should be preserved, I think

+Also, it should _only_ be pairs, nothing more.

+** TODO (define) needs to support function definitions

+Right now you need to use lambda

 * Read

-** quote and quasiquote symbols not supported

+** TODO quote and quasiquote symbols not supported

+The shortcuts work, but not the keywords

 * Eval

 * Print

 * Things to watch for

--- a/printer.ml

+++ b/printer.ml

@@ -18,8 +18,7 @@

   | T.Char c -> Char.escaped c

   | T.Nil -> "nil"

   | T.Comment -> "" (* TODO: this leaves a space in the output for block comments *)

-  (* | T.Pair { T.value = one, two } -> "(" ^ one ^ " . " ^ two ^ ")" *)

-  | T.Pair (p, q) -> "<pair unsupported>"

+  (* | T.Pair ({ T.value = one }, { T.value = two }) -> "(" ^ (print one readable) ^ " . " ^ (print two readable) ^ ")" *)

   | T.Proc p -> "#<proc>"

   | T.Symbol { T.value = s } -> s

   | T.Bytevector bv -> "<bytevector unsupported>"

@@ -29,7 +28,18 @@

     then string_of_float n.value

     else string_of_int (int_of_float n.value)

   | T.Port p -> "<port unsupported>"

-  | T.String s -> s (* need to handle escaping and stuff *)

+  | T.String s ->

+    if r

+    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 -> print s r) xs) ^ ")"

   | T.Vector { T.value = v } ->

--- a/reader.ml

+++ b/reader.ml

@@ -28,6 +28,33 @@

        (Str.full_split token_re str))

;;

+(* copied verbatim - must needs grok *)

+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 unescape_string token =

+  if Str.string_match string_re token 0

+  then (

+    let without_quotes = String.sub token 1 (String.length token - 2) in

+    gsub

+      (Str.regexp "\\\\.")

+      (function

+        | "\\n" -> "\n"

+        | x -> String.sub x 1 1)

+      without_quotes)

+  else (

+    output_string stderr "expected '\"', got EOF\n";

+    flush stderr;

+    raise End_of_file)

+;;

 let read_atom token =

   match token with

   | "null" -> T.Nil

@@ -43,7 +70,7 @@

         (match token.[1] with

         | '0' .. '9' -> Types.number (float_of_string token)

         | _ -> Types.symbol token))

-    | '"' -> T.String token (* TODO: unescape *)

+    | '"' -> T.String (unescape_string token)

     | _ -> Types.symbol token)

;;

@@ -61,11 +88,17 @@

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 ]; 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

     | "(" ->

       let list_reader = read_list ")" { list_form = []; tokens } in

       { form = Types.list list_reader.list_form; tokens = list_reader.tokens }

@@ -76,4 +109,12 @@

       if token.[0] = ';' then read_form tokens else { form = read_atom token; tokens })

;;

-let read_str str = (read_form (tokenize str)).form

+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 read str = (read_form (tokenize str)).form

--- a/types.ml

+++ b/types.ml

@@ -10,7 +10,7 @@

     | Char of char

     | Nil

     | Comment

-    | Pair of t * t

+    (* | Pair of t with_meta * t list *)

     | Proc of (t list -> t) with_meta

     | Symbol of string with_meta

     | Bytevector of t list

@@ -47,6 +47,8 @@

;;

 let list x = Types.List { Types.value = x; meta = Types.Nil }

+(* let pair x xs = Types.Pair ({ Types.value = x; meta = Types.Nil }, Types.List { Types.value = xs; meta = Types.Nil }) *)

 let proc x = Types.Proc { Types.value = x; meta = Types.Nil }

 let symbol x = Types.Symbol { Types.value = x; meta = Types.Nil }

 let vector x = Types.Vector { Types.value = x; meta = Types.Nil }