shithub: martian9

Info  •  Files  •  Log  •  Branches

some macro stuff

--- a/core.ml

+++ b/core.ml

@@ -1,6 +1,7 @@

 module T = Types.Types

 let base = Env.make None

+let kw_macro = T.String "macro"

 let number_compare t f =

   Types.proc (function

@@ -26,6 +27,12 @@

 let init env =

   Env.set

     env

+    (Types.symbol "raise")

+    (Types.proc (function

+        | [ ast ] -> raise (Types.M9exn ast)

+        | _ -> T.Nil));

+  Env.set

+    env

     (Types.symbol "*arguments*")

     (Types.list

        (if Array.length Sys.argv > 1

@@ -39,6 +46,17 @@

   Env.set env (Types.symbol "<=") (simple_compare mk_bool ( <= ));

   Env.set env (Types.symbol ">") (simple_compare mk_bool ( > ));

   Env.set env (Types.symbol ">=") (simple_compare mk_bool ( >= ));

+  Env.set

+    env

+    (Types.symbol "proc?")

+    (Types.proc (function

+        | [ T.Proc { T.meta = T.Map { T.value = meta } } ] ->

+          mk_bool

+            (not

+               (Types.M9map.mem kw_macro meta

+               && Types.to_bool (Types.M9map.find kw_macro meta)))

+        | [ T.Proc _ ] -> T.Bool true

+        | _ -> T.Bool false));

   Env.set

     env

     (Types.symbol "number?")

--- a/m9.ml

+++ b/m9.ml

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

   | ast -> Types.list [ Types.symbol "quote"; ast ]

 ;;

+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.Proc { T.meta = T.Map { T.value = meta } } ->

+      Types.M9map.mem Core.kw_macro meta

+      && Types.to_bool (Types.M9map.find Core.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.Proc { 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

--- a/printer.ml

+++ b/printer.ml

@@ -17,7 +17,8 @@

   | T.Bool false -> "#f"

   | T.Char c -> "#\\" ^ Char.escaped c

   | T.Nil -> "nil"

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

+  | T.Map _ | T.Comment ->

+    "" (* TODO: this leaves a space in the output for block comments *)

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

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

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

--- a/types.ml

+++ b/types.ml

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

   and t =

     | List of t list with_meta

+    | Vector of t list with_meta

+    | Map of t M9map.t with_meta

     | Bool of bool

     | Char of char

     | Nil

@@ -18,7 +20,6 @@

     | Number of float with_meta

     | Port of bool (* not sure how to represent this *)

     | String of string

-    | Vector of t list with_meta

     | Record of t with_meta

 end =

   Types

@@ -33,8 +34,18 @@

   let compare = Stdlib.compare

 end

+and M9map : (Map.S with type key = Value.t) = Map.Make (Value)

+

+let to_bool x =

+  match x with

+  | Types.Nil | Types.Bool false -> false

+  | _ -> true

+;;

+

 type m9type = Value.t

+exception M9exn of Types.t

+

 let to_bool x =

   match x with

   | Types.Nil | Types.Bool false -> false

@@ -47,6 +58,7 @@

 ;;

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

+let map x = Types.Map { 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 }