Skip to content
Permalink
Browse files

Implemented code generation of #import forms.

  • Loading branch information...
artob committed May 24, 2018
1 parent 3f81b1d commit 4693a1b730dbbd8093ef06b63c386b8df1e623f2
Showing with 54 additions and 27 deletions.
  1. +16 −7 src/Name.ml
  2. +5 −3 src/Name.mli
  3. +1 −1 src/Node.ml
  4. +8 −4 src/target/Lisp.ml
  5. +24 −12 src/target/Lua.ml
@@ -3,9 +3,7 @@
open DRY.Core
open DRY.Text

module Symbol = DRY.Core.Symbol

type t = Symbol.t * Symbol.t list
type t = string * string list

let is_valid str =
not (UTF8.String.starts_with_char str '/') &&
@@ -14,13 +12,24 @@ let is_valid str =

let make ?(package = "dry") str =
match is_valid str with
| true ->
let strs = (String.split_on_char '/' str) in
Symbol.of_string package, List.map Symbol.of_string strs
| true -> package, (String.split_on_char '/' str)
| false -> Syntax.semantic_error "invalid name"

let of_string str =
make str (* TODO: parse package name *)

let to_string (pkg, name) =
(Symbol.to_string pkg) ^ ":" ^ (String.concat "/" (List.map Symbol.to_string name))
pkg ^ ":" ^ (String.concat "/" name)

let package (pkg, name) = pkg

let dirname ?(sep = "/") (pkg, name) =
List.rev name |> List.tl |> List.rev |> String.concat sep

let basename (pkg, name) =
let rec last = function
| [] -> assert false
| [s] -> s
| _ :: tl -> last tl
in
last name
@@ -2,12 +2,14 @@

(** Names. *)

module Symbol = DRY.Core.Symbol

type t = Symbol.t * Symbol.t list
type t = string * string list

val make : ?package:string -> string -> t

val of_string : string -> t

val to_string : t -> string

val package : t -> string
val dirname : ?sep:string -> t -> string
val basename : t -> string
@@ -62,7 +62,7 @@ let rec print ppf = function
| Export names ->
pp_print_char ppf '(';
pp_print_char ppf '#';
pp_print_string ppf "import";
pp_print_string ppf "export";
pp_print_char ppf ' ';
pp_print_list~pp_sep:pp_print_space pp_print_string ppf (List.map Name.to_string names);
pp_print_char ppf ')'
@@ -37,12 +37,15 @@ let datum = function
| Datum.Tensor x -> tensor x
| Datum.Unit _ -> not_implemented () (* TODO: implement *)

let translate_name (pkg, name) =
Target.keyword (String.concat "/" ("dry" :: name))

let rec translate_node = function
| Node.Literal x -> datum x
| Node.Id x -> Target.symbol x
| Node.Name _ -> not_implemented () (* TODO: implement *)
| Node.Import names -> not_implemented () (* TODO: implement *)
| Node.Export names -> not_implemented () (* TODO: implement *)
| Node.Id id -> Target.symbol id
| Node.Name name -> translate_name name
| Node.Import names -> Target.form ((Target.keyword "import-from") :: (List.map translate_name names))
| Node.Export names -> Target.form ((Target.keyword "export") :: (List.map translate_name names))
| Node.Apply (op, args) -> Target.form ((translate_node op) :: (List.map translate_node args))
| Node.MathNeg a -> Target.form [symbol "-"; translate_node a]
| Node.MathAdd (a, b) -> Target.form [symbol "+"; translate_node a; translate_node b]
@@ -65,6 +68,7 @@ let compile_node ppf node =
translate_node node |> Target.Expression.print ppf

let compile_module ppf module_ =
(* TODO: defpackage *)
translate_module module_ |> Target.Program.print ppf

let compile_program ppf program =
@@ -46,19 +46,22 @@ let datum = function
| Datum.Tensor x -> tensor x
| Datum.Unit _ -> not_implemented () (* TODO: implement *)

let translate_name (pkg, name) =
String.concat "." (pkg :: name)

let rec translate_expr = function
| Node.Literal x -> datum x
| Node.Id x -> Target.var (Symbol.to_string x)
| Node.Name (_, []) -> assert false
| Node.Name (pkg, name) -> Target.var (String.concat "." ("dry" :: (List.map Symbol.to_string name)))
| Node.Import names -> not_implemented ()
| Node.Export names -> not_implemented ()
| Node.Name name -> Target.var (translate_name name)
| Node.Import names -> assert false
| Node.Export names -> assert false
| Node.Apply (op, args) ->
begin match op with
| Node.Id fname ->
Target.Expression.FunctionCall (fname, (List.map translate_expr args))
| Node.Name (pkg, name) ->
let fname = Symbol.of_string (String.concat "." (List.map Symbol.to_string (pkg :: name))) in
| Node.Name fname ->
let fname = Symbol.of_string (translate_name fname) in
Target.Expression.FunctionCall (fname, (List.map translate_expr args))
| _ -> failwith "invalid function call" (* TODO: improve error *)
end
@@ -74,20 +77,29 @@ let rec translate_expr = function
| Node.Loop body -> assert false

and translate_node = function
| Node.Loop body -> Target.Statement.While (Target.of_bool true, List.map translate_node body)
| node -> Target.Statement.LocalVarBind (Target.Name.of_string "_", translate_expr node)
| Node.Import names ->
let require_name name =
let (pkg, basename, dirname) = Name.package name, Name.basename name, Name.dirname name in
Target.Statement.LocalVarBind
(Target.Name.of_string basename,
Target.call "require" [Target.of_string (pkg ^ "/" ^ dirname)])
in
names |> List.map require_name
| Node.Export names -> not_implemented () (* TODO: implement *)
| Node.Loop body -> [Target.Statement.While (Target.of_bool true, List.concat (List.map translate_node body))]
| node -> [Target.Statement.LocalVarBind (Target.Name.of_string "_", translate_expr node)]

let translate_module (module_ : Module.t) =
not_implemented ()
not_implemented () (* TODO: implement *)

let translate_program (program : Program.t) =
not_implemented ()
not_implemented () (* TODO: implement *)

let compile_node ppf node =
Target.Block.make [translate_node node] |> Target.Block.print ppf
Target.Block.make (translate_node node) |> Target.Block.print ppf

let compile_module ppf module_ =
not_implemented ()
not_implemented () (* TODO: implement *)

let compile_program ppf program =
not_implemented ()
not_implemented () (* TODO: implement *)

0 comments on commit 4693a1b

Please sign in to comment.
You can’t perform that action at this time.