├── test ├── bundler_simple │ ├── char.ml │ ├── mod2.ml │ ├── entry.ml │ └── mod.ml ├── bundler_dune │ ├── dune-project │ ├── we │ │ ├── mo │ │ │ ├── dune │ │ │ ├── module_second.ml │ │ │ └── module.ml │ │ ├── we.ml │ │ └── dune │ ├── wo │ │ ├── dune │ │ └── wo.ml │ ├── bin │ │ ├── dune │ │ └── exec.ml │ └── test │ │ ├── dune │ │ └── test.ml ├── bundler_dune.ml ├── bundler_simple.ml ├── factorial.ml ├── anon_function.ml ├── let_bind.ml ├── simple_func.ml ├── dune ├── conditional.ml ├── unit_value.ml ├── global_names.ml ├── definition.ml ├── comment.ml ├── tuple.ml ├── file_io.ml ├── operator.ml ├── value_match.ml ├── range_pattern.ml ├── filename_.ml ├── printf_.ml ├── bytes.ml ├── when_match.ml ├── arith.ml ├── let_and.ml ├── or_pattern.ml ├── closure_currying.ml ├── array_.ml ├── variant.ml ├── string_.ml ├── list_.ml ├── equality.ml ├── tester.ml ├── record.ml ├── module.ml └── stdlib_.ml ├── dune-project ├── bin ├── dune └── mlmlc.ml ├── dev ├── ci_script.sh ├── exec.sh ├── start.sh ├── ci_coverage.sh ├── Dockerfile ├── init.sh └── self_host.sh ├── mlml ├── compile.ml ├── tree │ ├── namespace.ml │ ├── dune │ ├── unaryop.ml │ ├── format_string.ml │ ├── simple_set.ml │ ├── binop.ml │ ├── type_expression.ml │ ├── path.ml │ ├── module.ml │ ├── pattern.ml │ └── expression.ml ├── analysis │ ├── analysis.ml │ ├── dune │ ├── format_string.ml │ ├── alpha.ml │ ├── closure.ml │ └── resolve.ml ├── codegen │ ├── dune │ ├── output_buffer.ml │ ├── codegen.ml │ └── builder.ml ├── lexer │ ├── dune │ └── lexer.ml ├── dune ├── parser │ ├── dune │ ├── compilation_unit.ml │ ├── path.ml │ ├── type_expression.ml │ ├── pattern.ml │ ├── module.ml │ └── expression.ml └── bundler │ ├── dune │ ├── bundler.ml │ ├── modules_cache.ml │ ├── dependency_tree.ml │ ├── find_projects.ml │ ├── find_dependencies.ml │ └── build_tree.ml ├── .ocamlformat ├── stdlib ├── printf.ml ├── char.ml ├── sys.ml ├── pervasives2.ml ├── filename.ml ├── hashtbl.ml ├── array.ml ├── bytes.ml ├── pervasives.ml ├── string.ml └── list.ml ├── .travis.yml ├── Dockerfile ├── LICENSE ├── .gitignore ├── .dockerignore └── README.md /test/bundler_simple/char.ml: -------------------------------------------------------------------------------- 1 | let fake = 'c' 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.6) 2 | (using fmt 1.0) 3 | -------------------------------------------------------------------------------- /test/bundler_dune/dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.6) 2 | -------------------------------------------------------------------------------- /test/bundler_dune/we/mo/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mo)) 3 | -------------------------------------------------------------------------------- /test/bundler_dune/we/mo/module_second.ml: -------------------------------------------------------------------------------- 1 | let v = 43 2 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name mlmlc) 3 | (libraries mlml)) 4 | -------------------------------------------------------------------------------- /test/bundler_dune/we/mo/module.ml: -------------------------------------------------------------------------------- 1 | let f x = Module_second.v * x 2 | -------------------------------------------------------------------------------- /test/bundler_dune/we/we.ml: -------------------------------------------------------------------------------- 1 | let the_function x = x * Wo.the_value 2 | -------------------------------------------------------------------------------- /dev/ci_script.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | BISECT_ENABLE=yes dune runtest 4 | -------------------------------------------------------------------------------- /mlml/compile.ml: -------------------------------------------------------------------------------- 1 | let f file = Bundler.f file |> Analysis.f |> Codegen.f 2 | -------------------------------------------------------------------------------- /test/bundler_dune/we/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name we) 3 | (libraries wo)) 4 | -------------------------------------------------------------------------------- /test/bundler_dune/wo/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name wo) 3 | (libraries mo)) 4 | -------------------------------------------------------------------------------- /test/bundler_dune/wo/wo.ml: -------------------------------------------------------------------------------- 1 | let the_value = Mo.Module.f Mo.Module_second.v 2 | -------------------------------------------------------------------------------- /test/bundler_dune/bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name exec) 3 | (libraries we)) 4 | -------------------------------------------------------------------------------- /test/bundler_dune/test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names test) 3 | (libraries we)) 4 | -------------------------------------------------------------------------------- /test/bundler_dune/test/test.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | (* dummy *) 3 | assert true 4 | -------------------------------------------------------------------------------- /test/bundler_simple/mod2.ml: -------------------------------------------------------------------------------- 1 | let print = List.iter print_int 2 | let id x = x 3 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = janestreet 2 | break-cases = fit 3 | wrap-comments = true 4 | -------------------------------------------------------------------------------- /mlml/tree/namespace.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Ctor 3 | | Field 4 | | Var 5 | | Type 6 | -------------------------------------------------------------------------------- /test/bundler_dune/bin/exec.ml: -------------------------------------------------------------------------------- 1 | open We 2 | ;; 3 | 4 | print_int (the_function 10) 5 | -------------------------------------------------------------------------------- /dev/exec.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | source "$(dirname $0)/init.sh" 4 | 5 | exec_docker "$@" 6 | -------------------------------------------------------------------------------- /dev/start.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | source "$(dirname $0)/init.sh" 4 | 5 | exec_docker 6 | -------------------------------------------------------------------------------- /mlml/analysis/analysis.ml: -------------------------------------------------------------------------------- 1 | let f x = Format_string.f x |> Resolve.f |> Alpha.f |> Closure.f 2 | -------------------------------------------------------------------------------- /mlml/tree/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name tree) 3 | (preprocess (pps bisect_ppx -conditional))) 4 | 5 | -------------------------------------------------------------------------------- /mlml/codegen/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name codegen) 3 | (libraries parser) 4 | (preprocess (pps bisect_ppx -conditional))) 5 | -------------------------------------------------------------------------------- /mlml/lexer/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name lexer) 3 | (libraries tree) 4 | (preprocess (pps bisect_ppx -conditional))) 5 | 6 | -------------------------------------------------------------------------------- /mlml/analysis/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name analysis) 3 | (libraries parser) 4 | (preprocess (pps bisect_ppx -conditional))) 5 | -------------------------------------------------------------------------------- /mlml/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name mlml) 3 | (libraries bundler analysis codegen) 4 | (preprocess (pps bisect_ppx -conditional))) 5 | -------------------------------------------------------------------------------- /mlml/parser/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name parser) 3 | (libraries lexer tree) 4 | (preprocess (pps bisect_ppx -conditional))) 5 | 6 | -------------------------------------------------------------------------------- /test/bundler_simple/entry.ml: -------------------------------------------------------------------------------- 1 | ;; 2 | print_int (Mod.f 40); 3 | print_int Mod.Sub.v; 4 | Mod.list_f [1; 2; 3]; 5 | print_int (Mod2.id 1) 6 | -------------------------------------------------------------------------------- /mlml/bundler/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name bundler) 3 | (libraries lexer parser tree) 4 | (preprocess (pps bisect_ppx -conditional))) 5 | 6 | -------------------------------------------------------------------------------- /mlml/tree/unaryop.ml: -------------------------------------------------------------------------------- 1 | type t = 2 | | Positate 3 | | Negate 4 | 5 | let string_of_unaryop = function Positate -> "+" | Negate -> "-" 6 | -------------------------------------------------------------------------------- /test/bundler_simple/mod.ml: -------------------------------------------------------------------------------- 1 | let v = 10 2 | let f x = v + x 3 | 4 | module Sub = struct 5 | let v = 42 6 | end 7 | 8 | let list_f = Mod2.print 9 | -------------------------------------------------------------------------------- /bin/mlmlc.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | match Sys.argv with 3 | | [|_; file|] -> Mlml.Compile.f file |> print_endline 4 | | _ -> failwith "Invalid number of arguments" 5 | ;; 6 | -------------------------------------------------------------------------------- /stdlib/printf.ml: -------------------------------------------------------------------------------- 1 | let ksprintf k ff = ff (fun s -> k s) 2 | let sprintf = ksprintf (fun x -> x) 3 | let printf = ksprintf (fun x -> print_string x) 4 | let eprintf = ksprintf (fun x -> prerr_string x) 5 | -------------------------------------------------------------------------------- /test/bundler_dune.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | (* TODO: Remove hardcoded path *) 3 | let current_dir = "../../../test/" in 4 | Tester.file (Filename.concat current_dir "./bundler_dune/bin/exec.ml") "18490" 5 | ;; 6 | -------------------------------------------------------------------------------- /test/bundler_simple.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | (* TODO: Remove hardcoded path *) 3 | let current_dir = "../../../test/" in 4 | Tester.file (Filename.concat current_dir "./bundler_simple/entry.ml") "50421231" 5 | ;; 6 | -------------------------------------------------------------------------------- /test/factorial.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.expr 3 | {| 4 | let rec factorial n = 5 | if n = 0 6 | then 1 7 | else n * factorial (n - 1) 8 | in factorial 5 9 | |} 10 | ;; 11 | -------------------------------------------------------------------------------- /test/anon_function.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.expr "(fun x -> x + 4) 2"; 3 | Tester.expr {| 4 | let f = fun x -> x * 10 in 5 | f 4 6 | |}; 7 | Tester.expr {| 8 | let f = fun (a, b) -> a + b in 9 | f (1, 2) 10 | |} 11 | ;; 12 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: generic 2 | sudo: required 3 | dist: xenial 4 | services: 5 | - docker 6 | 7 | install: 8 | - ./dev/init.sh 9 | 10 | script: 11 | - ./dev/exec.sh ./dev/ci_script.sh 12 | 13 | after_success: 14 | - ./dev/exec.sh ./dev/ci_coverage.sh 15 | -------------------------------------------------------------------------------- /dev/ci_coverage.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | bisect-ppx-report \ 4 | -I _build/default/ \ 5 | -coveralls coverage.json \ 6 | -service-name travis-ci \ 7 | -service-job-id $TRAVIS_JOB_ID \ 8 | `find . -name 'bisect*.out'` 9 | curl -L -F json_file=@./coverage.json https://coveralls.io/api/v1/jobs 10 | -------------------------------------------------------------------------------- /test/let_bind.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.expr "let x = 10 in x + 33"; 3 | Tester.expr "let abc = 10 in abc + 33"; 4 | Tester.expr {| 5 | let x = 10 in 6 | let y = 3 in 7 | x + y + 30 8 | |}; 9 | Tester.expr {| 10 | let x = 10 in 11 | let x' = 3 in 12 | x + x' + 30 13 | |} 14 | ;; 15 | -------------------------------------------------------------------------------- /Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam2:alpine 2 | 3 | RUN opam install dune bisect_ppx 4 | 5 | COPY . /src 6 | WORKDIR /src 7 | 8 | RUN . ~/.profile \ 9 | && sudo dune build bin/mlmlc.exe 10 | 11 | FROM alpine 12 | 13 | COPY --from=0 /src/_build/default/bin/mlmlc.exe /usr/local/bin/mlmlc 14 | ENTRYPOINT ["/usr/local/bin/mlmlc"] 15 | -------------------------------------------------------------------------------- /mlml/tree/format_string.ml: -------------------------------------------------------------------------------- 1 | type kind = 2 | | Const of string 3 | | Int 4 | | Char 5 | | String 6 | 7 | let string_of_kind = function 8 | | Const s -> s 9 | | Int -> "(d)" 10 | | Char -> "(c)" 11 | | String -> "(s)" 12 | ;; 13 | 14 | let string_of_format_string l = List.map string_of_kind l |> String.concat "" 15 | -------------------------------------------------------------------------------- /test/simple_func.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.expr "let f x = x + 3 in f 40"; 3 | Tester.expr {| 4 | let f x = x + 3 in 5 | let g x = 10 * x in 6 | f (g 4) 7 | |}; 8 | Tester.expr {| 9 | let f x = x + 3 in 10 | let g x = 10 * x in 11 | f 0 + g 4 12 | |}; 13 | Tester.expr "let f x = x * 3 in f 1 -4" 14 | ;; 15 | -------------------------------------------------------------------------------- /test/dune: -------------------------------------------------------------------------------- 1 | (tests 2 | (names arith let_bind simple_func conditional factorial global_names tuple definition variant value_match or_pattern when_match anon_function closure_currying comment equality let_and list_ string_ record range_pattern module operator unit_value bytes printf_ array_ stdlib_ bundler_simple bundler_dune file_io filename_) 3 | (libraries mlml unix)) 4 | -------------------------------------------------------------------------------- /test/conditional.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.expr "if true then 43 else 10"; 3 | Tester.expr "if false then 10 else 40 + 3"; 4 | Tester.expr 5 | {| 6 | if 1 = 2 7 | then 4 8 | else ( 9 | let a = 10 in 10 | if a * 2 = 20 11 | then 43 12 | else 0 13 | ) 14 | |}; 15 | Tester.f {| 16 | if false 17 | then print_endline "true"; 18 | print_endline "outer!" 19 | |} 20 | ;; 21 | -------------------------------------------------------------------------------- /test/unit_value.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.f "if true then print_int 1"; 3 | Tester.f {| 4 | let b = true in 5 | if b 6 | then print_int 1; 7 | if not b 8 | then print_int 2 9 | |}; 10 | Tester.f {| 11 | let () = 12 | print_string "hello"; 13 | print_string "world" 14 | |}; 15 | Tester.f 16 | {| 17 | let rec f = function 18 | | 0 -> () 19 | | i -> print_int i; f @@ i - 1 20 | in f 10 21 | |} 22 | ;; 23 | -------------------------------------------------------------------------------- /mlml/parser/compilation_unit.ml: -------------------------------------------------------------------------------- 1 | (* Parse the compilation unit. *) 2 | (* https://caml.inria.fr/pub/docs/manual-ocaml/compunit.html#unit-implementation *) 3 | 4 | module Mod = Module 5 | 6 | type ast = Mod.module_item list 7 | type t = ast 8 | 9 | let f tokens = 10 | let _rest, ast = Mod.parse_module_items tokens in 11 | ast 12 | ;; 13 | 14 | let string_of_ast = Mod.string_of_module_items 15 | -------------------------------------------------------------------------------- /test/global_names.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | (* starting with underscore to suppress warning *) 3 | Tester.expr {| 4 | let _f x = x + 3 in 5 | let _f x = 10 * x + 3 in 6 | _f 4 7 | |}; 8 | Tester.expr 9 | {| 10 | let f x = ( 11 | if x = 0 12 | then x + 3 13 | else x * 3 14 | ) in 15 | let g x = ( 16 | if x = 9 17 | then x + 3 18 | else x * 3 19 | ) in 20 | g (f 3) 21 | |} 22 | ;; 23 | -------------------------------------------------------------------------------- /test/definition.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.f {| 3 | ;; 4 | print_int 10 5 | ;; 6 | |}; 7 | Tester.f {| 8 | let var = 1 ;; 9 | print_int var 10 | |}; 11 | Tester.f {| 12 | let var = 1 13 | let f a = a * 2 14 | let d = f var ;; 15 | print_int var 16 | |}; 17 | Tester.f 18 | {| 19 | let f a = a + 1 ;; 20 | let v = f 2 ;; 21 | let g x = print_int x ;; 22 | ignore @@ g v 23 | |}; 24 | Tester.f {| 25 | let a = 1 ;; 26 | let b = a in 27 | print_int b 28 | |} 29 | ;; 30 | -------------------------------------------------------------------------------- /dev/Dockerfile: -------------------------------------------------------------------------------- 1 | FROM ocaml/opam2:debian-stable 2 | 3 | ARG LOCAL_UID 4 | ARG LOCAL_GID 5 | 6 | RUN sudo usermod -u ${LOCAL_UID} -o opam 7 | RUN sudo groupmod -g ${LOCAL_GID} -o opam 8 | 9 | RUN opam install dune bisect_ppx 10 | RUN sudo apt-get update 11 | RUN sudo apt-get install -y inotify-tools libgc-dev 12 | 13 | ENV SRC_DIR=${HOME}/src 14 | 15 | VOLUME ${SRC_DIR} 16 | WORKDIR ${SRC_DIR} 17 | 18 | ENV MLML_STDLIB_DIR ${SRC_DIR}/stdlib 19 | 20 | CMD ["dune", "runtest", "-w"] 21 | -------------------------------------------------------------------------------- /test/comment.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.expr "1 + (* comment *) 2"; 3 | Tester.expr 4 | {| 5 | let (* comment *) f x = x + 1 (* comment *) in 6 | f (* comment *) 2 7 | |}; 8 | Tester.f 9 | {| 10 | (* comment *) 11 | let f (* comment *) x = x + 1 (* comment *) ;; 12 | print_int (f 2) 13 | |}; 14 | Tester.f 15 | {| 16 | (* com (* comment *) ent *) 17 | (* (* comment *) *) 18 | let f (* comment (*comment*) *) x = x + 1 (*(*comment*) comment *) ;; 19 | print_int (f (** comment **) 2) 20 | |} 21 | ;; 22 | -------------------------------------------------------------------------------- /stdlib/char.ml: -------------------------------------------------------------------------------- 1 | external code : char -> int = "_mlml_identity" 2 | external chr : int -> char = "_mlml_identity" 3 | 4 | (* simplified version *) 5 | let escaped = function 6 | | '\'' -> "\\'" 7 | | '\\' -> "\\\\" 8 | | '\n' -> "\\n" 9 | | '\t' -> "\\t" 10 | | '\r' -> "\\r" 11 | | '\b' -> "\\b" 12 | | c -> (* TODO: Use String.make 1 c *) 13 | Bytes.make 1 c |> Bytes.to_string 14 | ;; 15 | 16 | let lowercase_ascii c = match c with 'A' .. 'Z' -> chr (code c + 32) | _ -> c 17 | let uppercase_ascii c = match c with 'a' .. 'z' -> chr (code c - 32) | _ -> c 18 | -------------------------------------------------------------------------------- /stdlib/sys.ml: -------------------------------------------------------------------------------- 1 | external _mlml_get_argv : unit -> string array = "_mlml_get_argv" 2 | external file_exists : string -> bool = "_mlml_file_exists" 3 | external is_directory : string -> bool = "_mlml_is_directory" 4 | external getcwd : unit -> string = "_mlml_getcwd" 5 | external getenv : string -> string = "_mlml_getenv" 6 | external _has_env : string -> bool = "_mlml_has_env" 7 | external readdir : string -> string array = "_mlml_readdir" 8 | 9 | let argv = _mlml_get_argv () 10 | 11 | let getenv_opt name = 12 | match _has_env name with true -> Some (getenv name) | false -> None 13 | ;; 14 | -------------------------------------------------------------------------------- /mlml/parser/path.ml: -------------------------------------------------------------------------------- 1 | module L = Lexer 2 | module T = Tree.Path 3 | 4 | (* parse path from token list *) 5 | let try_parse_path tokens = 6 | let rec aux = function 7 | | L.CapitalIdent ident :: L.Dot :: rest -> 8 | let rest, acc = aux rest in 9 | rest, ident :: acc 10 | | L.CapitalIdent ident :: rest | L.LowerIdent ident :: rest -> rest, [ident] 11 | | rest -> rest, [] 12 | in 13 | match aux tokens with rest, [] -> rest, None | rest, l -> rest, Some (T.Path l) 14 | ;; 15 | 16 | let parse_path tokens = 17 | match try_parse_path tokens with 18 | | rest, Some path -> rest, path 19 | | _ -> failwith "path is expected" 20 | ;; 21 | -------------------------------------------------------------------------------- /test/tuple.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.expr "let a, b = 1, 2 in a + b"; 3 | Tester.expr {| 4 | let a = 1, 2, 3 in 5 | let x, y, z = a in 6 | x * y + z 7 | |}; 8 | Tester.expr 9 | {| 10 | let f a = a, a+1, a+2, a+3 in 11 | let a, b, c, d = f 10 in 12 | a + b + c + d 13 | |}; 14 | Tester.expr {| 15 | let a, (b, c) = 1, (2, 3) in 16 | a + b * c 17 | |}; 18 | Tester.expr {| 19 | let add (a, b) = a + b in 20 | add (1, 2) 21 | |}; 22 | Tester.expr 23 | {| 24 | let add (a, b, (d, e)) = a * b + d * e in 25 | let v, t = 10, (3, 4) in 26 | add (5, v, t) 27 | |}; 28 | Tester.expr {| 29 | let t = (1, fun x -> x + 1) in 30 | let v, f = t in 31 | f v 32 | |} 33 | ;; 34 | -------------------------------------------------------------------------------- /stdlib/pervasives2.ml: -------------------------------------------------------------------------------- 1 | let string_of_int i = 2 | let string_of_pos i = 3 | let char_of_digit d = char_of_int (int_of_char '0' + d) in 4 | let rec len = function i when i < 10 -> 1 | i -> 1 + len (i / 10) in 5 | let rec digit_of n = function 6 | | 0 -> char_of_digit @@ (n mod 10) 7 | | i -> digit_of (n / 10) (i - 1) 8 | in 9 | let l = len i in 10 | let f idx = digit_of i @@ (l - idx - 1) in 11 | String.init l f 12 | in 13 | if i < 0 then "-" ^ string_of_pos (-i) else string_of_pos i 14 | ;; 15 | 16 | let print_int i = print_string @@ string_of_int i 17 | 18 | module MlmlInternalFormat = struct 19 | let fmt_int d = string_of_int d 20 | let fmt_string s = s 21 | let fmt_char c = String.make 1 c 22 | end 23 | -------------------------------------------------------------------------------- /test/file_io.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.f 3 | {| 4 | let ic = open_in "/etc/issue" in 5 | let content = really_input_string ic @@ in_channel_length ic in 6 | close_in ic; 7 | print_endline content 8 | |}; 9 | Tester.f 10 | {| 11 | match Sys.getenv_opt "USER" with 12 | | Some v -> Printf.printf "Some %s\n" v 13 | | None -> print_endline "None" 14 | |}; 15 | Tester.bool_expr {| 16 | Sys.is_directory "/etc" 17 | |}; 18 | Tester.bool_expr {| 19 | Sys.is_directory "/etc/issue" 20 | |}; 21 | Tester.bool_expr {| 22 | Sys.file_exists "/etc" 23 | |}; 24 | Tester.bool_expr {| 25 | Sys.file_exists "/etc/issue" 26 | |}; 27 | Tester.expr 28 | {| 29 | (* TODO: Test against the content *) 30 | Sys.readdir "/etc" |> Array.length 31 | |} 32 | ;; 33 | -------------------------------------------------------------------------------- /dev/init.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -euo pipefail 4 | 5 | readonly IMAGE_NAME=mlml-dev 6 | 7 | if docker version &> /dev/null; then 8 | readonly DOCKER=docker 9 | else 10 | readonly DOCKER="sudo docker" 11 | fi 12 | 13 | # Build if the image is not found 14 | [ -z "$($DOCKER image ls -q ${IMAGE_NAME})" ] \ 15 | && $DOCKER build "$(dirname $0)" \ 16 | -t ${IMAGE_NAME} \ 17 | --build-arg LOCAL_UID=$(id -u $USER) \ 18 | --build-arg LOCAL_GID=$(id -g $USER) 19 | 20 | function exec_docker() { 21 | # TRAVIS_JOB_ID is for CI environment 22 | $DOCKER run --rm -it \ 23 | --ulimit stack=4294967296 \ 24 | -v $(pwd):/home/opam/src \ 25 | -e TRAVIS_JOB_ID=${TRAVIS_JOB_ID:-} \ 26 | ${IMAGE_NAME} "$@" 27 | } 28 | -------------------------------------------------------------------------------- /stdlib/filename.ml: -------------------------------------------------------------------------------- 1 | let is_relative path = path.[0] <> '/' 2 | let concat a b = a ^ "/" ^ b 3 | 4 | let chop_suffix path suff = 5 | let len = String.length path - String.length suff in 6 | String.sub path 0 len 7 | ;; 8 | 9 | let check_suffix path suff = 10 | let len_suff = String.length suff in 11 | let len = String.length path - len_suff in 12 | String.sub path len len_suff = suff 13 | ;; 14 | 15 | let _strip_slash path = 16 | match check_suffix path "/" with true -> chop_suffix path "/" | false -> path 17 | ;; 18 | 19 | let basename path = 20 | match String.split_on_char '/' @@ _strip_slash path with 21 | | [] -> "." 22 | | l -> List.nth l (List.length l - 1) 23 | ;; 24 | 25 | let dirname path = _strip_slash @@ chop_suffix (_strip_slash path) (basename path) 26 | -------------------------------------------------------------------------------- /test/operator.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | (* in pervasives *) 3 | Tester.expr 4 | {| 5 | let f g h = g 10 |> h in 6 | let g x = x + 20 in 7 | let fa a = g @@ a * 200 in 8 | f g fa 9 | |}; 10 | Tester.f 11 | {| 12 | let l1 = [1; 2; 3] 13 | let l2 = [4; 5; 6] 14 | ;; 15 | 16 | let rec print_list = function 17 | | [] -> print_string "end\n" 18 | | h :: t -> print_int h; print_string "->"; print_list t 19 | ;; 20 | 21 | print_list (l1 @ l2); 22 | print_list (l1 @ [1; 3]); 23 | print_list (l2 @ [10]); 24 | print_list ([4; 5] @ [3; 4; 10]) 25 | |}; 26 | (* user-defined *) 27 | Tester.f 28 | {| 29 | let (<=>) a b = a - b 30 | let (-->) a b = a * b 31 | let (@~@) a b = a + b 32 | ;; 33 | print_int (50 <=> 8); 34 | print_int (7 --> 6); 35 | print_int (13 @~@ 29) 36 | |} 37 | ;; 38 | -------------------------------------------------------------------------------- /test/value_match.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.expr 3 | {| 4 | let f = function 5 | | 1 -> 3 6 | | 2 -> 4 7 | | 3 -> 5 8 | | _ -> 6 9 | in (f 2) + (f 4) 10 | |}; 11 | Tester.expr 12 | {| 13 | let f = function 14 | | 3, 2 -> 3 15 | | 4, a -> a + 1 16 | | a, b -> a + b 17 | in (f (4, 5)) + (f (3, 2)) + (f (9, 8)) 18 | |}; 19 | Tester.f 20 | {| 21 | type t = 22 | | A of int 23 | | B of int * int 24 | ;; 25 | let f = function 26 | | A 1 -> 42 27 | | A x -> x 28 | | B (1, x) -> x 29 | | B (x, 1) -> x + 5 30 | | _ -> 99 31 | in 32 | print_int (f (A 4)); 33 | print_int (f (A 1)); 34 | print_int (f (B (1, 5))); 35 | print_int (f (B (9, 1))); 36 | print_int (f (B (10, 10))) 37 | |} 38 | ;; 39 | -------------------------------------------------------------------------------- /stdlib/hashtbl.ml: -------------------------------------------------------------------------------- 1 | (* fake implementation of Hashbl *) 2 | (* this behaves like OCaml's `Hashtbl`, but is not a hash table at all *) 3 | 4 | type ('a, 'b) t = {mutable data : ('a * 'b) list} 5 | 6 | let create _ = {data = []} 7 | let clear t = t.data <- [] 8 | let reset = clear 9 | let copy t = {data = t.data} 10 | let update t f = t.data <- f t.data 11 | let add t k v = update t @@ List.cons (k, v) 12 | let find t k = List.assoc k t.data 13 | let find_opt t k = List.assoc_opt k t.data 14 | let mem t k = List.mem_assoc k t.data 15 | let remove t x = update t @@ List.remove_assoc x 16 | 17 | let replace t k v = 18 | remove t k; 19 | add t k v 20 | ;; 21 | 22 | let iter f t = 23 | let g (k, v) = f k v in 24 | List.iter g t.data 25 | ;; 26 | 27 | let fold f t = 28 | let folder (k, v) = f k v in 29 | List.fold_right folder t.data 30 | ;; 31 | -------------------------------------------------------------------------------- /stdlib/array.ml: -------------------------------------------------------------------------------- 1 | external _get : 'a array * int -> 'a = "_mlml_get_array" 2 | external _set : 'a array * int * 'a -> unit = "_mlml_set_array" 3 | external _create_uninitialized : int -> 'a array = "_mlml_create_array" 4 | 5 | let get a n = _get (a, n) 6 | let set a n x = _set (a, n, x) 7 | 8 | external length : 'a array -> int = "_mlml_length_array" 9 | 10 | let init n f = 11 | let b = _create_uninitialized n in 12 | let rec aux i = 13 | set b i (f i); 14 | if i != 0 then aux (i - 1) 15 | in 16 | aux (n - 1); 17 | b 18 | ;; 19 | 20 | let make n x = init n (fun _ -> x) 21 | 22 | let to_list a = 23 | let rec aux acc = function 24 | | 0 -> acc 25 | | i -> 26 | let i = i - 1 in 27 | aux (get a i :: acc) i 28 | in 29 | aux [] (length a) 30 | ;; 31 | 32 | let fold_left f acc a = to_list a |> List.fold_left f acc 33 | -------------------------------------------------------------------------------- /test/range_pattern.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.f 3 | {| 4 | let f = function 5 | | 'a' .. 'd' -> 0 6 | | 'd' .. 'g' -> 1 7 | | _ -> 2 8 | in 9 | print_int (f 'a'); 10 | print_int (f 'c'); 11 | print_int (f 'd'); 12 | print_int (f 'g'); 13 | print_int (f 'x') 14 | |}; 15 | Tester.f 16 | {| 17 | let is_digit = function 18 | | '0' .. '9' -> 1 19 | | _ -> 0 20 | ;; 21 | 22 | print_int (is_digit 'a'); 23 | print_int (is_digit '0'); 24 | print_int (is_digit '7'); 25 | print_int (is_digit '9'); 26 | print_int (is_digit 'd') 27 | |}; 28 | Tester.f 29 | {| 30 | let is_uppercase = function 31 | | 'A' .. 'Z' -> 1 32 | | _ -> 0 33 | ;; 34 | 35 | print_int (is_uppercase '9'); 36 | print_int (is_uppercase 'A'); 37 | print_int (is_uppercase 'c'); 38 | print_int (is_uppercase 'D'); 39 | print_int (is_uppercase '_'); 40 | print_int (is_uppercase 'Z') 41 | |} 42 | ;; 43 | -------------------------------------------------------------------------------- /test/filename_.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.bool_expr {| Filename.is_relative "a/b" |}; 3 | Tester.bool_expr {| Filename.is_relative "/a/b" |}; 4 | Tester.bool_expr {| Filename.is_relative "./a/b" |}; 5 | Tester.f {| 6 | print_endline @@ Filename.chop_suffix "./a/b.ml" ".ml" 7 | |}; 8 | Tester.bool_expr {| Filename.check_suffix "./a/b.ml" ".ml" |}; 9 | Tester.bool_expr {| Filename.check_suffix "a/b.ml/c" ".ml" |}; 10 | Tester.f {| 11 | print_endline @@ Filename.basename "./a/b/c.ml" 12 | |}; 13 | Tester.f {| 14 | print_endline @@ Filename.basename "./a/b/c/" 15 | |}; 16 | Tester.f {| 17 | print_endline @@ Filename.basename "./a/b" 18 | |}; 19 | Tester.f {| 20 | print_endline @@ Filename.dirname "./a/b/c.ml" 21 | |}; 22 | Tester.f {| 23 | print_endline @@ Filename.dirname "./a/b/c/" 24 | |}; 25 | Tester.f {| 26 | print_endline @@ Filename.dirname "./a/b" 27 | |} 28 | ;; 29 | -------------------------------------------------------------------------------- /test/printf_.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.f {| Printf.printf "this is number %d" 123 |}; 3 | Tester.f 4 | {| print_string @@ Printf.sprintf "String: %s\tNumber: %d\tChar: %c" "ramen" 42 'd' |}; 5 | Tester.f 6 | {| 7 | let make_string = Printf.sprintf "s%d" in 8 | print_string @@ make_string 123 9 | |}; 10 | Tester.f 11 | {| 12 | let fmt = Printf.printf "the answer to %s, the %s, and %s is %d\n" in 13 | fmt "life" "universe" "everything" 42; 14 | let ramen_ver = fmt "ramen" in 15 | ramen_ver "universe" "everything" 42; 16 | let foods = ramen_ver "steak" "sushi" in 17 | foods 42 18 | |}; 19 | Tester.f 20 | {| 21 | let f s = Printf.ksprintf (fun x -> s ^ x) in 22 | print_string @@ f "hello, " "%s!" "world"; 23 | print_string @@ f "one" "plus %s is %d" "one" 2; 24 | let f2 = f "No." in 25 | f2 "%d-%s" 1 "maybe" 26 | |}; 27 | Tester.f {| 28 | Printf.printf "Escape%%%s!" "escaped!" 29 | |} 30 | ;; 31 | -------------------------------------------------------------------------------- /mlml/bundler/bundler.ml: -------------------------------------------------------------------------------- 1 | module Mod = Tree.Module 2 | module Path = Tree.Path 3 | module ModCache = Modules_cache 4 | module SS = Tree.Simple_set 5 | module DepTree = Dependency_tree 6 | module Build = Build_tree 7 | module Find = Find_projects 8 | 9 | let rec bundle_libs cache libs = 10 | let f = function 11 | | DepTree.Entry p -> ModCache.get cache p 12 | | DepTree.Scoped (name, l) -> 13 | let name = String.capitalize_ascii name in 14 | let l = bundle_libs cache l in 15 | [Mod.Definition (Mod.Module (name, Mod.Struct l))] 16 | in 17 | List.rev_map f libs |> List.flatten 18 | ;; 19 | 20 | let f file = 21 | let cache = ModCache.empty () in 22 | let projects = 23 | match Find.find_project_root_opt file with 24 | | Some root -> Find.find_projects root |> SS.elements 25 | | None -> [] 26 | in 27 | Build.build_tree_root cache projects file |> DepTree.collapse |> bundle_libs cache 28 | ;; 29 | -------------------------------------------------------------------------------- /test/bytes.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.f 3 | {| 4 | let b = Bytes.of_string "hello" in 5 | Bytes.set b 1 'o'; 6 | print_string @@ Bytes.to_string b; 7 | print_char @@ Bytes.get b 1; 8 | print_char @@ Bytes.get b 4 9 | |}; 10 | Tester.f 11 | {| 12 | let b1 = Bytes.of_string "hello" in 13 | let b2 = Bytes.copy b1 in 14 | Bytes.set b1 1 'o'; 15 | print_string @@ Bytes.to_string b2 16 | |}; 17 | Tester.f 18 | {| 19 | let b1 = Bytes.of_string "hello, world" in 20 | let b2 = Bytes.of_string "that curry is delicious" in 21 | Bytes.blit b2 6 b1 1 4; 22 | print_string @@ Bytes.to_string b1 23 | |}; 24 | Tester.f {| 25 | let b = Bytes.make 10 'w' in 26 | print_string @@ Bytes.to_string b 27 | |}; 28 | Tester.f {| 29 | let s = "ramen" in 30 | let sub = String.sub s 2 3 in 31 | print_string sub 32 | |}; 33 | Tester.f 34 | {| 35 | let char_of_digit d = char_of_int (int_of_char '0' + d) ;; 36 | let f i = char_of_digit i in 37 | let s = String.init 10 f in 38 | print_string s 39 | |} 40 | ;; 41 | -------------------------------------------------------------------------------- /mlml/bundler/modules_cache.ml: -------------------------------------------------------------------------------- 1 | type 'a ast = 'a Tree.Module.module_item list 2 | type 'a t = (string, 'a ast) Hashtbl.t 3 | 4 | let empty () = Hashtbl.create 32 5 | let add = Hashtbl.add 6 | let find_opt = Hashtbl.find_opt 7 | let find = Hashtbl.find 8 | let copy = Hashtbl.copy 9 | 10 | let find_key_opt pred s = 11 | let f k _v acc = match pred k with true -> Some k | false -> acc in 12 | Hashtbl.fold f s None 13 | ;; 14 | 15 | let load_direct file = 16 | let ic = open_in file in 17 | let content = really_input_string ic @@ in_channel_length ic in 18 | close_in ic; 19 | Lexer.f content |> Parser.Compilation_unit.f 20 | ;; 21 | 22 | let load_with_opt init_opt s file = 23 | match find_opt s file with 24 | | Some tree -> tree 25 | | None -> 26 | let tree = load_direct file in 27 | let tree = match init_opt with Some f -> f tree | None -> tree in 28 | add s file tree; 29 | tree 30 | ;; 31 | 32 | let load_with f = load_with_opt (Some f) 33 | let load = load_with_opt None 34 | let get = find 35 | -------------------------------------------------------------------------------- /test/when_match.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.f 3 | {| 4 | let f v = 5 | let cond = function 6 | | 1 | 2 | 3 -> true 7 | | _ -> false 8 | in match v with 9 | | x when cond x -> 42 10 | | x when x = 10 -> 10 11 | | _ -> 0 12 | in 13 | print_int (f 1); 14 | print_int (f 3); 15 | print_int (f 10); 16 | print_int (f 11) 17 | |}; 18 | Tester.f 19 | {| 20 | let f = function 21 | | x, y when x = y -> 42 22 | | x, y -> x + y 23 | in 24 | print_int (f (1, 2)); 25 | print_int (f (10, 10)) 26 | |}; 27 | Tester.f 28 | {| 29 | type t = 30 | | A of int * int 31 | | B of int * int 32 | 33 | let f = function 34 | | A (a, b) | B (a, b) when a + b = 20 -> a * b 35 | | A (a, b) -> a + b 36 | | B (a, b) -> a - b 37 | ;; 38 | print_int (f (A (2, 3))); 39 | print_int (f (B (15, 5))); 40 | print_int (f (A (4, 16))); 41 | print_int (f (B (5, 3))) 42 | |} 43 | ;; 44 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2019 coord.e 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: 4 | 5 | The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. 6 | 7 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 8 | -------------------------------------------------------------------------------- /mlml/tree/simple_set.ml: -------------------------------------------------------------------------------- 1 | (* simple (and inefficient) implementation of set *) 2 | 3 | type 'a t = {data : 'a list} 4 | 5 | let empty = {data = []} 6 | let singleton x = {data = [x]} 7 | 8 | let rec remove_duplicates = function 9 | | [] -> [] 10 | | h :: t -> 11 | let t = List.filter (fun x -> x <> h) t in 12 | h :: remove_duplicates t 13 | ;; 14 | 15 | let elements s = remove_duplicates s.data 16 | let of_list l = {data = l} 17 | 18 | let union a b = 19 | let l = elements a @ elements b in 20 | of_list l 21 | ;; 22 | 23 | let mem e s = List.mem e s.data 24 | let add e s = of_list (e :: s.data) 25 | 26 | let remove e s = 27 | let l = List.filter (fun x -> x <> e) s.data in 28 | of_list l 29 | ;; 30 | 31 | let choose_opt s = match s.data with [] -> None | h :: _ -> Some h 32 | let choose s = match choose_opt s with Some v -> v | None -> failwith "Empty" 33 | 34 | let diff a b = 35 | let f x = not (mem x b) in 36 | let l = List.filter f a.data in 37 | of_list l 38 | ;; 39 | 40 | let filter f s = of_list (List.filter f (elements s)) 41 | -------------------------------------------------------------------------------- /test/arith.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.expr "13 + 5 * 10"; 3 | Tester.expr "(2 + 5) * 6"; 4 | Tester.expr "14 * 2 - 3 * 5"; 5 | Tester.expr "1+2+3+4+5+6+7*2+8"; 6 | Tester.expr "4 / 2"; 7 | Tester.expr "12 / 5 + 3"; 8 | Tester.expr "12 mod 5 * 14"; 9 | Tester.expr "8 + 3 mod 12 + 4"; 10 | Tester.expr "-10"; 11 | Tester.expr "5-10"; 12 | Tester.expr "-(5-10)"; 13 | Tester.expr "-5-10*2"; 14 | Tester.expr "-0"; 15 | Tester.bool_expr "1 > 2"; 16 | Tester.bool_expr "133 < 123"; 17 | Tester.bool_expr "42 > 42"; 18 | Tester.bool_expr "2 < 42"; 19 | Tester.bool_expr "2 < -42"; 20 | Tester.bool_expr "-10 < -42"; 21 | Tester.bool_expr "42 >= 42"; 22 | Tester.bool_expr "4 <= 5"; 23 | Tester.bool_expr "5 <= 5"; 24 | Tester.bool_expr "4 >= 8"; 25 | Tester.bool_expr "false || false"; 26 | Tester.bool_expr "true || true"; 27 | Tester.bool_expr "false || true"; 28 | Tester.bool_expr "true && true"; 29 | Tester.bool_expr "false && true"; 30 | Tester.bool_expr "false && (print_int 42; true)"; 31 | Tester.bool_expr "true && (print_int 42; true)" 32 | ;; 33 | -------------------------------------------------------------------------------- /test/let_and.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.bool_expr 3 | {| 4 | let rec is_even = function 5 | | 0 -> true 6 | | x -> is_odd (x-1) 7 | and is_odd = function 8 | | 0 -> false 9 | | x -> is_even (x-1) 10 | in is_even 13 11 | |}; 12 | Tester.expr 13 | {| 14 | let rec f x = h (x - 1) 15 | and g = function 16 | | 0 -> 0 17 | | x -> 1 + g (x - 1) 18 | and h x = g x 19 | in f 10 20 | |}; 21 | Tester.expr {| 22 | let rec f x = x + a 23 | and a = 10 24 | and g x = f x 25 | in g 10 26 | |}; 27 | Tester.expr {| 28 | let f x = x + 1 29 | and a, b = 1, 2 30 | and g x = x * 10 31 | in f a + g b 32 | |}; 33 | (* definiton version *) 34 | Tester.f 35 | {| 36 | let rec is_even = function 37 | | 0 -> true 38 | | x -> is_odd (x-1) 39 | and is_odd = function 40 | | 0 -> false 41 | | x -> is_even (x-1) 42 | and print_bool = function 43 | | true -> print_int 1 44 | | false -> print_int 0 45 | ;; 46 | print_bool (is_even 13) 47 | |}; 48 | Tester.f 49 | {| 50 | let f x = x + 1 51 | and a, b = 1, 2 52 | and g x = x * 10 53 | ;; 54 | print_int (f a + g b) 55 | |} 56 | ;; 57 | -------------------------------------------------------------------------------- /test/or_pattern.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.expr 3 | {| 4 | let f = function 5 | | 1 | 2 -> 3 6 | | 3 -> 5 7 | | _ -> 6 8 | in (f 2) + (f 1) + (f 4) 9 | |}; 10 | Tester.f 11 | {| 12 | type t = 13 | | A of int * int 14 | | B of int * int 15 | 16 | let f = function 17 | | A (v1, v2) | B (v1, v2) -> v1 + v2 18 | ;; 19 | print_int (f (A (2, 3))); 20 | print_int (f (B (4, 5))) 21 | |}; 22 | Tester.f 23 | {| 24 | type t = 25 | | A of int * int 26 | | B of int 27 | 28 | let f = function 29 | | A (a, _) | B a -> a + 1 30 | ;; 31 | print_int (f (A (2, 3))); 32 | print_int (f (B 4)) 33 | |}; 34 | Tester.f 35 | {| 36 | type t = 37 | | A of int * int 38 | | B of int * int 39 | | C of int * int 40 | | D of int 41 | 42 | let f = function 43 | | A (a, b) | B (a, b) | C (a, b) -> a + b 44 | | D i -> i * 100 45 | ;; 46 | print_int (f (A (2, 3))); 47 | print_int (f (B (4, 5))); 48 | print_int (f (C (6, 7))); 49 | print_int (f (D 7)) 50 | |} 51 | ;; 52 | -------------------------------------------------------------------------------- /mlml/tree/binop.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 2 | | Add 3 | | Sub 4 | | Mul 5 | | Follow 6 | | Equal 7 | | NotPhysicalEqual 8 | | Lt 9 | | Gt 10 | | And 11 | | Or 12 | | Cons 13 | | StringIndex 14 | | ArrayIndex 15 | | Mod 16 | | Div 17 | (* non-keyword operators *) 18 | | Custom of 'a 19 | 20 | let string_of_binop f = function 21 | | Add -> "+" 22 | | Sub -> "-" 23 | | Mul -> "*" 24 | | Div -> "/" 25 | | Lt -> "<" 26 | | Gt -> ">" 27 | | Mod -> "mod" 28 | | Follow -> ";" 29 | | Equal -> "=" 30 | | NotPhysicalEqual -> "!=" 31 | | And -> "&&" 32 | | Or -> "||" 33 | | Cons -> "::" 34 | | StringIndex -> ".[]" 35 | | ArrayIndex -> ".()" 36 | | Custom s -> f s 37 | ;; 38 | 39 | let apply_on_custom f = function 40 | | Add -> Add 41 | | Sub -> Sub 42 | | Mul -> Mul 43 | | Follow -> Follow 44 | | Equal -> Equal 45 | | NotPhysicalEqual -> NotPhysicalEqual 46 | | Lt -> Lt 47 | | Gt -> Gt 48 | | And -> And 49 | | Or -> Or 50 | | Cons -> Cons 51 | | StringIndex -> StringIndex 52 | | ArrayIndex -> ArrayIndex 53 | | Mod -> Mod 54 | | Div -> Div 55 | | Custom s -> Custom (f s) 56 | ;; 57 | -------------------------------------------------------------------------------- /mlml/bundler/dependency_tree.ml: -------------------------------------------------------------------------------- 1 | type 'a t = 2 | | Node of 'a * 'a t list 3 | | Submodule of string * 'a t list 4 | 5 | type 'a dep = 6 | | Entry of 'a 7 | | Scoped of string * 'a dep_list 8 | 9 | and 'a dep_list = 'a dep list 10 | 11 | let merge_list a b = 12 | let rec aux acc = function 13 | | h :: t -> 14 | let f x = x <> h in 15 | let t = List.filter f t in 16 | aux (h :: acc) t 17 | | [] -> acc 18 | in 19 | let l = List.append a b |> List.rev in 20 | aux [] l 21 | ;; 22 | 23 | let rec collapse_list l = List.map collapse l |> List.fold_left merge_list [] 24 | 25 | and upper_lower l = 26 | let aux = function Node (file, _) -> file | Submodule (name, _) -> name in 27 | let under_names = List.map aux l in 28 | let l = collapse_list l in 29 | let f = function Entry name | Scoped (name, _) -> List.mem name under_names in 30 | List.partition f l 31 | 32 | and collapse = function 33 | | Node (file, []) -> [Entry file] 34 | | Node (file, l) -> Entry file :: collapse_list l 35 | | Submodule (name, l) -> 36 | (* `upper` is what is expected to be accessible as if it is under the name *) 37 | (* `lower` is the other, non-related things *) 38 | let upper, lower = upper_lower l in 39 | Scoped (name, upper) :: lower 40 | ;; 41 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | 2 | # Created by https://www.gitignore.io/api/ocaml,vim,linux 3 | # Edit at https://www.gitignore.io/?templates=ocaml,vim,linux 4 | 5 | ### Linux ### 6 | *~ 7 | 8 | # temporary files which can be created if a process still has a handle open of a deleted file 9 | .fuse_hidden* 10 | 11 | # KDE directory preferences 12 | .directory 13 | 14 | # Linux trash folder which might appear on any partition or disk 15 | .Trash-* 16 | 17 | # .nfs files are created when an open file is removed but is still being accessed 18 | .nfs* 19 | 20 | ### OCaml ### 21 | *.annot 22 | *.cmo 23 | *.cma 24 | *.cmi 25 | *.a 26 | *.o 27 | *.cmx 28 | *.cmxs 29 | *.cmxa 30 | 31 | # ocamlbuild working directory 32 | _build/ 33 | 34 | # ocamlbuild targets 35 | *.byte 36 | *.native 37 | 38 | # oasis generated files 39 | setup.data 40 | setup.log 41 | 42 | # Merlin configuring file for Vim and Emacs 43 | .merlin 44 | 45 | # Dune generated files 46 | *.install 47 | 48 | # Local OPAM switch 49 | _opam/ 50 | 51 | ### Vim ### 52 | # Swap 53 | [._]*.s[a-v][a-z] 54 | [._]*.sw[a-p] 55 | [._]s[a-rt-v][a-z] 56 | [._]ss[a-gi-z] 57 | [._]sw[a-p] 58 | 59 | # Session 60 | Session.vim 61 | 62 | # Temporary 63 | .netrwhist 64 | # Auto-generated tag files 65 | tags 66 | # Persistent undo 67 | [._]*.un~ 68 | 69 | # End of https://www.gitignore.io/api/ocaml,vim,linux 70 | -------------------------------------------------------------------------------- /.dockerignore: -------------------------------------------------------------------------------- 1 | 2 | # Created by https://www.gitignore.io/api/ocaml,vim,linux 3 | # Edit at https://www.gitignore.io/?templates=ocaml,vim,linux 4 | 5 | ### Linux ### 6 | *~ 7 | 8 | # temporary files which can be created if a process still has a handle open of a deleted file 9 | .fuse_hidden* 10 | 11 | # KDE directory preferences 12 | .directory 13 | 14 | # Linux trash folder which might appear on any partition or disk 15 | .Trash-* 16 | 17 | # .nfs files are created when an open file is removed but is still being accessed 18 | .nfs* 19 | 20 | ### OCaml ### 21 | *.annot 22 | *.cmo 23 | *.cma 24 | *.cmi 25 | *.a 26 | *.o 27 | *.cmx 28 | *.cmxs 29 | *.cmxa 30 | 31 | # ocamlbuild working directory 32 | _build/ 33 | 34 | # ocamlbuild targets 35 | *.byte 36 | *.native 37 | 38 | # oasis generated files 39 | setup.data 40 | setup.log 41 | 42 | # Merlin configuring file for Vim and Emacs 43 | .merlin 44 | 45 | # Dune generated files 46 | *.install 47 | 48 | # Local OPAM switch 49 | _opam/ 50 | 51 | ### Vim ### 52 | # Swap 53 | [._]*.s[a-v][a-z] 54 | [._]*.sw[a-p] 55 | [._]s[a-rt-v][a-z] 56 | [._]ss[a-gi-z] 57 | [._]sw[a-p] 58 | 59 | # Session 60 | Session.vim 61 | 62 | # Temporary 63 | .netrwhist 64 | # Auto-generated tag files 65 | tags 66 | # Persistent undo 67 | [._]*.un~ 68 | 69 | # End of https://www.gitignore.io/api/ocaml,vim,linux 70 | -------------------------------------------------------------------------------- /stdlib/bytes.ml: -------------------------------------------------------------------------------- 1 | external of_string : string -> bytes = "_mlml_shallow_copy" 2 | external to_string : bytes -> string = "_mlml_shallow_copy" 3 | external copy : bytes -> bytes = "_mlml_shallow_copy" 4 | external create : int -> bytes = "_mlml_create_string" 5 | external length : bytes -> int = "_mlml_length_string" 6 | external _get : bytes * int -> char = "_mlml_get_string" 7 | external _set : bytes * int * char -> unit = "_mlml_set_string" 8 | 9 | let get s n = _get (s, n) 10 | let set s n c = _set (s, n, c) 11 | let empty = create 0 12 | 13 | let blit src srcoff dst dstoff len = 14 | let rec aux i = 15 | let srcidx = srcoff + i in 16 | let dstidx = dstoff + i in 17 | set dst dstidx @@ get src srcidx; 18 | if i != 0 then aux (i - 1) 19 | in 20 | match len with 0 -> () | len -> aux (len - 1) 21 | ;; 22 | 23 | let blit_string src srcoff dst dstoff len = blit src srcoff dst dstoff len |> to_string 24 | 25 | let sub s start len = 26 | let b = create len in 27 | blit s start b 0 len; 28 | b 29 | ;; 30 | 31 | let sub_string s start len = sub s start len |> to_string 32 | 33 | let init n f = 34 | let b = create n in 35 | let rec aux i = 36 | set b i (f i); 37 | if i != 0 then aux (i - 1) 38 | in 39 | (match n with 0 -> () | n -> aux (n - 1)); 40 | b 41 | ;; 42 | 43 | let make n c = init n (fun _ -> c) 44 | -------------------------------------------------------------------------------- /test/closure_currying.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.expr "let f a b c = a + b * c in f 1 3 5"; 3 | Tester.expr {| 4 | let a = 10 in 5 | let f x = a + x in 6 | f 5 7 | |}; 8 | Tester.expr 9 | {| 10 | let f a b c = a * b + c in 11 | let add = f 1 in 12 | let succ = add 1 in 13 | f (add (succ 2) 3) (succ 5) (add 2 3) 14 | |}; 15 | (* TODO: ack with larger number *) 16 | Tester.expr 17 | {| 18 | let rec ack m n = 19 | match m, n with 20 | | 0, n -> n + 1 21 | | m, 0 -> ack (m - 1) 1 22 | | m, n -> ack (m - 1) (ack m (n - 1)) 23 | in ack 3 5 24 | |}; 25 | Tester.expr {| 26 | let f x = x + 1 in 27 | let g x = f x + 1 in 28 | g 10 29 | |}; 30 | Tester.expr 31 | {| 32 | let t = (2, 3), 4 in 33 | let f x = 34 | let (a, b), c = t in 35 | a * b + c * x 36 | in f 10 37 | |}; 38 | Tester.expr {| 39 | let f (a, b) c = 40 | a * b + c 41 | in 42 | let g = f (2, 3) in 43 | g 10 44 | |}; 45 | Tester.f {| 46 | let v = 10 47 | let f x = v + x 48 | ;; 49 | print_int (f 12) 50 | |}; 51 | Tester.f {| 52 | let f a b = a + b ;; 53 | let succ = f 1 ;; 54 | print_int (succ 12) 55 | |}; 56 | Tester.f 57 | {| 58 | let v = 1 ;; 59 | let rec fact = function 60 | | 0 -> v 61 | | n -> n * fact (n - 1) 62 | ;; 63 | 64 | print_int (fact 5) 65 | |}; 66 | Tester.f {| 67 | let printer = print_int in 68 | printer 12 69 | |} 70 | ;; 71 | -------------------------------------------------------------------------------- /mlml/tree/type_expression.ml: -------------------------------------------------------------------------------- 1 | module NS = Namespace 2 | 3 | type 'a t = 4 | | Ident of 'a 5 | | Tuple of 'a t list 6 | | Var of string 7 | | Ctor of 'a t list * 'a 8 | | Function of 'a t * 'a t 9 | 10 | (* apply `f` on reference names, apply `g` on binding names *) 11 | let rec apply_on_names f g e = 12 | let apply = apply_on_names f g in 13 | match e with 14 | | Ident x -> Ident (f x NS.Type) 15 | | Tuple l -> Tuple (List.map apply l) 16 | | Var s -> Var s 17 | | Ctor (params, ctor) -> 18 | let params = List.map apply params in 19 | let ctor = f ctor NS.Type in 20 | Ctor (params, ctor) 21 | | Function (a, b) -> 22 | let a = apply a in 23 | let b = apply b in 24 | Function (a, b) 25 | ;; 26 | 27 | let rec string_of_type_expression f = function 28 | | Ident ident -> Printf.sprintf "Ident %s" (f ident) 29 | | Var ident -> Printf.sprintf "Var %s" ident 30 | | Ctor (tys, ident) -> 31 | let tys = List.map (string_of_type_expression f) tys |> String.concat ", " in 32 | Printf.sprintf "Ctor (%s) %s" tys (f ident) 33 | | Tuple ts -> 34 | let ts = List.map (string_of_type_expression f) ts |> String.concat " * " in 35 | Printf.sprintf "Tuple (%s)" ts 36 | | Function (a, b) -> 37 | Printf.sprintf 38 | "(%s) -> (%s)" 39 | (string_of_type_expression f a) 40 | (string_of_type_expression f b) 41 | ;; 42 | -------------------------------------------------------------------------------- /test/array_.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.f {| 3 | let ary = [|1; 2; 3|] in 4 | print_int ary.(1) 5 | |}; 6 | Tester.f {| 7 | let a = [|1; 2; 3|] in 8 | let [|x; y; z|] = a in 9 | print_int (x * y + z) 10 | |}; 11 | Tester.f 12 | {| 13 | let a = [| [| 1; 2 |]; [| 3; 4 |] |] in 14 | let [| a; [| b; c |] |] = a in 15 | print_int (b + c); 16 | print_int a.(0) 17 | |}; 18 | Tester.f 19 | {| 20 | let a = [| 1; 2; 3; 4 |] in 21 | print_int a.(2); 22 | a.(2) <- 10; 23 | print_int a.(2) 24 | |}; 25 | Tester.f 26 | {| 27 | let a = [| "a"; "b"; "c" |] in 28 | let b = a in 29 | a.(2) <- "d"; 30 | print_string b.(2) 31 | |}; 32 | Tester.f 33 | {| 34 | let f = function 35 | | [| a |] -> print_int a 36 | | [| a; b |] -> print_int (a * b) 37 | | _ -> print_int 1200 38 | ;; 39 | 40 | f [| 2; 13 |]; 41 | f [| 3 |]; 42 | f [| 3; 243; 234 |] 43 | |}; 44 | (* Library features *) 45 | Tester.f {| 46 | let a = [| 3; 2; 5 |] in 47 | print_int @@ Array.length a 48 | |}; 49 | Tester.f 50 | {| 51 | let a = Array.make 10 "hello" in 52 | print_int @@ Array.length a; 53 | let print_array a = 54 | let rec aux i = 55 | print_string @@ Array.get a i; 56 | if i != 0 then aux (i - 1) 57 | in aux (Array.length a - 1) 58 | in 59 | print_array a 60 | |}; 61 | Tester.f {| 62 | Array.to_list [|1; 2; 3|] |> List.iter print_int 63 | |}; 64 | Tester.f {| 65 | let f acc i = acc * (i + 5) in 66 | Array.fold_left f 0 [|1; 2; 3; 4; 5|] 67 | |} 68 | ;; 69 | -------------------------------------------------------------------------------- /mlml/bundler/find_projects.ml: -------------------------------------------------------------------------------- 1 | module SS = Tree.Simple_set 2 | 3 | let parent path = 4 | match Filename.check_suffix path "/" with 5 | | false -> Filename.dirname path 6 | | true -> 7 | let path = Filename.chop_suffix path "/" in 8 | Filename.dirname path 9 | ;; 10 | 11 | let absolute path = 12 | match Filename.is_relative path with 13 | | true -> 14 | let cwd = Sys.getcwd () in 15 | Filename.concat cwd path 16 | | false -> path 17 | ;; 18 | 19 | let find_project_root_opt dir = 20 | let rec aux dir = 21 | let candidate = Filename.concat dir "dune-project" in 22 | match Sys.file_exists candidate with 23 | | true -> Some dir 24 | | false when dir = "/" -> None 25 | | false -> aux @@ parent dir 26 | in 27 | aux @@ absolute dir 28 | ;; 29 | 30 | let is_library_dune path = 31 | let ic = open_in path in 32 | let target = "(library" in 33 | let str = really_input_string ic (String.length target) in 34 | close_in ic; 35 | str = target 36 | ;; 37 | 38 | let rec find_projects root_dir = 39 | let aux acc name = 40 | let path = Filename.concat root_dir name in 41 | match Sys.is_directory path with 42 | | false -> acc 43 | | true -> 44 | let acc = SS.union acc @@ find_projects path in 45 | let dune = Filename.concat path "dune" in 46 | (match Sys.file_exists dune with 47 | | true when is_library_dune dune -> SS.add path acc 48 | | _ -> acc) 49 | in 50 | Sys.readdir root_dir |> Array.fold_left aux SS.empty 51 | ;; 52 | -------------------------------------------------------------------------------- /test/variant.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.f 3 | {| 4 | type t = A | B | C 5 | ;; 6 | 7 | let v = A in 8 | let r = ( 9 | match v with 10 | | A -> 1 11 | | B -> 2 12 | | C -> 3 13 | ) in print_int r 14 | |}; 15 | Tester.f 16 | {| 17 | type t = 18 | | Int of int 19 | | Add of t * t 20 | | Mul of t * t 21 | 22 | let rec calc = function 23 | | Int a -> a 24 | | Add (a, b) -> 25 | let a = calc a in 26 | let b = calc b in 27 | a + b 28 | | Mul (a, b) -> 29 | let a = calc a in 30 | let b = calc b in 31 | a * b 32 | ;; 33 | 34 | ;; 35 | let tree = Mul (Add (Int 3, Int 5), Mul (Int 2, Int 4)) in 36 | print_int (calc tree) 37 | |}; 38 | Tester.f 39 | {| 40 | type t1 = A | B 41 | type t2 = 42 | | C of t1 * int 43 | 44 | let m = function 45 | | C (A, i) -> i 46 | | C (B, i) -> i + 1 47 | ;; 48 | 49 | print_int (m (C (B, 10))) 50 | |}; 51 | Tester.f 52 | {| 53 | type t1 = 54 | | A of int * int 55 | | B of int 56 | 57 | type t2 = 58 | | C of t1 * (int * int) 59 | | D 60 | 61 | let complex_match = function 62 | | C (A (a, b), t) -> 63 | let c, d = t in 64 | a + b + c + d 65 | | C (B i, (a, b)) -> i + a * b 66 | | D -> 10 67 | ;; 68 | 69 | let a = complex_match (C (A (4, 5), (6, 7))) in 70 | let b = complex_match (C (B 12, (3, 4))) in 71 | print_int (a + b) 72 | |}; 73 | (* parser precedence *) 74 | Tester.f 75 | {| 76 | type t = A | B 77 | ;; 78 | let f a b = 79 | match a with 80 | | A -> b + 1 81 | | B -> b 82 | in print_int (f A 10) 83 | |} 84 | ;; 85 | -------------------------------------------------------------------------------- /stdlib/pervasives.ml: -------------------------------------------------------------------------------- 1 | external print_char : char -> unit = "_mlml_print_char" 2 | external print_string : string -> unit = "_mlml_print_string" 3 | external prerr_string : string -> unit = "_mlml_prerr_string" 4 | external int_of_char : char -> int = "_mlml_identity" 5 | external char_of_int : int -> char = "_mlml_identity" 6 | external _append_string : string * string -> string = "_mlml_append_string" 7 | 8 | let string_of_bool = function true -> "true" | false -> "false" 9 | 10 | let print_endline s = 11 | print_string s; 12 | print_char '\n' 13 | ;; 14 | 15 | let not c = if c then false else true 16 | let ( <> ) a b = not (a = b) 17 | let ( == ) a b = not (a != b) 18 | let ( ^ ) a b = _append_string (a, b) 19 | let ( <= ) a b = not (a > b) 20 | let ( >= ) a b = not (a < b) 21 | let rec ( @ ) a b = match a with [] -> b | h :: t -> h :: (t @ b) 22 | 23 | (* TODO: @@ is right-assiciative *) 24 | let ( @@ ) f a = f a 25 | let ( |> ) v f = f v 26 | 27 | type 'a option = 28 | | Some of 'a 29 | | None 30 | 31 | external exit : int -> 'a = "_mlml_exit" 32 | 33 | let failwith msg = 34 | prerr_string msg; 35 | exit 2 36 | ;; 37 | 38 | (* TODO: Use -1 *) 39 | let compare a b = 40 | match a = b, a > b with true, _ -> 0 | _, true -> 1 | _, false -> 0 - 1 41 | ;; 42 | 43 | let succ x = x + 1 44 | let fst (a, _) = a 45 | let snd (_, b) = b 46 | 47 | external open_in : string -> in_channel = "_mlml_open_in" 48 | external close_in : in_channel -> unit = "_mlml_close_in" 49 | external in_channel_length : in_channel -> int = "_mlml_in_channel_length" 50 | external _really_input_string : in_channel * int -> string = "_mlml_really_input_string" 51 | 52 | let really_input_string ic len = _really_input_string (ic, len) 53 | let ignore _ = () 54 | -------------------------------------------------------------------------------- /test/string_.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.f {|print_string "hello, world!"|}; 3 | Tester.f {| 4 | let s1 = "hello" in 5 | let s2 = "world" in 6 | print_string (s1 ^ ", " ^ s2) 7 | |}; 8 | Tester.bool_expr 9 | {| 10 | let s1 = "hel" in 11 | let is_hello = function "hello" -> true | _ -> false in 12 | is_hello (s1 ^ "lo") 13 | |}; 14 | Tester.bool_expr {| 15 | "hello" = "hello" 16 | |}; 17 | Tester.bool_expr {| 18 | "hell" <> "hello" 19 | |}; 20 | Tester.bool_expr {| 21 | "hello" != "hello" 22 | |}; 23 | Tester.f {| 24 | print_string "this is \"quoted\" string" 25 | |}; 26 | Tester.f 27 | {| 28 | let f = function 'a' -> "AHHHH" | 'b' -> "BEEEE" | _ -> "huh, idk" in 29 | print_string (f "aieee".[0]) 30 | |}; 31 | Tester.f 32 | {| 33 | let explode s = 34 | let rec exp i l = if i < 0 then l else exp (i - 1) (s.[i] :: l) in 35 | exp (String.length s - 1) [] 36 | ;; 37 | 38 | let rec print = function 39 | | [] -> print_string "end" 40 | | h :: t -> 41 | print_char h; 42 | print_string "->"; 43 | print t 44 | ;; 45 | 46 | print (explode "hello, world") 47 | |}; 48 | Tester.f 49 | {| 50 | type op = 51 | | Just of string 52 | | Concat of op * op 53 | ;; 54 | 55 | let replace = function 56 | | "like" -> "love" 57 | | "bad" -> "cool" 58 | | s -> s 59 | ;; 60 | 61 | let rec f = function 62 | | Just s -> replace s 63 | | Concat (a, b) -> f a ^ " " ^ f b 64 | ;; 65 | 66 | let s = Concat ( 67 | Concat ( 68 | Just "I", 69 | Just "like" 70 | ), 71 | Concat ( 72 | Concat ( 73 | Just "bad", 74 | Concat ( 75 | Just "and", 76 | Just "cute" 77 | ) 78 | ), 79 | Just "dogs" 80 | ) 81 | ) in print_string (f s) 82 | |}; 83 | Tester.bool_expr {| 84 | let a = "mutable" in 85 | let b = "mut" ^ "able" in 86 | a = b 87 | |} 88 | ;; 89 | -------------------------------------------------------------------------------- /stdlib/string.ml: -------------------------------------------------------------------------------- 1 | external length : string -> int = "_mlml_length_string" 2 | external _get : string * int -> char = "_mlml_get_string" 3 | 4 | let get s n = _get (s, n) 5 | let make n c = Bytes.make n c |> Bytes.to_string 6 | let init n c = Bytes.init n c |> Bytes.to_string 7 | let blit = Bytes.blit_string 8 | let sub s = Bytes.sub_string (Bytes.of_string s) 9 | 10 | let map f str = 11 | let aux i = f str.[i] in 12 | init (length str) aux 13 | ;; 14 | 15 | let mapi f str = 16 | let aux i = f i str.[i] in 17 | init (length str) aux 18 | ;; 19 | 20 | let rec concat d = function [] -> "" | [h] -> h | h :: t -> h ^ d ^ concat d t 21 | 22 | (* does not exists in official stdlib *) 23 | let get_opt str i = if length str > i then Some str.[i] else None 24 | 25 | let index_opt str chr = 26 | let rec aux i = 27 | match get_opt str i with 28 | | Some c when c = chr -> Some i 29 | | Some _ -> aux (i + 1) 30 | | None -> None 31 | in 32 | aux 0 33 | ;; 34 | 35 | let split_on_char c str = 36 | let rec aux str = 37 | match index_opt str c with 38 | | Some i -> 39 | let before = sub str 0 i in 40 | let p = i + 1 in 41 | let after = sub str p (length str - p) in 42 | let l = aux after in 43 | before :: l 44 | | None -> [str] 45 | in 46 | aux str 47 | ;; 48 | 49 | let uppercase_ascii = map Char.uppercase_ascii 50 | let lowercase_ascii = map Char.lowercase_ascii 51 | 52 | let apply_hd f s = 53 | let aux = function 0 -> f s.[0] | i -> s.[i] in 54 | init (length s) aux 55 | ;; 56 | 57 | let capitalize_ascii = apply_hd Char.uppercase_ascii 58 | let uncapitalize_ascii = apply_hd Char.lowercase_ascii 59 | 60 | let escaped str = 61 | let rec aux acc i = 62 | let e = match str.[i] with '"' -> "\\\"" | c -> Char.escaped c in 63 | let acc = e ^ acc in 64 | match i with 0 -> acc | i -> aux acc (i - 1) 65 | in 66 | match length str with 0 -> "" | i -> aux "" (i - 1) 67 | ;; 68 | -------------------------------------------------------------------------------- /test/list_.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.expr 3 | {| 4 | let v = 1 :: 2 :: 3 :: [] in 5 | let rec length = function 6 | | [] -> 0 7 | | _ :: t -> 1 + length t 8 | in length v 9 | |}; 10 | Tester.f 11 | {| 12 | let v1 = [1; 2; 3] ;; 13 | let v2 = [4; 2; 9; 10;] ;; 14 | let rec print_list = function 15 | | [] -> print_int 0 16 | | h :: t -> print_int h; print_list t 17 | and app a b = match a with 18 | | [] -> b 19 | | h :: t -> h :: (app t b) 20 | and rev = function 21 | | [] -> [] 22 | | h :: t -> app (rev t) [h] 23 | ;; 24 | print_list (rev (app v1 v2)) 25 | |}; 26 | Tester.expr 27 | {| 28 | let v1 = [(1, 2); (2, 3); (3, 4)] in 29 | let rec f = function 30 | | [] -> 0 31 | | (x, y) :: t -> x + y + (f t) 32 | in f v1 33 | |}; 34 | Tester.expr 35 | {| 36 | let l = [1; 2; 3; 2; 3] in 37 | let rec f l = 38 | match l with 39 | | a :: b :: t -> a * b + (f t) 40 | | _ -> 0 41 | in f l 42 | |}; 43 | Tester.f 44 | {| 45 | type t = 46 | | A 47 | | G 48 | | C 49 | | T 50 | ;; 51 | 52 | let l1 = [A; T; G; C; A; T; G; A; C; T; A; A] ;; 53 | let l2 = [G; A; C; T; A; T; G; C; A; T; T; A; A] ;; 54 | let rec parse = function 55 | | A :: T :: G :: rest -> 56 | let rest, acc = parse rest in 57 | rest, 1 :: acc 58 | | C :: A :: T :: rest -> 59 | let rest, acc = parse rest in 60 | rest, 2 :: acc 61 | | G :: A :: C :: rest -> 62 | let rest, acc = parse rest in 63 | rest, 3 :: acc 64 | | T :: A :: A :: rest -> rest, [0] 65 | | _ :: t -> parse t 66 | | [] -> [], [] 67 | ;; 68 | 69 | let rec print_list = function 70 | | [] -> print_int 0 71 | | h :: t -> print_int h; print_list t 72 | ;; 73 | 74 | let print_result r = 75 | let _, l = r in 76 | print_list l 77 | ;; 78 | 79 | print_result (parse l1) ;; 80 | print_result (parse l2) ;; 81 | |}; 82 | Tester.expr 83 | {| 84 | let rec f = function 85 | | [a; b] -> a + b 86 | | [1] -> 10 87 | | [x] -> x 88 | | h :: t -> f [h] + f t 89 | | _ -> 100 90 | in 91 | f [3; 1; 5; 2; 1; 7; 1; 10] 92 | |} 93 | ;; 94 | -------------------------------------------------------------------------------- /test/equality.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | (* Physical equality *) 3 | Tester.bool_expr "1 == 1"; 4 | Tester.bool_expr "1 != 1"; 5 | Tester.bool_expr "0 == 1"; 6 | Tester.bool_expr "0 != 1"; 7 | Tester.bool_expr "(1, 2, 3) == (1, 2, 3)"; 8 | (* Structural equality *) 9 | Tester.bool_expr "2 = 2"; 10 | Tester.bool_expr "0 <> 0"; 11 | Tester.bool_expr "(1, 2) = (1, 2)"; 12 | Tester.bool_expr "(1, (2, 3), 3) = (1, (2, 3), 3)"; 13 | Tester.bool_expr "(1, 4, 3) = (1, 2, 3)"; 14 | Tester.bool_expr "(4, 3) = (2, 3)"; 15 | Tester.bool_expr "((2, 3), 5, (2, 6)) <> ((2, 3), 5, (2, 6))"; 16 | Tester.bool_expr "(1, 5, (2, 6)) <> (1, 5, (2, 3))"; 17 | Tester.bool_expr "(4, 3) <> (2, 3)"; 18 | Tester.bool_expr 19 | {| 20 | let a = (4, (3, (3, 2), 3)) in 21 | let b = (3, 2) in 22 | let f v = (4, (v, b, v)) in 23 | a = f 3 24 | |}; 25 | (* variant *) 26 | Tester.f 27 | {| 28 | type variant = 29 | | A of int * int 30 | | B of int * int 31 | | C of int 32 | | D 33 | 34 | let print_bool = function 35 | | true -> print_int 1 36 | | false -> print_int 0 37 | ;; 38 | 39 | (* Physical equality *) 40 | print_bool (A (1, 2) == A (1, 2)) ;; 41 | print_bool (A (6, 2) != B (6, 2)) ;; 42 | 43 | (* Structural equality *) 44 | print_bool (A (1, 2) = A (1, 2)) ;; 45 | print_bool (A (3, 2) <> A (1, 4)) ;; 46 | print_bool (A (3, 2) = A (1, 4)) ;; 47 | print_bool (A (6, 2) = B (6, 2)) ;; 48 | print_bool (C 1 = C 1) ;; 49 | print_bool (A (5, 2) <> C 1) ;; 50 | print_bool (A (0, 0) = D) ;; 51 | print_bool (D = D) ;; 52 | print_bool (D <> C 0) ;; 53 | 54 | (* with tuple *) 55 | print_bool ((1, A (1, 2)) = (1, A (1, 2))) ;; 56 | print_bool ((A (1, 2), 4) <> (B (1, 2), 4)) ;; 57 | print_bool ((1, D) = (1, C 0)) ;; 58 | 59 | (* complex *) 60 | let f = function 61 | | 1 -> A (0, 0) 62 | | 2 -> B (0, 0) 63 | | x -> C x 64 | in let g = function 65 | | x, y when x = (1, 2) -> y + 1 66 | | x, y when x = (3, 5) -> y + 3 67 | | _, y -> y 68 | in 69 | print_bool (f (g ((3, 5), 0)) = A (0, 0)); 70 | print_bool (f (g ((1, 5), 5)) <> C 5); 71 | print_bool (f (g ((1, 2), 1)) = B (0, 0)) 72 | |} 73 | ;; 74 | -------------------------------------------------------------------------------- /mlml/tree/path.ml: -------------------------------------------------------------------------------- 1 | type t = Path of string list 2 | 3 | let string_of_path = function Path l -> String.concat "." l 4 | let path_of_string s = Path (String.split_on_char '.' s) 5 | let of_list l = Path l 6 | let single s = of_list [s] 7 | let length = function Path l -> List.length l 8 | 9 | (* return a list of strings from path *) 10 | let extract = function Path l -> l 11 | 12 | (* return the common part of two paths *) 13 | (* e.g. common (path_of_string "A.B.C") (path_of_string "A.B.ab.cd") *) 14 | (* -> Path ("A.B") *) 15 | let common a b = 16 | let rec aux a b = 17 | match a, b with h1 :: t1, h2 :: t2 when h1 = h2 -> h1 :: aux t1 t2 | _ -> [] 18 | in 19 | of_list (aux (extract a) (extract b)) 20 | ;; 21 | 22 | (* join two paths *) 23 | let join a b = of_list (extract a @ extract b) 24 | 25 | (* check if b is under a *) 26 | let is_under a b = 27 | let c = common a b in 28 | c = a 29 | ;; 30 | 31 | let is_root = function Path [] -> true | _ -> false 32 | let is_empty = is_root 33 | let root = of_list [] 34 | 35 | (* slow operation: extract the last element of path *) 36 | let init_last path = 37 | let rec aux = function 38 | | [h] -> [], h 39 | | h :: t -> 40 | let acc, last = aux t in 41 | h :: acc, last 42 | | _ -> failwith "Empty" 43 | in 44 | aux @@ extract path 45 | ;; 46 | 47 | let init path = init_last path |> fst 48 | let last path = init_last path |> snd 49 | let last_path path = single @@ last path 50 | let head_tail = function Path (h :: t) -> h, t | Path [] -> failwith "Empty" 51 | let head path = head_tail path |> fst 52 | let tail path = head_tail path |> snd 53 | let compare = compare 54 | let is_capitalized path = match (last path).[0] with 'A' .. 'Z' -> true | _ -> false 55 | let is_single path = length path == 1 56 | 57 | let subpaths path = 58 | let rec aux path = 59 | match length path with 60 | | 0 -> [root] 61 | | _ -> 62 | let t, _ = init_last path in 63 | let acc = aux (of_list t) in 64 | path :: acc 65 | in 66 | aux path 67 | ;; 68 | -------------------------------------------------------------------------------- /mlml/codegen/output_buffer.ml: -------------------------------------------------------------------------------- 1 | type placeholder = Holder of int 2 | 3 | type line = 4 | | Label of string 5 | | Inst of string 6 | | Placeholder of placeholder 7 | 8 | type t = 9 | { mutable main : line list 10 | ; mutable sub : line list 11 | ; mutable placeholder_index : int } 12 | 13 | let create () = {main = []; sub = []; placeholder_index = 0} 14 | 15 | (* basic emit functions *) 16 | let emit buf line = 17 | match line, buf.main with 18 | | Inst i1, Inst i2 :: t -> 19 | let inst = Printf.sprintf "%s\n%s" i2 i1 in 20 | buf.main <- Inst inst :: t 21 | | _ -> buf.main <- line :: buf.main 22 | ;; 23 | 24 | let emit_sub buf line = buf.sub <- line :: buf.sub 25 | 26 | (* prepend functions (slow) *) 27 | let prepend buf line = buf.main <- buf.main @ [line] 28 | let prepend_sub buf line = buf.sub <- buf.sub @ [line] 29 | 30 | (* auxiliary functions *) 31 | let emit_inst buf inst = emit buf (Inst inst) 32 | let emit_sub_inst buf inst = emit_sub buf (Inst inst) 33 | let emit_inst_fmt buf = Printf.ksprintf (fun x -> emit_inst buf x) 34 | let emit_sub_inst_fmt buf = Printf.ksprintf (fun x -> emit_sub_inst buf x) 35 | let prepend_inst buf inst = prepend buf (Inst inst) 36 | let prepend_sub_inst buf inst = prepend_sub buf (Inst inst) 37 | 38 | (* placeholder handlings *) 39 | let create_placeholder buf = 40 | let i = buf.placeholder_index in 41 | buf.placeholder_index <- i + 1; 42 | Holder i 43 | ;; 44 | 45 | let emit_placeholder buf = 46 | let p = create_placeholder buf in 47 | emit buf (Placeholder p); 48 | p 49 | ;; 50 | 51 | let emit_sub_placeholder buf = 52 | let p = create_placeholder buf in 53 | emit_sub buf (Placeholder p); 54 | p 55 | ;; 56 | 57 | let substitute buf holder line = 58 | let aux = function Placeholder l when l = holder -> line | l -> l in 59 | buf.main <- List.map aux buf.main 60 | ;; 61 | 62 | let prepend_buffer a b = 63 | let a_idx = a.placeholder_index in 64 | let aux = function 65 | | Placeholder (Holder i) -> Placeholder (Holder (i + a_idx)) 66 | | l -> l 67 | in 68 | a.main <- List.map aux b.main |> List.append a.main; 69 | a.sub <- List.map aux b.sub |> List.append a.sub; 70 | a.placeholder_index <- a_idx + b.placeholder_index 71 | ;; 72 | 73 | let append_buffer a b = prepend_buffer b a 74 | 75 | let contents buf = 76 | let aux = function 77 | | Label s -> s ^ ":" 78 | | Inst s -> "\t" ^ s 79 | | Placeholder _ -> failwith "subst is left" 80 | in 81 | List.rev buf.main |> List.rev_append buf.sub |> List.map aux |> String.concat "\n" 82 | ;; 83 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # mlml 2 | 3 | [![Build Status](https://travis-ci.com/coord-e/mlml.svg?branch=develop)](https://travis-ci.com/coord-e/mlml) 4 | [![Coverage Status](https://coveralls.io/repos/github/coord-e/mlml/badge.svg)](https://coveralls.io/github/coord-e/mlml) 5 | ![Docker Cloud Automated build](https://img.shields.io/docker/cloud/automated/coorde/mlml.svg) 6 | ![Docker Cloud Build Status](https://img.shields.io/docker/cloud/build/coorde/mlml.svg) 7 | [![MicroBadger Image](https://images.microbadger.com/badges/image/coorde/mlml.svg)](https://microbadger.com/images/coorde/mlml) 8 | 9 | mlml is a self-hosted toy compiler for a tiny subset of OCaml. 10 | 11 | a detailed description can be found in my blog post (in Japanese): [自作OCamlコンパイラでセルフホストした - molecular coordinates](https://coordination.hatenablog.com/entry/2019/05/23/212720) 12 | 13 | ## roadmap 14 | 15 | - [x] basic arithmetic 16 | - [x] variables 17 | - [x] if-then-else 18 | - [x] functions 19 | - [x] recursion 20 | - [x] mutual recursion 21 | - [x] closure 22 | - [x] currying 23 | - [x] tuples 24 | - [x] variants 25 | - [x] records 26 | - [x] pattern matching 27 | - [x] structual comparison 28 | - [x] primitive types 29 | - [x] string 30 | - [x] list 31 | - [x] bytes 32 | - [x] array 33 | - [x] formatted output with `Printf` 34 | - [x] modules 35 | - [x] definition 36 | - [x] aliases 37 | - [x] `open` 38 | - [x] dune-like bundler 39 | - [x] **self-hosting!** 40 | - [ ] exceptions 41 | - [ ] type checker & type inference 42 | 43 | ## self hosting 44 | 45 | mlml is self-hosted. i.e. mlml can compile itself. 46 | 47 | ```shell 48 | ./dev/exec.sh ./dev/self_host.sh 49 | ``` 50 | 51 | To obtain build artifacts, pass a path to local directory as below. You will see compiled binaries under `./self_host`. 52 | 53 | ```shell 54 | mkdir self_host 55 | ./dev/exec.sh ./dev/self_host.sh ./self_host 56 | ``` 57 | 58 | ## limitations 59 | 60 | - `external` definitions are only available for functions 61 | - all modules and paths are statically-resolved 62 | - all custom oeprators are left-associative 63 | - `function` keyword does not make an expression 64 | 65 | ## development 66 | 67 | If you have docker installed in your system, simply run 68 | 69 | ```shell 70 | ./dev/start.sh 71 | ``` 72 | 73 | to start the development. 74 | 75 | You can run tests manually by running the following command: 76 | 77 | ```shell 78 | ./dev/exec.sh dune runtest 79 | ``` 80 | 81 | ## thanks 82 | 83 | The code and algorithm in parser and lexer is strongly inspired by [ushitora-anqou/aqaml](https://github.com/ushitora-anqou/aqaml) 84 | -------------------------------------------------------------------------------- /dev/self_host.sh: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -euo pipefail 4 | 5 | readonly WORKDIR="${1:-$(mktemp -d)}" 6 | 7 | function info () { 8 | >&2 echo "$(tput setaf 2)=> $(tput sgr0)$(tput bold)$@$(tput sgr0)" 9 | } 10 | 11 | function warn () { 12 | >&2 echo "$(tput setaf 3)$(tput bold)WARN $(tput sgr0)$@" 13 | } 14 | 15 | function error () { 16 | >&2 echo "$(tput setaf 1)$(tput bold)ERROR $(tput sgr0)$@" 17 | } 18 | 19 | function cmd () { 20 | >&2 echo "$(tput setaf 5)$ $@$(tput sgr0)" 21 | eval $@ 22 | } 23 | 24 | function interrupt () { 25 | error "Interrupted." 26 | exit 1 27 | } 28 | 29 | function check_environment () { 30 | function check_stack_size () { 31 | local max_stack=$(ulimit -s) 32 | [ $max_stack -gt 1000000 ] \ 33 | || warn "Compilation might fail with segfault due to small maximum stack size" 34 | } 35 | 36 | function check_docker () { 37 | # thanks to Henk Lengeveld from StackOverflow 38 | # https://stackoverflow.com/questions/23513045/ 39 | cat /proc/1/cgroup | grep -q "/docker" \ 40 | || warn "It seems that this script is running outside of the development docker container" 41 | } 42 | 43 | check_stack_size 44 | check_docker 45 | } 46 | 47 | function compile () { 48 | set -euo pipefail 49 | 50 | local EXECOUT="$1" 51 | local ASMOUT="$EXECOUT.s" 52 | shift 53 | 54 | cmd "$@ bin/mlmlc.ml > \"$ASMOUT\"" 55 | cmd "gcc \"$ASMOUT\" -lgc -o \"$EXECOUT\"" 56 | cmd "md5sum \"$ASMOUT\" | cut -d' ' -f1" 57 | } 58 | 59 | function readonly_ () { 60 | if [ $? -ne 0 ]; then 61 | error "command exited with non-zero code" 62 | exit 3 63 | else 64 | readonly $@ 65 | fi 66 | } 67 | 68 | function main () { 69 | readonly GEN1="$WORKDIR/mlmlc_1" 70 | readonly GEN2="$WORKDIR/mlmlc_2" 71 | readonly GEN3="$WORKDIR/mlmlc_3" 72 | 73 | info "Compiling mlml with ocaml" 74 | readonly_ GEN1_HASH=$(compile $GEN1 dune exec bin/mlmlc.exe) 75 | info "Successfully compiled 1st-gen compiler: $GEN1 (${GEN1_HASH:0:7})" 76 | 77 | info "Compiling mlml with mlml (1st generation)" 78 | readonly_ GEN2_HASH=$(compile $GEN2 $GEN1) 79 | info "Successfully compiled 2nd-gen compiler: $GEN2 (${GEN2_HASH:0:7})" 80 | 81 | info "Compiling mlml with mlml (2nd generation)" 82 | readonly_ GEN3_HASH=$(compile $GEN3 $GEN2) 83 | info "Successfully compiled 3rd-gen compiler: $GEN3 (${GEN3_HASH:0:7})" 84 | 85 | if cmd [ "$GEN2_HASH" = "$GEN3_HASH" ]; then 86 | info "*** SELF HOSTING SUCCEEDED ***" 87 | else 88 | warn "Output mismatch between 2nd and 3rd generation compilers" 89 | error "Self hosting failed" 90 | exit 2 91 | fi 92 | } 93 | 94 | trap interrupt INT 95 | check_environment 96 | main 97 | -------------------------------------------------------------------------------- /test/tester.ml: -------------------------------------------------------------------------------- 1 | open Mlml 2 | 3 | let input_line_opt ch = try Some (input_line ch) with End_of_file -> None 4 | 5 | let input_all ch = 6 | let rec aux acc = 7 | match input_line_opt ch with 8 | | Some line -> aux (line :: acc) 9 | | None -> List.rev acc |> String.concat "\n" 10 | in 11 | aux [] 12 | ;; 13 | 14 | let open_and_read_result cmd = 15 | let channel = Unix.open_process_in cmd in 16 | let result = input_all channel in 17 | let status = Unix.close_process_in channel in 18 | (* TODO: Fail if status is not zero or process is signaled *) 19 | (match status with 20 | | Unix.WEXITED code -> 21 | if code != 0 22 | then Printf.eprintf "Warning: Execution of test code failed with code %d\n" code 23 | | Unix.WSTOPPED s | Unix.WSIGNALED s -> 24 | Printf.eprintf "Warning: Execution of test code failed with signal %d\n" s); 25 | result 26 | ;; 27 | 28 | let exec_with_mlml_file file = 29 | let as_file = Filename.temp_file "." ".s" in 30 | let oc = open_out as_file in 31 | Printf.fprintf oc "%s\n" @@ Compile.f file; 32 | close_out oc; 33 | let exec_file = Filename.temp_file "." "" in 34 | let ret_code = Sys.command @@ Printf.sprintf "gcc %s -lgc -o %s" as_file exec_file in 35 | if ret_code != 0 then failwith "Failed to compile resulting assembly"; 36 | open_and_read_result exec_file 37 | ;; 38 | 39 | let exec_with_mlml source = 40 | let ml_file = Filename.temp_file "." ".ml" in 41 | let oc = open_out ml_file in 42 | Printf.fprintf oc "%s\n" source; 43 | close_out oc; 44 | exec_with_mlml_file ml_file 45 | ;; 46 | 47 | let exec_with_ocaml_file file = open_and_read_result @@ "ocaml " ^ file 48 | 49 | let exec_with_ocaml source = 50 | let ml_file = Filename.temp_file "." ".ml" in 51 | let oc = open_out ml_file in 52 | Printf.fprintf oc "%s\n" source; 53 | close_out oc; 54 | exec_with_ocaml_file ml_file 55 | ;; 56 | 57 | let f source = 58 | let mlml_result = exec_with_mlml source in 59 | let ocaml_result = exec_with_ocaml source in 60 | if not (mlml_result = ocaml_result) 61 | then ( 62 | Printf.eprintf "mlml: (%s)\nocaml: (%s)\n" mlml_result ocaml_result; 63 | failwith "assertion failed" ) 64 | ;; 65 | 66 | let expr source = 67 | let source = Printf.sprintf "print_int (%s)" source in 68 | f source 69 | ;; 70 | 71 | let bool_expr source = 72 | let source = Printf.sprintf "if (%s) then 1 else 0" source in 73 | expr source 74 | ;; 75 | 76 | let file path expected_result = 77 | let mlml_result = exec_with_mlml_file path in 78 | if not (mlml_result = expected_result) 79 | then ( 80 | Printf.eprintf "mlml: (%s)\nexpected: (%s)\n" mlml_result expected_result; 81 | failwith "assertion failed" ) 82 | ;; 83 | -------------------------------------------------------------------------------- /mlml/bundler/find_dependencies.ml: -------------------------------------------------------------------------------- 1 | module SS = Tree.Simple_set 2 | module TyExpr = Tree.Type_expression 3 | module Expr = Tree.Expression 4 | module Mod = Tree.Module 5 | module Path = Tree.Path 6 | module Pat = Tree.Pattern 7 | 8 | type mutable_set = {mutable data : string SS.t} 9 | 10 | let empty () = {data = SS.empty} 11 | let union s x = s.data <- SS.union x s.data 12 | let add s x = s.data <- SS.add x s.data 13 | 14 | type env = mutable_set 15 | 16 | let deps_of_module_path env path = 17 | let h = Path.head path in 18 | if SS.mem h env.data then SS.empty else SS.singleton h 19 | ;; 20 | 21 | let deps_of_path env path = 22 | match Path.is_single path with 23 | | true -> SS.empty 24 | | false -> deps_of_module_path env path 25 | ;; 26 | 27 | let vars env s path _ = union s @@ deps_of_path env path 28 | let binds x _ = x 29 | 30 | let type_expression env ex = 31 | let s = empty () in 32 | ignore @@ TyExpr.apply_on_names (vars env s) binds ex; 33 | s.data 34 | ;; 35 | 36 | let type_definition env = function 37 | | Mod.Variant l -> 38 | let aux = function _, Some x -> type_expression env x | _, None -> SS.empty in 39 | List.map aux l |> List.fold_left SS.union SS.empty 40 | | Mod.Record l -> 41 | let aux (_, _, x) = type_expression env x in 42 | List.map aux l |> List.fold_left SS.union SS.empty 43 | | Mod.Alias x -> type_expression env x 44 | ;; 45 | 46 | let pattern env p = 47 | let s = empty () in 48 | ignore @@ Pat.apply_on_names (vars env s) binds p; 49 | s.data 50 | ;; 51 | 52 | let expression env e = 53 | let s = empty () in 54 | ignore @@ Expr.apply_on_names (vars env s) binds e; 55 | s.data 56 | ;; 57 | 58 | let rec definition env = function 59 | | Mod.LetAnd (_, l) -> 60 | let aux = function 61 | | Expr.VarBind (p, b) | Expr.FunBind (_, p, b) -> 62 | SS.union (pattern env p) (expression env b) 63 | in 64 | List.map aux l |> List.fold_left SS.union SS.empty 65 | | Mod.TypeDef l -> 66 | let aux (_, _, def) = type_definition env def in 67 | List.map aux l |> List.fold_left SS.union SS.empty 68 | | Mod.Module (name, Mod.Path path) -> 69 | let s = deps_of_module_path env path in 70 | add env name; 71 | s 72 | | Mod.Module (name, Mod.Struct l) -> 73 | let s = module_items env l in 74 | add env name; 75 | s 76 | | Mod.Open path -> deps_of_module_path env path 77 | | Mod.External (_, ty, _) -> type_expression env ty 78 | 79 | and module_item env = function 80 | | Mod.Expression expr -> expression env expr 81 | | Mod.Definition defn -> definition env defn 82 | 83 | and module_items env l = List.map (module_item env) l |> List.fold_left SS.union SS.empty 84 | 85 | let f l = 86 | let env = empty () in 87 | module_items env l 88 | ;; 89 | -------------------------------------------------------------------------------- /mlml/parser/type_expression.ml: -------------------------------------------------------------------------------- 1 | (* Parse the type expression. *) 2 | (* https://caml.inria.fr/pub/docs/manual-ocaml/types.html *) 3 | 4 | module L = Lexer 5 | module T = Tree.Type_expression 6 | 7 | type t = Tree.Path.t T.t 8 | 9 | let string_of_type_expression = T.string_of_type_expression Tree.Path.string_of_path 10 | 11 | let rec try_parse_primary tokens = 12 | match tokens with 13 | | L.LowerIdent ident :: rest -> rest, Some (T.Ident (Tree.Path.single ident)) 14 | | L.CapitalIdent _ :: _ -> 15 | (match Path.try_parse_path tokens with 16 | | rest, Some p -> rest, Some (T.Ident p) 17 | | rest, None -> rest, None) 18 | | L.Apostrophe :: L.LowerIdent ident :: rest -> rest, Some (T.Var ident) 19 | | L.LParen :: rest -> 20 | let rest, v = parse_type_expression rest in 21 | (match rest with L.RParen :: rest -> rest, Some v | _ -> rest, None) 22 | | tokens -> tokens, None 23 | 24 | and parse_primary tokens = 25 | match try_parse_primary tokens with 26 | | tokens, Some v -> tokens, v 27 | | h :: _, None -> 28 | failwith @@ Printf.sprintf "unexpected token: '%s'" (L.string_of_token h) 29 | | [], None -> failwith "Empty input" 30 | 31 | and parse_type_params = function 32 | | L.LParen :: rest -> 33 | let rec aux tokens = 34 | let rest, t = parse_type_expression tokens in 35 | match rest with 36 | | L.Comma :: rest -> 37 | let rest, l = aux rest in 38 | rest, t :: l 39 | | L.RParen :: rest -> rest, [t] 40 | | _ -> failwith "could not parse type params" 41 | in 42 | aux rest 43 | | tokens -> 44 | let rest, t = parse_primary tokens in 45 | rest, [t] 46 | 47 | and parse_app tokens = 48 | let rest, l = parse_type_params tokens in 49 | let rec aux l tokens = 50 | let rest, path_opt = Path.try_parse_path tokens in 51 | match path_opt, l with 52 | | Some path, l -> aux [T.Ctor (l, path)] rest 53 | | None, [t] -> rest, t 54 | | _ -> failwith "could not parse type" 55 | in 56 | aux l rest 57 | 58 | and parse_tuple tokens = 59 | let rec aux tokens = 60 | let rest, curr = parse_app tokens in 61 | match rest with 62 | | L.Star :: rest -> 63 | let rest, tail = aux rest in 64 | rest, curr :: tail 65 | | _ -> rest, [curr] 66 | in 67 | let rest, values = aux tokens in 68 | match values with 69 | | [] -> failwith "unreachable" 70 | | [value] -> rest, value 71 | | _ -> rest, T.Tuple values 72 | 73 | and parse_fun tokens = 74 | let tokens, lhs = parse_tuple tokens in 75 | match tokens with 76 | | L.Arrow :: tokens -> 77 | let tokens, rhs = parse_fun tokens in 78 | tokens, T.Function (lhs, rhs) 79 | | _ -> tokens, lhs 80 | 81 | and parse_type_expression tokens = parse_fun tokens 82 | -------------------------------------------------------------------------------- /test/record.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.f 3 | {| 4 | type t = 5 | { a : int 6 | ; b : int 7 | ; c : string } 8 | ;; 9 | 10 | let v = {a = 1; c = "hello!"; b = 2} in 11 | print_int v.a; 12 | print_int v.b; 13 | print_string v.c 14 | |}; 15 | Tester.f 16 | {| 17 | type t = 18 | { a : int 19 | ; b : string } 20 | 21 | let create a = {a; b = "hello"} 22 | let modify v s = {v with b = s} 23 | ;; 24 | 25 | let v = create 7 in 26 | match modify v "world" with {a; b = c} -> print_int a; print_string c 27 | |}; 28 | Tester.f 29 | {| 30 | type t1 = 31 | { a : string 32 | ; b : int * string } 33 | 34 | and t2 = 35 | { f : string 36 | ; s : string 37 | ; t : string } 38 | 39 | and t3 = 40 | { value : t1 * int 41 | ; sub : t2 } 42 | 43 | let v = {value = {a = "hello"; b = 10, "he"}, 10; sub = {f = "l"; s = "l"; t = "o"}} 44 | 45 | let f v = 46 | let vf, vs = v.value in 47 | let bf, bs = vf.b in 48 | let {f = sf; s = ss; t = _} = v.sub in 49 | let s = bs ^ sf ^ ss in 50 | if s = vf.a then bf + vs else bf * vs 51 | ;; 52 | 53 | let g = function 54 | | {value = {a; b = 10, b}, _; sub = {f; s; t}} -> a ^ b ^ f ^ s ^ t 55 | | _ -> "mlml" 56 | ;; 57 | 58 | print_int (f v) ;; 59 | print_string (g v) ;; 60 | print_string (g {v with value = {a = "string"; b = 20, "str"}, 1}) ;; 61 | print_string (g {v with sub = {v.sub with t = "o, mlml"}}) 62 | |}; 63 | Tester.f 64 | {| 65 | type 'a t = 66 | { lst : 'a t list 67 | ; v : 'a } 68 | 69 | let rec f v = 70 | let rec aux = function h :: t -> (aux h.lst * h.v) + aux t | [] -> v.v in 71 | aux v.lst 72 | ;; 73 | 74 | let value = {lst = [{lst = [{lst = []; v = 1}]; v = 10}; {lst = []; v = 40}]; v = 20} 75 | 76 | ;; 77 | print_int (f value) 78 | |}; 79 | (* mutable fields *) 80 | Tester.f 81 | {| 82 | type r = { mutable a : int; mutable b : string } 83 | let print_r {a; b} = Printf.printf "a = %d, b = %s\n" a b 84 | let r = { a = 10; b = "hello" } 85 | ;; 86 | print_r r; 87 | r.a <- 20; 88 | print_r r; 89 | r.b <- "hi"; 90 | print_r r 91 | |}; 92 | Tester.f 93 | {| 94 | type r = { a : int; mutable b : string } ;; 95 | let r = { a = 10; b = "hello" } in 96 | let s = r in 97 | r.b <- "world"; 98 | print_string s.b; 99 | let t = { r with a = 30 } in 100 | r.b <- "mlml"; 101 | print_string t.b 102 | |}; 103 | Tester.f 104 | {| 105 | type t0 = { deep_value : string } 106 | type t1 = { inner_value : int; t0 : t0 } 107 | type t2 = { value : t1 } 108 | ;; 109 | let v = { value = { inner_value = 41; t0 = { deep_value = "Hello" }}} in 110 | print_int v.value.inner_value; 111 | print_string v.value.t0.deep_value; 112 | print_char v.value.t0.deep_value.[2] 113 | |} 114 | ;; 115 | -------------------------------------------------------------------------------- /mlml/tree/module.ml: -------------------------------------------------------------------------------- 1 | module Expr = Expression 2 | module Pat = Pattern 3 | module TyExpr = Type_expression 4 | 5 | type 'a type_def = 6 | | Variant of (string * 'a TyExpr.t option) list 7 | | Record of (bool * string * 'a TyExpr.t) list 8 | | Alias of 'a TyExpr.t 9 | 10 | type 'a module_expr = 11 | | Path of Path.t 12 | | Struct of 'a module_item list 13 | 14 | and 'a definition = 15 | | LetAnd of bool * 'a Expr.let_binding list 16 | | TypeDef of (string list * string * 'a type_def) list 17 | | Module of string * 'a module_expr 18 | | Open of 'a 19 | | External of string * 'a TyExpr.t * string 20 | 21 | and 'a module_item = 22 | | Definition of 'a definition 23 | | Expression of 'a Expr.t 24 | 25 | let rec string_of_type_def f = function 26 | | Variant variants -> 27 | let aux (ctor, param) = 28 | match param with 29 | | Some p -> Printf.sprintf "%s (%s)" ctor (TyExpr.string_of_type_expression f p) 30 | | None -> ctor 31 | in 32 | List.map aux variants |> String.concat " | " 33 | | Record fields -> 34 | let aux (is_mut, name, ty) = 35 | Printf.sprintf 36 | "%s%s: %s" 37 | (if is_mut then "mutable " else "") 38 | name 39 | (TyExpr.string_of_type_expression f ty) 40 | in 41 | List.map aux fields |> String.concat "; " |> Printf.sprintf "{%s}" 42 | | Alias ty -> TyExpr.string_of_type_expression f ty 43 | 44 | and string_of_module_expression f = function 45 | | Path p -> Path.string_of_path p 46 | | Struct l -> 47 | List.map (string_of_module_item f) l 48 | |> String.concat ";; " 49 | |> Printf.sprintf "struct %s end" 50 | 51 | and string_of_definition f = function 52 | | LetAnd (is_rec, l) -> 53 | let l = List.map (Expr.string_of_let_binding f) l |> String.concat " and " in 54 | Printf.sprintf "Let %s %s" (if is_rec then "rec" else "") l 55 | | TypeDef l -> 56 | let aux (params, name, def) = 57 | let params = String.concat ", '" params |> Printf.sprintf "('%s)" in 58 | Printf.sprintf "%s %s = %s" params name (string_of_type_def f def) 59 | in 60 | List.map aux l |> String.concat " and " |> Printf.sprintf "type %s" 61 | | Module (name, mexp) -> 62 | Printf.sprintf "module %s = (%s)" name (string_of_module_expression f mexp) 63 | | Open path -> Printf.sprintf "open %s" (f path) 64 | | External (name, ty, decl) -> 65 | Printf.sprintf 66 | "external %s : (%s) = \"%s\"" 67 | name 68 | (TyExpr.string_of_type_expression f ty) 69 | decl 70 | 71 | and string_of_module_item f = function 72 | | Definition def -> string_of_definition f def 73 | | Expression expr -> Expr.string_of_expression f expr 74 | ;; 75 | 76 | (* TODO: function composition can make this clearer *) 77 | let string_of_module_items f items = 78 | List.map (string_of_module_item f) items |> String.concat ";; " 79 | ;; 80 | -------------------------------------------------------------------------------- /test/module.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | Tester.f 3 | {| 4 | module M = struct 5 | let f x = x + 1 6 | let v = 42 7 | end 8 | 9 | let f x = x * 10 ;; 10 | print_int (M.f (f M.v)) 11 | |}; 12 | Tester.f 13 | {| 14 | module Long_name = struct 15 | let f x = x * 42 16 | module So_long_name = struct 17 | let f x = x + 42 18 | end 19 | end 20 | 21 | module L = Long_name 22 | module S = L.So_long_name 23 | module A = S 24 | ;; 25 | 26 | print_int (L.f (A.f 42)) 27 | |}; 28 | Tester.f 29 | {| 30 | module M = struct 31 | let f x = x + 1 32 | let v = 42 33 | end 34 | 35 | (* will be overwritten *) 36 | let f x = x * 10 37 | 38 | open M ;; 39 | 40 | print_int (f v) 41 | |}; 42 | Tester.f 43 | {| 44 | let f x = x + 30 45 | 46 | module M = struct 47 | let f x = x + 1 48 | let v = 42 49 | end 50 | 51 | module L = struct 52 | (* will be overwritten *) 53 | let f x = x * 10 54 | 55 | module M = struct 56 | let f x = x * 1 57 | end 58 | 59 | ;; 60 | print_int (M.f 10) 61 | end 62 | |}; 63 | Tester.f 64 | {| 65 | module M = struct 66 | type t = 67 | | A 68 | | B 69 | | C 70 | 71 | type r = 72 | { a : t 73 | ; b : int } 74 | 75 | let f = function A -> 1 | B -> 2 | C -> 3 76 | end 77 | 78 | type t = A of M.r 79 | 80 | ;; 81 | let f (A {M.a; M.b}) = 82 | let i = M.f a + b in 83 | print_int i 84 | in 85 | f (A {M.a = M.A; M.b = 10}) 86 | |}; 87 | Tester.f 88 | {| 89 | module M = struct 90 | type t = 91 | | A 92 | | B 93 | | C 94 | end 95 | 96 | open M 97 | 98 | ;; 99 | let f = function 100 | | A -> 1 101 | | B -> 2 102 | | C -> 3 103 | in print_int (f A) 104 | |}; 105 | Tester.f 106 | {| 107 | let var = 1 108 | module A = struct 109 | let var = 2 110 | module B = struct 111 | let var = 3 112 | module C = struct 113 | ;; 114 | print_int var 115 | end 116 | end 117 | end 118 | |}; 119 | Tester.f 120 | {| 121 | let var = 1 122 | module A = struct 123 | let var = 2 124 | module B = struct 125 | module C = struct 126 | ;; 127 | print_int var 128 | end 129 | end 130 | end 131 | |}; 132 | Tester.f 133 | {| 134 | module A = struct 135 | module D = struct 136 | let var = 2 137 | end 138 | module B = struct 139 | module C = struct 140 | ;; 141 | print_int D.var 142 | end 143 | end 144 | end 145 | |}; 146 | Tester.f 147 | {| 148 | module B = struct 149 | let var = 3 150 | end 151 | module A = struct 152 | open B ;; 153 | print_int var ;; 154 | let var = 10 ;; 155 | print_int var 156 | end 157 | |}; 158 | Tester.f 159 | {| 160 | let print_string s = print_string s; print_string "hi!" 161 | ;; 162 | print_string "wow" 163 | |} 164 | ;; 165 | -------------------------------------------------------------------------------- /mlml/tree/pattern.ml: -------------------------------------------------------------------------------- 1 | module NS = Namespace 2 | module SS = Simple_set 3 | 4 | type 'a t = 5 | | Var of string 6 | | Wildcard 7 | | Int of int 8 | | String of string 9 | | Tuple of 'a t list 10 | | Array of 'a t list 11 | | Ctor of 'a * 'a t option 12 | | Or of 'a t * 'a t 13 | | Cons of 'a t * 'a t 14 | | Nil 15 | | Record of ('a * 'a t) list 16 | | Range of char * char 17 | 18 | (* apply `f` on reference names, apply `g` on binding names *) 19 | let rec apply_on_names f g p = 20 | let apply = apply_on_names f g in 21 | match p with 22 | | Var bind -> Var (g bind NS.Var) 23 | | Wildcard -> Wildcard 24 | | Int i -> Int i 25 | | String s -> String s 26 | | Nil -> Nil 27 | | Range (f, t) -> Range (f, t) 28 | | Tuple l -> Tuple (List.map apply l) 29 | | Array l -> Array (List.map apply l) 30 | | Ctor (name, None) -> Ctor (f name NS.Ctor, None) 31 | | Ctor (name, Some v) -> 32 | let name = f name NS.Ctor in 33 | let v = apply v in 34 | Ctor (name, Some v) 35 | | Or (a, b) -> 36 | let a = apply a in 37 | let b = apply b in 38 | Or (a, b) 39 | | Cons (a, b) -> 40 | let a = apply a in 41 | let b = apply b in 42 | Cons (a, b) 43 | | Record l -> 44 | let aux (name, p) = f name NS.Field, apply p in 45 | Record (List.map aux l) 46 | ;; 47 | 48 | let rec string_of_pattern f = function 49 | | Var x -> x 50 | | Wildcard -> "_" 51 | | Int x -> string_of_int x 52 | | String s -> Printf.sprintf "\"%s\"" s 53 | | Tuple values -> 54 | List.map (string_of_pattern f) values |> String.concat ", " |> Printf.sprintf "(%s)" 55 | | Array values -> 56 | List.map (string_of_pattern f) values 57 | |> String.concat ", " 58 | |> Printf.sprintf "[|%s|]" 59 | | Ctor (name, rhs) -> 60 | (match rhs with 61 | | Some rhs -> Printf.sprintf "%s (%s)" (f name) (string_of_pattern f rhs) 62 | | None -> f name) 63 | | Or (a, b) -> 64 | Printf.sprintf "(%s) | (%s)" (string_of_pattern f a) (string_of_pattern f b) 65 | | Cons (a, b) -> 66 | Printf.sprintf "(%s) :: (%s)" (string_of_pattern f a) (string_of_pattern f b) 67 | | Nil -> "[]" 68 | | Record fields -> 69 | let aux (name, expr) = 70 | Printf.sprintf "%s = (%s)" (f name) (string_of_pattern f expr) 71 | in 72 | List.map aux fields |> String.concat "; " |> Printf.sprintf "{%s}" 73 | | Range (from, to_) -> Printf.sprintf "'%c' .. '%c'" from to_ 74 | ;; 75 | 76 | let rec introduced_idents = function 77 | | Var x -> SS.singleton x 78 | | Wildcard -> SS.empty 79 | | Int _ | String _ -> SS.empty 80 | | Array values | Tuple values -> 81 | List.map introduced_idents values |> List.fold_left SS.union SS.empty 82 | | Ctor (_, value) -> 83 | (match value with Some value -> introduced_idents value | None -> SS.empty) 84 | | Or (a, b) -> SS.union (introduced_idents a) (introduced_idents b) 85 | | Cons (a, b) -> SS.union (introduced_idents a) (introduced_idents b) 86 | | Nil | Range _ -> SS.empty 87 | | Record fields -> 88 | let aux (_, p) = introduced_idents p in 89 | List.map aux fields |> List.fold_left SS.union SS.empty 90 | ;; 91 | 92 | let introduced_ident_list p = introduced_idents p |> SS.elements 93 | -------------------------------------------------------------------------------- /stdlib/list.ml: -------------------------------------------------------------------------------- 1 | let rec length = function [] -> 0 | _ :: t -> 1 + length t 2 | let cons h t = h :: t 3 | let hd = function h :: _ -> h | [] -> failwith "hd" 4 | let tl = function _ :: t -> t | [] -> failwith "tl" 5 | 6 | let rec nth_opt l i = 7 | match l, i with h :: _, 0 -> Some h | _ :: t, i -> nth_opt t (i - 1) | _ -> None 8 | ;; 9 | 10 | let nth l i = match nth_opt l i with Some v -> v | None -> failwith "nth" 11 | let rec rev_append a b = match a with [] -> b | h :: t -> rev_append t (h :: b) 12 | let rev l = rev_append l [] 13 | let append a b = a @ b 14 | let rec concat = function [] -> [] | h :: t -> h @ concat t 15 | let flatten = concat 16 | 17 | let rec iter f = function 18 | | [] -> () 19 | | h :: t -> 20 | f h; 21 | iter f t 22 | ;; 23 | 24 | let iteri f = 25 | let rec aux i = function 26 | | [] -> () 27 | | h :: t -> 28 | f i h; 29 | aux (i + 1) t 30 | in 31 | aux 0 32 | ;; 33 | 34 | let rec map f = function [] -> [] | h :: t -> f h :: map f t 35 | 36 | let mapi f = 37 | let rec aux i = function [] -> [] | h :: t -> f i h :: aux (i + 1) t in 38 | aux 0 39 | ;; 40 | 41 | let rev_map f l = 42 | let rec aux acc = function [] -> acc | h :: t -> aux (f h :: acc) t in 43 | aux [] l 44 | ;; 45 | 46 | let rec fold_left f acc = function [] -> acc | h :: t -> fold_left f (f acc h) t 47 | 48 | let rec fold_right f l acc = 49 | match l with [] -> acc | h :: t -> f h (fold_right f t acc) 50 | ;; 51 | 52 | let rec mem x = function [] -> false | h :: _ when h = x -> true | _ :: t -> mem x t 53 | 54 | let rec find_opt f = function 55 | | [] -> None 56 | | h :: _ when f h -> Some h 57 | | _ :: t -> find_opt f t 58 | ;; 59 | 60 | let find f l = match find_opt f l with Some v -> v | None -> failwith "NotFound" 61 | 62 | let rec filter f = function 63 | | [] -> [] 64 | | h :: t when f h -> h :: filter f t 65 | | _ :: t -> filter f t 66 | ;; 67 | 68 | let rec partition f = function 69 | | [] -> [], [] 70 | | h :: t -> 71 | let a, b = partition f t in 72 | if f h then h :: a, b else a, h :: b 73 | ;; 74 | 75 | let rec split = function 76 | | [] -> [], [] 77 | | (a, b) :: t -> 78 | let a_l, b_l = split t in 79 | a :: a_l, b :: b_l 80 | ;; 81 | 82 | let rec iter2 f l1 l2 = 83 | match l1, l2 with 84 | | [], [] -> () 85 | | h1 :: t1, h2 :: t2 -> 86 | f h1 h2; 87 | iter2 f t1 t2 88 | | _, _ -> failwith "List.iter2" 89 | ;; 90 | 91 | (* quick sort *) 92 | let rec sort pred = function 93 | | [] -> [] 94 | | h :: t -> 95 | let is_smaller x = pred h x >= 0 in 96 | let is_greater x = not (is_smaller x) in 97 | let smaller = sort pred @@ filter is_smaller t in 98 | let greater = sort pred @@ filter is_greater t in 99 | smaller @ [h] @ greater 100 | ;; 101 | 102 | let assoc_opt a l = 103 | let f (k, _) = k = a in 104 | match find_opt f l with Some (_, v) -> Some v | None -> None 105 | ;; 106 | 107 | let assoc a l = match assoc_opt a l with Some v -> v | None -> failwith "NotFound" 108 | let mem_assoc a l = match assoc_opt a l with Some _ -> true | None -> false 109 | 110 | let rec remove_assoc k = function 111 | | [] -> [] 112 | | (a, b) :: t -> if a = k then t else (a, b) :: remove_assoc k t 113 | ;; 114 | -------------------------------------------------------------------------------- /mlml/bundler/build_tree.ml: -------------------------------------------------------------------------------- 1 | module Mod = Tree.Module 2 | module Path = Tree.Path 3 | module ModCache = Modules_cache 4 | module SS = Tree.Simple_set 5 | module DepTree = Dependency_tree 6 | module FindDeps = Find_dependencies 7 | 8 | let stdlib_dir = 9 | match Sys.getenv_opt "MLML_STDLIB_DIR" with Some d -> d | None -> "../../../stdlib" 10 | ;; 11 | 12 | let preprocess name is_stdlib tree = 13 | let form_open name = Mod.Definition (Mod.Open (Path.single name)) in 14 | let tree = 15 | match name with 16 | | "Pervasives" -> tree 17 | | "Pervasives2" -> form_open "Pervasives" :: tree 18 | | _ when is_stdlib -> form_open "Pervasives" :: tree 19 | | _ -> form_open "Pervasives" :: form_open "Pervasives2" :: tree 20 | in 21 | let name = String.capitalize_ascii name in 22 | [Mod.Definition (Mod.Module (name, Mod.Struct tree))] 23 | ;; 24 | 25 | type module_location = 26 | | Single of string 27 | | Submodule of string 28 | | Stdlib of string 29 | 30 | let find_module_opt projs dir name = 31 | let name = String.uncapitalize_ascii name in 32 | let std_filename = Printf.sprintf "%s/%s.ml" stdlib_dir name in 33 | let local_filename = Printf.sprintf "%s/%s.ml" dir name in 34 | (* find registered dune modules first *) 35 | let f x = Filename.basename x = name in 36 | match List.find_opt f projs with 37 | | Some path -> Some (Submodule path) 38 | | None -> 39 | (match Sys.file_exists local_filename, Sys.file_exists std_filename with 40 | | true, _ when dir <> stdlib_dir -> Some (Single local_filename) 41 | | _, true -> Some (Stdlib std_filename) 42 | | _ -> None) 43 | ;; 44 | 45 | let check_stdlib = function Stdlib _ -> true | _ -> false 46 | 47 | let find_module projs dir name = 48 | match find_module_opt projs dir name with 49 | | Some loc -> loc 50 | | None -> failwith @@ Printf.sprintf "could not find module named %s" name 51 | ;; 52 | 53 | let filename_to_module path = 54 | let file = Filename.basename path in 55 | let name = Filename.chop_suffix file ".ml" in 56 | String.capitalize_ascii name 57 | ;; 58 | 59 | let rec build_submodule_tree cache projs path = 60 | let name = Filename.basename path in 61 | let entry_path = Filename.concat path name ^ ".ml" in 62 | match Sys.file_exists entry_path with 63 | | true -> DepTree.Node (entry_path, build_tree cache projs name false entry_path) 64 | | false -> 65 | let is_module_file x = Filename.check_suffix x ".ml" in 66 | let build path = 67 | let name = filename_to_module path in 68 | DepTree.Node (path, build_tree cache projs name false path) 69 | in 70 | let l = 71 | Sys.readdir path 72 | |> Array.to_list 73 | |> List.filter is_module_file 74 | |> List.map (Filename.concat path) 75 | |> List.map build 76 | in 77 | DepTree.Submodule (name, l) 78 | 79 | and build_tree cache projs name is_stdlib file = 80 | (* run preprocess in first load *) 81 | ModCache.load_with (preprocess name is_stdlib) cache file 82 | |> FindDeps.f 83 | |> SS.elements 84 | |> List.map (build_tree_node cache projs @@ Filename.dirname file) 85 | 86 | and build_tree_node cache projs dir name = 87 | let loc = find_module projs dir name in 88 | match loc with 89 | | Single file | Stdlib file -> 90 | DepTree.Node (file, build_tree cache projs name (check_stdlib loc) file) 91 | | Submodule path -> build_submodule_tree cache projs path 92 | ;; 93 | 94 | let build_tree_root cache projs file = 95 | let name = Printf.sprintf "//%s//" file in 96 | DepTree.Node (file, build_tree cache projs name false file) 97 | ;; 98 | -------------------------------------------------------------------------------- /mlml/parser/pattern.ml: -------------------------------------------------------------------------------- 1 | module L = Lexer 2 | module T = Tree.Pattern 3 | 4 | type t = Tree.Path.t T.t 5 | 6 | let string_of_pattern = T.string_of_pattern Tree.Path.string_of_path 7 | 8 | let rec parse_fields tokens = 9 | let continue path expr = function 10 | | L.Semicolon :: rest -> 11 | let rest, acc = parse_fields rest in 12 | rest, (path, expr) :: acc 13 | | rest -> rest, [path, expr] 14 | in 15 | match Path.try_parse_path tokens with 16 | | L.Equal :: rest, Some path -> 17 | let rest, expr = parse_pattern rest in 18 | continue path expr rest 19 | | rest, None -> rest, [] 20 | | rest, Some path -> continue path (T.Var (Tree.Path.last path)) rest 21 | 22 | and try_parse_literal tokens = 23 | match tokens with 24 | | L.IntLiteral num :: tokens -> tokens, Some (T.Int num) 25 | (* TODO: Add boolean value *) 26 | | L.BoolLiteral b :: tokens -> tokens, Some (T.Int (if b then 1 else 0)) 27 | (* TODO: Add char value *) 28 | | L.CharLiteral from :: L.DoubleDot :: L.CharLiteral to_ :: tokens -> 29 | tokens, Some (T.Range (from, to_)) 30 | | L.CharLiteral c :: tokens -> tokens, Some (T.Int (Char.code c)) 31 | | L.StringLiteral s :: tokens -> tokens, Some (T.String s) 32 | | L.LowerIdent "_" :: tokens -> tokens, Some T.Wildcard 33 | | L.LowerIdent ident :: tokens -> tokens, Some (T.Var ident) 34 | | L.LParen :: L.InfixSymbol sym :: L.RParen :: tokens -> tokens, Some (T.Var sym) 35 | | L.CapitalIdent _ :: _ -> 36 | (match Path.try_parse_path tokens with 37 | | rest, None -> rest, None 38 | | rest, Some path -> 39 | (match try_parse_literal rest with 40 | | rest, Some p -> rest, Some (T.Ctor (path, Some p)) 41 | | _, None -> rest, Some (T.Ctor (path, None)))) 42 | | L.LBrace :: rest -> 43 | let rest, fields = parse_fields rest in 44 | (match rest with 45 | | L.RBrace :: rest -> rest, Some (T.Record fields) 46 | | _ -> failwith "record definition is not terminated") 47 | | L.LArray :: rest -> 48 | let rec aux = function 49 | | L.RArray :: rest -> rest, [] 50 | | L.Semicolon :: rest -> aux rest 51 | | tokens -> 52 | let rest, v = parse_pattern tokens in 53 | let rest, acc = aux rest in 54 | rest, v :: acc 55 | in 56 | let rest, l = aux rest in 57 | rest, Some (T.Array l) 58 | | L.LBracket :: rest -> 59 | let rec aux = function 60 | | L.RBracket :: rest -> rest, T.Nil 61 | | L.Semicolon :: rest -> aux rest 62 | | tokens -> 63 | let rest, lhs = parse_pattern tokens in 64 | let rest, rhs = aux rest in 65 | rest, T.Cons (lhs, rhs) 66 | in 67 | let rest, l = aux rest in 68 | rest, Some l 69 | | L.LParen :: L.RParen :: tokens -> tokens, Some (T.Tuple []) 70 | | L.LParen :: tokens -> 71 | let rest, v = parse_pattern tokens in 72 | (match rest with L.RParen :: rest -> rest, Some v | _ -> rest, None) 73 | | _ -> tokens, None 74 | 75 | and parse_literal tokens = 76 | match try_parse_literal tokens with 77 | | tokens, Some v -> tokens, v 78 | | h :: _, None -> 79 | failwith @@ Printf.sprintf "unexpected token: '%s'" (L.string_of_token h) 80 | | [], None -> failwith "Empty input" 81 | 82 | and parse_cons tokens = 83 | let tokens, lhs = parse_literal tokens in 84 | match tokens with 85 | | L.DoubleColon :: tokens -> 86 | let tokens, rhs = parse_cons tokens in 87 | tokens, T.Cons (lhs, rhs) 88 | | _ -> tokens, lhs 89 | 90 | and parse_tuple tokens = 91 | let rec aux tokens = 92 | let rest, curr = parse_cons tokens in 93 | match rest with 94 | | L.Comma :: rest -> 95 | let rest, tail = aux rest in 96 | rest, curr :: tail 97 | | _ -> rest, [curr] 98 | in 99 | let rest, values = aux tokens in 100 | match values with 101 | | [] -> failwith "unreachable" 102 | | [value] -> rest, value 103 | | _ -> rest, T.Tuple values 104 | 105 | and parse_or tokens = 106 | let tokens, lhs = parse_tuple tokens in 107 | let rec aux lhs tokens = 108 | match tokens with 109 | | L.Vertical :: rest -> 110 | let rest, rhs = parse_tuple rest in 111 | aux (T.Or (lhs, rhs)) rest 112 | | _ -> tokens, lhs 113 | in 114 | aux lhs tokens 115 | 116 | and parse_pattern tokens = parse_or tokens 117 | -------------------------------------------------------------------------------- /mlml/analysis/format_string.ml: -------------------------------------------------------------------------------- 1 | module Path = Tree.Path 2 | module Expr = Tree.Expression 3 | module Mod = Tree.Module 4 | module Pat = Tree.Pattern 5 | module Fmt = Tree.Format_string 6 | module Binop = Tree.Binop 7 | 8 | let fmt_int_function = Path.path_of_string "MlmlInternalFormat.fmt_int" 9 | let fmt_string_function = Path.path_of_string "MlmlInternalFormat.fmt_string" 10 | let fmt_char_function = Path.path_of_string "MlmlInternalFormat.fmt_char" 11 | 12 | let convert_format_string fmt = 13 | let join a_opt b = 14 | match a_opt with 15 | | Some a -> Some (Expr.BinOp (Binop.Custom (Path.single "^"), a, b)) 16 | | None -> Some b 17 | in 18 | let call_path path b = Expr.App (Expr.Var path, Expr.Var (Path.single b)) in 19 | let gen = Printf.sprintf "%s%d" in 20 | (* `f_acc` is a reverse-ordered list of function parameters *) 21 | (* `s_acc` is a body of format string *) 22 | let rec aux f_acc s_acc = function 23 | | Fmt.Const s :: rest -> 24 | let s = Expr.String s in 25 | aux f_acc (join s_acc s) rest 26 | | Fmt.Int :: rest -> 27 | let v = gen "d" (List.length f_acc) in 28 | let s = call_path fmt_int_function v in 29 | aux (v :: f_acc) (join s_acc s) rest 30 | | Fmt.Char :: rest -> 31 | let v = gen "c" (List.length f_acc) in 32 | let s = call_path fmt_char_function v in 33 | aux (v :: f_acc) (join s_acc s) rest 34 | | Fmt.String :: rest -> 35 | let v = gen "s" (List.length f_acc) in 36 | let s = call_path fmt_string_function v in 37 | aux (v :: f_acc) (join s_acc s) rest 38 | | [] -> f_acc, s_acc 39 | in 40 | let f_acc, s_acc = aux [] None fmt in 41 | let s_acc = match s_acc with Some s -> s | None -> failwith "empty format string" in 42 | let s_body = Expr.App (Expr.Var (Path.single "k"), s_acc) in 43 | let folder acc name = Expr.Lambda (Pat.Var name, acc) in 44 | let body = List.fold_left folder s_body f_acc in 45 | Expr.Lambda (Pat.Var "k", body) 46 | ;; 47 | 48 | let rec convert_let_bindings l = 49 | let aux = function 50 | | Expr.VarBind (p, e) -> Expr.VarBind (p, convert_expr e) 51 | | Expr.FunBind (name, p, e) -> Expr.FunBind (name, p, convert_expr e) 52 | in 53 | List.map aux l 54 | 55 | and convert_expr e = 56 | match e with 57 | | Expr.Format l -> convert_format_string l 58 | | Expr.LetAnd (is_rec, l, in_) -> 59 | let l = convert_let_bindings l in 60 | let in_ = convert_expr in_ in 61 | Expr.LetAnd (is_rec, l, in_) 62 | | Expr.Lambda (p, body) -> 63 | let body = convert_expr body in 64 | Expr.Lambda (p, body) 65 | | Expr.Match (expr, l) -> 66 | let aux (p, when_, arm) = 67 | let when_ = 68 | match when_ with Some when_ -> Some (convert_expr when_) | None -> None 69 | in 70 | let arm = convert_expr arm in 71 | p, when_, arm 72 | in 73 | let expr = convert_expr expr in 74 | let l = List.map aux l in 75 | Expr.Match (expr, l) 76 | | Expr.String _ | Expr.Var _ | Expr.Nil | Expr.Int _ -> e 77 | | Expr.Tuple l -> Expr.Tuple (List.map convert_expr l) 78 | | Expr.Array l -> Expr.Array (List.map convert_expr l) 79 | | Expr.BinOp (op, l, r) -> Expr.BinOp (op, convert_expr l, convert_expr r) 80 | | Expr.UnaryOp (op, e) -> Expr.UnaryOp (op, convert_expr e) 81 | | Expr.IfThenElse (cond, then_, else_) -> 82 | Expr.IfThenElse (convert_expr cond, convert_expr then_, convert_expr else_) 83 | | Expr.App (l, r) -> Expr.App (convert_expr l, convert_expr r) 84 | | Expr.Ctor (_name, None) -> e 85 | | Expr.Ctor (name, Some param) -> Expr.Ctor (name, Some (convert_expr param)) 86 | | Expr.Record fields -> 87 | let aux' (name, expr) = name, convert_expr expr in 88 | Expr.Record (List.map aux' fields) 89 | | Expr.RecordField (v, field) -> Expr.RecordField (convert_expr v, field) 90 | | Expr.RecordFieldAssign (v, field, e) -> 91 | Expr.RecordFieldAssign (convert_expr v, field, convert_expr e) 92 | | Expr.RecordUpdate (e, fields) -> 93 | let aux' (name, expr) = name, convert_expr expr in 94 | Expr.RecordUpdate (convert_expr e, List.map aux' fields) 95 | | Expr.ArrayAssign (ary, idx, v) -> 96 | Expr.ArrayAssign (convert_expr ary, convert_expr idx, convert_expr v) 97 | ;; 98 | 99 | let rec convert_defn defn = 100 | match defn with 101 | | Mod.LetAnd (is_rec, l) -> 102 | let l = convert_let_bindings l in 103 | Mod.LetAnd (is_rec, l) 104 | | Mod.TypeDef _ -> defn 105 | | Mod.Module (_name, Mod.Path _) -> defn 106 | | Mod.Module (name, Mod.Struct l) -> 107 | Mod.Module (name, Mod.Struct (convert_module_items l)) 108 | | Mod.External _ | Mod.Open _ -> defn 109 | 110 | and convert_module_item = function 111 | | Mod.Expression expr -> Mod.Expression (convert_expr expr) 112 | | Mod.Definition defn -> Mod.Definition (convert_defn defn) 113 | 114 | and convert_module_items l = List.map convert_module_item l 115 | 116 | let f = convert_module_items 117 | -------------------------------------------------------------------------------- /mlml/parser/module.ml: -------------------------------------------------------------------------------- 1 | (* Parse the definition. *) 2 | (* https://caml.inria.fr/pub/docs/manual-ocaml/modules.html#definition *) 3 | 4 | module L = Lexer 5 | module T = Tree.Module 6 | module Expr = Expression 7 | module TyExpr = Type_expression 8 | 9 | type module_item = Tree.Path.t T.module_item 10 | 11 | let string_of_module_items = T.string_of_module_items Tree.Path.string_of_path 12 | 13 | let parse_variant tokens = 14 | let rec aux = function 15 | | L.CapitalIdent name :: L.Of :: rest -> 16 | let rest, ty_expr = TyExpr.parse_type_expression rest in 17 | (match rest with 18 | | L.Vertical :: rest -> 19 | let rest, acc = aux rest in 20 | rest, (name, Some ty_expr) :: acc 21 | | _ -> rest, [name, Some ty_expr]) 22 | | L.CapitalIdent name :: L.Vertical :: rest -> 23 | let rest, acc = aux rest in 24 | rest, (name, None) :: acc 25 | | L.CapitalIdent name :: rest -> rest, [name, None] 26 | | rest -> rest, [] 27 | in 28 | let rest, ctors = match tokens with L.Vertical :: rest | rest -> aux rest in 29 | rest, T.Variant ctors 30 | ;; 31 | 32 | let parse_record tokens = 33 | let rec aux tokens = 34 | let is_mut, tokens = 35 | match tokens with L.Mutable :: rest -> true, rest | _ -> false, tokens 36 | in 37 | match tokens with 38 | | L.LowerIdent name :: L.Colon :: rest -> 39 | let rest, ty_expr = TyExpr.parse_type_expression rest in 40 | (match rest with 41 | | L.Semicolon :: rest -> 42 | let rest, acc = aux rest in 43 | rest, (is_mut, name, ty_expr) :: acc 44 | | _ -> rest, [is_mut, name, ty_expr]) 45 | | rest -> rest, [] 46 | in 47 | let rest, fields = match tokens with L.LBrace :: rest | rest -> aux rest in 48 | match rest with 49 | | L.RBrace :: rest -> rest, T.Record fields 50 | | _ -> failwith "record definition is not terminated" 51 | ;; 52 | 53 | let parse_type_params tokens = 54 | let rec aux = function 55 | | L.Apostrophe :: L.LowerIdent ident :: L.Comma :: rest -> 56 | let rest, params = aux rest in 57 | rest, ident :: params 58 | | L.Apostrophe :: L.LowerIdent ident :: L.RParen :: rest -> rest, [ident] 59 | | _ -> failwith "could not parse type params" 60 | in 61 | match tokens with 62 | | L.Apostrophe :: L.LowerIdent ident :: rest -> rest, [ident] 63 | | L.LParen :: rest -> aux rest 64 | | _ -> tokens, [] 65 | ;; 66 | 67 | let rec try_parse_type_bindings tokens = 68 | let rest, params = parse_type_params tokens in 69 | match rest with 70 | | L.LowerIdent ident :: L.Equal :: rest -> 71 | let rest, def = 72 | match rest with 73 | | L.LBrace :: _ -> parse_record rest 74 | (* TODO: distinguish variant and alias by checking the ability to be parsed as type 75 | expression *) 76 | | L.Vertical :: _ 77 | | L.CapitalIdent _ :: L.Vertical :: _ 78 | | L.CapitalIdent _ :: L.Of :: _ -> parse_variant rest 79 | | _ -> 80 | let rest, ty = TyExpr.parse_type_expression rest in 81 | rest, T.Alias ty 82 | in 83 | (match rest with 84 | | L.And :: rest -> 85 | (match try_parse_type_bindings rest with 86 | | rest, Some l -> rest, Some ((params, ident, def) :: l) 87 | | _, None -> failwith "could not parse a binding after `and`") 88 | | _ -> rest, Some [params, ident, def]) 89 | | tokens -> tokens, None 90 | ;; 91 | 92 | let rec try_parse_let tokens = 93 | match tokens with 94 | | L.Type :: rest -> 95 | (match try_parse_type_bindings rest with 96 | | rest, Some l -> rest, Some (T.TypeDef l) 97 | | rest, None -> rest, None) 98 | | L.Module :: L.CapitalIdent ident :: L.Equal :: rest -> 99 | let rest, expr = parse_module_expression rest in 100 | rest, Some (T.Module (ident, expr)) 101 | | L.Open :: rest -> 102 | let rest, path = Path.parse_path rest in 103 | rest, Some (T.Open path) 104 | | L.External :: L.LowerIdent name :: L.Colon :: rest 105 | | L.External :: L.LParen :: L.InfixSymbol name :: L.RParen :: L.Colon :: rest -> 106 | let rest, tyexpr = TyExpr.parse_type_expression rest in 107 | (match rest with 108 | | L.Equal :: L.StringLiteral s :: rest -> rest, Some (T.External (name, tyexpr, s)) 109 | | _ -> failwith "syntax error") 110 | | L.Let :: rest -> 111 | let rest, is_rec = Expr.parse_rec rest in 112 | let rest, binds = Expr.parse_let_bindings rest in 113 | (match rest with 114 | | L.In :: _ -> tokens, None 115 | | _ -> rest, Some (T.LetAnd (is_rec, binds))) 116 | | tokens -> tokens, None 117 | 118 | and try_parse_definition x = try_parse_let x 119 | 120 | and parse_definition tokens = 121 | match try_parse_definition tokens with 122 | | rest, Some def -> rest, def 123 | | h :: _, None -> 124 | failwith @@ Printf.sprintf "unexpected token: '%s'" (L.string_of_token h) 125 | | [], None -> failwith "Empty input" 126 | 127 | and parse_module_items = function 128 | | L.DoubleSemicolon :: rest -> parse_module_items rest 129 | | [] -> [], [] 130 | | L.End :: rest -> rest, [] 131 | | tokens -> 132 | let rest, def_opt = try_parse_definition tokens in 133 | (match def_opt with 134 | | Some def -> 135 | let rest, items = parse_module_items rest in 136 | rest, T.Definition def :: items 137 | | None -> 138 | (* may fail in parse_expression (OK because there's no other candidate) *) 139 | let rest, expr = Expr.parse_expression rest in 140 | let rest, items = parse_module_items rest in 141 | rest, T.Expression expr :: items) 142 | 143 | and parse_module_expression = function 144 | | L.Struct :: rest -> 145 | let rest, l = parse_module_items rest in 146 | rest, T.Struct l 147 | | tokens -> 148 | let rest, path = Path.parse_path tokens in 149 | rest, T.Path path 150 | ;; 151 | 152 | let f = parse_definition 153 | -------------------------------------------------------------------------------- /mlml/analysis/alpha.ml: -------------------------------------------------------------------------------- 1 | module Pat = Tree.Pattern 2 | module Mod = Tree.Module 3 | module Expr = Tree.Expression 4 | module Binop = Tree.Binop 5 | 6 | let make_name = Printf.sprintf "%s%d" 7 | 8 | let rename env s = 9 | let idx = 10 | match Hashtbl.find_opt env s with 11 | | Some c -> 12 | let next = c + 1 in 13 | Hashtbl.replace env s next; 14 | next 15 | | None -> 16 | Hashtbl.add env s 0; 17 | 0 18 | in 19 | make_name s idx 20 | ;; 21 | 22 | let find env s = 23 | match Hashtbl.find_opt env s with 24 | | Some idx -> make_name s idx 25 | (* keep the unbound name (for external ones) *) 26 | (* TODO: Remove this bahavior in support of `external` *) 27 | | None -> s 28 | ;; 29 | 30 | let copy_env env = Hashtbl.copy env 31 | 32 | let rec replace_pattern env p = 33 | match p with 34 | | Pat.Var name -> Pat.Var (rename env name) 35 | | Pat.Wildcard | Pat.Int _ | Pat.String _ | Pat.Nil | Pat.Range _ -> p 36 | | Pat.Tuple l -> 37 | let l = List.map (replace_pattern env) l in 38 | Pat.Tuple l 39 | | Pat.Array l -> 40 | let l = List.map (replace_pattern env) l in 41 | Pat.Array l 42 | | Pat.Ctor (_name, None) -> p 43 | | Pat.Ctor (name, Some param) -> 44 | let param = replace_pattern env param in 45 | Pat.Ctor (name, Some param) 46 | | Pat.Or (a, b) -> 47 | (* `a` and `b` should introduce the same names *) 48 | (* So we can ignore the introductions from a and use b's ones *) 49 | let dummy_env = copy_env env in 50 | let a = replace_pattern dummy_env a in 51 | let b = replace_pattern env b in 52 | Pat.Or (a, b) 53 | | Pat.Cons (a, b) -> 54 | let a = replace_pattern env a in 55 | let b = replace_pattern env b in 56 | Pat.Cons (a, b) 57 | | Pat.Record l -> 58 | let aux (field, pat) = 59 | let pat = replace_pattern env pat in 60 | field, pat 61 | in 62 | let l = List.map aux l in 63 | Pat.Record l 64 | ;; 65 | 66 | let replace_intros env = 67 | let aux = function 68 | | Expr.VarBind (p, body) -> 69 | let p = replace_pattern env p in 70 | Expr.VarBind (p, body) 71 | | Expr.FunBind (name, p, body) -> 72 | let name = rename env name in 73 | Expr.FunBind (name, p, body) 74 | in 75 | List.map aux 76 | ;; 77 | 78 | let rec convert_let_binding env = function 79 | | Expr.VarBind (p, body) -> 80 | let body = convert_expr env body in 81 | Expr.VarBind (p, body) 82 | | Expr.FunBind (name, p, body) -> 83 | let inner_env = copy_env env in 84 | let p = replace_pattern inner_env p in 85 | let body = convert_expr inner_env body in 86 | Expr.FunBind (name, p, body) 87 | 88 | and convert_let_bindings env is_rec l = 89 | match is_rec with 90 | | true -> 91 | let l = replace_intros env l in 92 | List.map (convert_let_binding env) l 93 | | false -> 94 | let l = List.map (convert_let_binding env) l in 95 | replace_intros env l 96 | 97 | and convert_expr env e = 98 | match e with 99 | | Expr.LetAnd (is_rec, l, in_) -> 100 | let new_env = copy_env env in 101 | let l = convert_let_bindings new_env is_rec l in 102 | let in_ = convert_expr new_env in_ in 103 | Expr.LetAnd (is_rec, l, in_) 104 | | Expr.Var name -> Expr.Var (find env name) 105 | | Expr.Lambda (p, body) -> 106 | let new_env = copy_env env in 107 | let p = replace_pattern new_env p in 108 | let body = convert_expr new_env body in 109 | Expr.Lambda (p, body) 110 | | Expr.Match (expr, l) -> 111 | let aux (p, when_, arm) = 112 | let new_env = copy_env env in 113 | let p = replace_pattern new_env p in 114 | let when_ = 115 | match when_ with Some when_ -> Some (convert_expr new_env when_) | None -> None 116 | in 117 | let arm = convert_expr new_env arm in 118 | p, when_, arm 119 | in 120 | let expr = convert_expr env expr in 121 | let l = List.map aux l in 122 | Expr.Match (expr, l) 123 | | Expr.Nil | Expr.Int _ | Expr.String _ | Expr.Format _ -> e 124 | | Expr.Tuple l -> Expr.Tuple (List.map (convert_expr env) l) 125 | | Expr.Array l -> Expr.Array (List.map (convert_expr env) l) 126 | | Expr.BinOp (op, l, r) -> 127 | let op = match op with Binop.Custom sym -> Binop.Custom (find env sym) | _ -> op in 128 | Expr.BinOp (op, convert_expr env l, convert_expr env r) 129 | | Expr.UnaryOp (op, e) -> Expr.UnaryOp (op, convert_expr env e) 130 | | Expr.IfThenElse (cond, then_, else_) -> 131 | Expr.IfThenElse 132 | (convert_expr env cond, convert_expr env then_, convert_expr env else_) 133 | | Expr.App (l, r) -> Expr.App (convert_expr env l, convert_expr env r) 134 | | Expr.Ctor (_name, None) -> e 135 | | Expr.Ctor (name, Some param) -> Expr.Ctor (name, Some (convert_expr env param)) 136 | | Expr.Record fields -> 137 | let aux' (name, expr) = name, convert_expr env expr in 138 | Expr.Record (List.map aux' fields) 139 | | Expr.RecordField (v, field) -> Expr.RecordField (convert_expr env v, field) 140 | | Expr.RecordFieldAssign (v, field, e) -> 141 | let v = convert_expr env v in 142 | let e = convert_expr env e in 143 | Expr.RecordFieldAssign (v, field, e) 144 | | Expr.RecordUpdate (e, fields) -> 145 | let aux' (name, expr) = name, convert_expr env expr in 146 | Expr.RecordUpdate (convert_expr env e, List.map aux' fields) 147 | | Expr.ArrayAssign (ary, idx, v) -> 148 | Expr.ArrayAssign (convert_expr env ary, convert_expr env idx, convert_expr env v) 149 | ;; 150 | 151 | let convert_defn env defn = 152 | match defn with 153 | | Mod.LetAnd (is_rec, l) -> 154 | let l = convert_let_bindings env is_rec l in 155 | Mod.LetAnd (is_rec, l) 156 | | Mod.TypeDef _ -> defn 157 | | Mod.Module _ -> defn 158 | | Mod.Open _ -> defn 159 | | Mod.External (name, ty, decl) -> 160 | let name = rename env name in 161 | Mod.External (name, ty, decl) 162 | ;; 163 | 164 | let convert_module_item env = function 165 | | Mod.Expression expr -> Mod.Expression (convert_expr env expr) 166 | | Mod.Definition defn -> Mod.Definition (convert_defn env defn) 167 | ;; 168 | 169 | let f = List.map (convert_module_item @@ Hashtbl.create 32) 170 | -------------------------------------------------------------------------------- /test/stdlib_.ml: -------------------------------------------------------------------------------- 1 | let () = 2 | (* Char *) 3 | Tester.f 4 | {| 5 | let test c = 6 | print_char @@ Char.uppercase_ascii c; 7 | print_char @@ Char.lowercase_ascii c; 8 | print_string @@ Char.escaped c; 9 | print_int @@ Char.code c 10 | ;; 11 | 12 | test 'a'; 13 | test 'x'; 14 | test 'C'; 15 | test 'Y'; 16 | test '\n'; 17 | test '\t' 18 | |}; 19 | (* Hashtbl *) 20 | Tester.f 21 | {| 22 | let t = Hashtbl.create 32 in 23 | Hashtbl.add t "hello" "world"; 24 | Hashtbl.add t "fantastic" "ramen"; 25 | print_string @@ Hashtbl.find t "hello"; 26 | print_string @@ Hashtbl.find t "fantastic" 27 | |}; 28 | Tester.f 29 | {| 30 | let t = Hashtbl.create 32 in 31 | Hashtbl.add t "hello" "world"; 32 | Hashtbl.add t "hello" "guys"; 33 | print_string @@ Hashtbl.find t "hello"; 34 | Hashtbl.remove t "hello"; 35 | print_string @@ Hashtbl.find t "hello" 36 | |}; 37 | Tester.f 38 | {| 39 | let t = Hashtbl.create 32 in 40 | Hashtbl.add t "mlml" 1; 41 | Hashtbl.replace t "mlml" 2; 42 | print_int @@ Hashtbl.find t "mlml" 43 | |}; 44 | Tester.f 45 | {| 46 | let print_opt = function 47 | | Some v -> Printf.printf "Some %s\n" v 48 | | None -> print_string "None\n" 49 | ;; 50 | 51 | let t = Hashtbl.create 32 in 52 | print_opt @@ Hashtbl.find_opt t "mlml"; 53 | Hashtbl.add t "mlml" "oss"; 54 | print_opt @@ Hashtbl.find_opt t "mlml"; 55 | Hashtbl.remove t "mlml"; 56 | print_opt @@ Hashtbl.find_opt t "mlml" 57 | |}; 58 | Tester.f 59 | {| 60 | let t = Hashtbl.create 32 in 61 | Hashtbl.add t "hello" "world"; 62 | let t2 = Hashtbl.copy t in 63 | Hashtbl.replace t "hello" "yeah"; 64 | print_string @@ Hashtbl.find t2 "hello" 65 | |}; 66 | Tester.f 67 | {| 68 | let t = Hashtbl.create 32 in 69 | Hashtbl.add t "hello" "world"; 70 | Hashtbl.add t "hello" "guys"; 71 | Hashtbl.iter (Printf.printf "%s -> %s\n") t 72 | |}; 73 | Tester.f 74 | {| 75 | let t = Hashtbl.create 32 in 76 | Hashtbl.add t "hello" "world"; 77 | Hashtbl.add t "fantastic" "ramen"; 78 | Hashtbl.remove t "hello"; 79 | print_string @@ Hashtbl.find t "fantastic" 80 | |}; 81 | Tester.f 82 | {| 83 | let t = Hashtbl.create 32 in 84 | Hashtbl.add t "hello" "world"; 85 | Hashtbl.add t "fantastic" "ramen"; 86 | let f k v acc = (k ^ v) :: acc in 87 | let l = Hashtbl.fold f t [] in 88 | List.iter print_endline l 89 | |}; 90 | (* List *) 91 | Tester.f 92 | {| 93 | let add a b = a + b in 94 | let sum = List.fold_left add 0 in 95 | let test l = print_int @@ sum l in 96 | test [3; 4; 5; 6]; 97 | test [0; 2; 0]; 98 | test [1200; 123; 100] 99 | |}; 100 | Tester.f 101 | {| 102 | let f x acc = print_int x; x :: acc in 103 | let fold l = List.fold_right f l [] in 104 | let test l = List.iter print_int @@ fold l in 105 | test [3; 4; 5; 6]; 106 | test [0; 2; 0]; 107 | test [1200; 123; 100] 108 | |}; 109 | Tester.f 110 | {| 111 | let test l x = 112 | if List.mem x l 113 | then print_string "found\n" 114 | else print_string "notfound\n" 115 | in 116 | test [1; 2; 3] 0; 117 | test [2] 2; 118 | test [] 0; 119 | test [2; 3] 5 120 | |}; 121 | Tester.f 122 | {| 123 | let square x = x * x in 124 | let mul (a, b) = a * b in 125 | let test f l = List.iter print_int @@ List.map f l in 126 | test succ [2; 3; 1; 3]; 127 | test square [4; 12; 23; 0]; 128 | test mul [9, 6; 5, 6; 1, 2; 0, 3; 3, 4] 129 | |}; 130 | Tester.f 131 | {| 132 | let square x = x * x in 133 | let mul (a, b) = a * b in 134 | let test f l = List.iter print_int @@ List.rev_map f l in 135 | test succ [2; 3; 1; 3]; 136 | test square [4; 12; 23; 0]; 137 | test mul [9, 6; 5, 6; 1, 2; 0, 3; 3, 4] 138 | |}; 139 | Tester.f 140 | {| 141 | let f i x = i * x in 142 | let test l = List.iter print_int @@ List.mapi f l in 143 | test [143; 21; 34]; 144 | test [0; 6; 3; 2] 145 | |}; 146 | Tester.f 147 | {| 148 | let print = List.iteri (Printf.printf "%d -> %d, ") in 149 | print @@ List.sort compare [5; 2; 4; 6; 1; 6; 7; 12; 4; 2; 0] 150 | |}; 151 | Tester.f 152 | {| 153 | let cmp (a1, b1) (a2, b2) = compare (a1 * b1) (a2 * b2) in 154 | let print = List.iter (fun (a, b) -> Printf.printf "%d %d, " a b) in 155 | print @@ List.sort cmp [9, 6; 5, 6; 1, 2; 0, 3; 3, 4] 156 | |}; 157 | Tester.f 158 | {| 159 | let test a b = 160 | if (List.rev a @ b <> List.rev_append a b) 161 | then print_string "differs" 162 | in 163 | test [1; 2; 5; 3] [12; 3; 4]; 164 | test [2; 3] [1; 3; 2] 165 | |}; 166 | Tester.f 167 | {| 168 | let test f l = 169 | let a, b = List.partition f l in 170 | List.iter print_int (a @ [0] @ b) 171 | in 172 | test (fun x -> x > 3) [4; 2; 5; 12; 0; 2] 173 | |}; 174 | Tester.f 175 | {| 176 | let a, b = List.split [4, 2; 5, 12; 0, 2; 5, 1; 12, 4] in 177 | List.iter print_int a; 178 | List.iter print_int b 179 | |}; 180 | Tester.f 181 | {| 182 | let test l = List.flatten l |> List.iter print_int in 183 | test [[4; 2]; [5]; [12; 0; 2]]; 184 | test [[]; [2]; [0]; []; [1; 3]] 185 | |}; 186 | Tester.f 187 | {| 188 | let f = Printf.printf "%d, %s" in 189 | List.iter2 f [1; 2; 3] ["hi"; "hello"; "omg"] 190 | |}; 191 | (* String *) 192 | Tester.f 193 | {| 194 | let test s = 195 | let aux c = match c with 'a' .. 'z' | 'A' .. 'Z' | '_' | '.' -> c | _ -> '_' in 196 | print_string @@ String.map aux s 197 | in 198 | test "hello"; 199 | test "2ks43(as"; 200 | test "2\n3 as" 201 | |}; 202 | Tester.f 203 | {| 204 | print_string @@ String.uppercase_ascii "Hello World"; 205 | print_string @@ String.lowercase_ascii "iOS 10"; 206 | print_string @@ String.capitalize_ascii "hello"; 207 | print_string @@ String.uncapitalize_ascii "HELLO" 208 | |}; 209 | Tester.f 210 | {| 211 | let test s = print_string @@ String.escaped s in 212 | test "hehehe"; 213 | test "hello world\nthis is mlml"; 214 | test "mlml\t@\tOCaml"; 215 | test "\"hello, world\"" 216 | |}; 217 | Tester.f 218 | {| 219 | let test c = 220 | match String.index_opt "hello, world" c with 221 | | Some i -> print_int i 222 | | None -> print_string "none" 223 | in 224 | test ','; 225 | test 'e'; 226 | test 'h'; 227 | test 'd'; 228 | test 'o' 229 | |}; 230 | Tester.f 231 | {| 232 | let test c s = 233 | List.iter (Printf.printf "%s, ") @@ String.split_on_char c s 234 | in 235 | test ',' "hello,world,mlml"; 236 | test ' ' "happy new year"; 237 | test '.' "...this is mlml. mlml has stdlib." 238 | |}; 239 | Tester.f {| 240 | ["hello"; "world"; "mlml"] 241 | |> String.concat ", " 242 | |> print_endline 243 | |}; 244 | Tester.f {| 245 | print_endline @@ String.escaped "" 246 | |}; 247 | (* Unit operations *) 248 | Tester.f {| 249 | let f x = print_int x; x ;; 250 | let () = ignore @@ f 42 251 | |} 252 | ;; 253 | -------------------------------------------------------------------------------- /mlml/tree/expression.ml: -------------------------------------------------------------------------------- 1 | module Pat = Pattern 2 | module NS = Namespace 3 | module Fmt = Format_string 4 | 5 | type 'a let_binding = 6 | | VarBind of 'a Pat.t * 'a t 7 | | FunBind of string * 'a Pat.t * 'a t 8 | 9 | and 'a t = 10 | | Int of int 11 | | Tuple of 'a t list 12 | | String of string 13 | | Array of 'a t list 14 | | Format of Fmt.kind list 15 | | BinOp of 'a Binop.t * 'a t * 'a t 16 | | UnaryOp of Unaryop.t * 'a t 17 | | LetAnd of bool * 'a let_binding list * 'a t 18 | | IfThenElse of 'a t * 'a t * 'a t 19 | | App of 'a t * 'a t 20 | | Ctor of 'a * 'a t option 21 | | Var of 'a 22 | | Match of 'a t * ('a Pat.t * 'a t option * 'a t) list 23 | | Lambda of 'a Pat.t * 'a t 24 | | Nil 25 | | Record of ('a * 'a t) list 26 | | RecordField of 'a t * 'a 27 | | RecordFieldAssign of 'a t * 'a * 'a t 28 | | RecordUpdate of 'a t * ('a * 'a t) list 29 | | ArrayAssign of 'a t * 'a t * 'a t 30 | 31 | let is_fun_bind = function FunBind _ -> true | VarBind _ -> false 32 | 33 | type ('a, 'b, 'c, 'd) let_binding_internal = 34 | | InternalVarBind of 'a Pat.t * 'b t 35 | | InternalFunBind of string * 'c Pat.t * 'd t 36 | 37 | (* TODO: Handle scope exit *) 38 | (* apply `f` on reference names, apply `g true` on local binding names, and apply `g 39 | false` on new binding names *) 40 | let rec apply_on_let_bindings f g is_rec l = 41 | (* can't use `let_binding` between `intros` and `bodies` *) 42 | (* because type differs in body and pattern *) 43 | (* using `let_binding_internal` instead *) 44 | let g_local = g true in 45 | let g_new = g false in 46 | let apply = apply_on_names f g_local in 47 | let destruct = function 48 | | VarBind (p, body) -> InternalVarBind (p, body) 49 | | FunBind (bind, p, body) -> InternalFunBind (bind, p, body) 50 | and construct = function 51 | | InternalVarBind (p, body) -> VarBind (p, body) 52 | | InternalFunBind (bind, p, body) -> FunBind (bind, p, body) 53 | and intros = function 54 | | InternalVarBind (p, body) -> InternalVarBind (Pat.apply_on_names f g_new p, body) 55 | | InternalFunBind (bind, p, body) -> 56 | let bind = g_new bind NS.Var in 57 | InternalFunBind (bind, p, body) 58 | and bodies = function 59 | | InternalFunBind (bind, p, body) -> 60 | let p = Pat.apply_on_names f g_local p in 61 | let body = apply body in 62 | InternalFunBind (bind, p, body) 63 | | InternalVarBind (p, body) -> InternalVarBind (p, apply body) 64 | in 65 | let l = List.map destruct l in 66 | let l = 67 | match is_rec with 68 | | true -> List.map intros l |> List.map bodies 69 | | false -> List.map bodies l |> List.map intros 70 | in 71 | List.map construct l 72 | 73 | (* apply `f` on reference names, apply `g` on binding names *) 74 | and apply_on_names f g e = 75 | let apply = apply_on_names f g in 76 | match e with 77 | | Int i -> Int i 78 | | String s -> String s 79 | | Format l -> Format l 80 | | Nil -> Nil 81 | | Tuple l -> Tuple (List.map apply l) 82 | | Array l -> Array (List.map apply l) 83 | | BinOp (op, l, r) -> 84 | let l = apply l in 85 | let r = apply r in 86 | let op = Binop.apply_on_custom (fun x -> f x NS.Var) op in 87 | BinOp (op, l, r) 88 | | UnaryOp (op, e) -> UnaryOp (op, apply e) 89 | | LetAnd (is_rec, l, in_) -> 90 | (* ignore local/global flag *) 91 | let l = apply_on_let_bindings f (fun _ -> g) is_rec l in 92 | let in_ = apply in_ in 93 | LetAnd (is_rec, l, in_) 94 | | IfThenElse (c, t, e) -> 95 | let c = apply c in 96 | let t = apply t in 97 | let e = apply e in 98 | IfThenElse (c, t, e) 99 | | App (l, r) -> 100 | let l = apply l in 101 | let r = apply r in 102 | App (l, r) 103 | | Ctor (name, None) -> Ctor (f name NS.Ctor, None) 104 | | Ctor (name, Some v) -> 105 | let name = f name NS.Ctor in 106 | let v = apply v in 107 | Ctor (name, Some v) 108 | | Var name -> Var (f name NS.Var) 109 | | Match (expr, l) -> 110 | let aux (p, when_, arm) = 111 | let p = Pat.apply_on_names f g p in 112 | let when_ = match when_ with Some when_ -> Some (apply when_) | None -> None in 113 | let arm = apply arm in 114 | p, when_, arm 115 | in 116 | let expr = apply expr in 117 | let l = List.map aux l in 118 | Match (expr, l) 119 | | Lambda (p, expr) -> 120 | let p = Pat.apply_on_names f g p in 121 | let expr = apply expr in 122 | Lambda (p, expr) 123 | | Record l -> 124 | let aux (field, expr) = f field NS.Field, apply expr in 125 | Record (List.map aux l) 126 | | RecordField (expr, field) -> 127 | let expr = apply expr in 128 | let field = f field NS.Field in 129 | RecordField (expr, field) 130 | | RecordFieldAssign (record, field, expr) -> 131 | let record = apply record in 132 | let expr = apply expr in 133 | let field = f field NS.Field in 134 | RecordFieldAssign (record, field, expr) 135 | | RecordUpdate (expr, l) -> 136 | let aux (field, expr) = f field NS.Field, apply expr in 137 | let expr = apply expr in 138 | let l = List.map aux l in 139 | RecordUpdate (expr, l) 140 | | ArrayAssign (ary, idx, v) -> 141 | let ary = apply ary in 142 | let idx = apply idx in 143 | let v = apply v in 144 | ArrayAssign (ary, idx, v) 145 | ;; 146 | 147 | let rec string_of_let_binding f = function 148 | | VarBind (pat, expr) -> 149 | Printf.sprintf 150 | "(%s) = (%s)" 151 | (Pat.string_of_pattern f pat) 152 | (string_of_expression f expr) 153 | | FunBind (name, param, expr) -> 154 | Printf.sprintf 155 | "%s (%s) = (%s)" 156 | name 157 | (Pat.string_of_pattern f param) 158 | (string_of_expression f expr) 159 | 160 | and string_of_expression f = function 161 | | Int num -> Printf.sprintf "Int %d" num 162 | | Tuple values -> 163 | let p = List.map (string_of_expression f) values |> String.concat ", " in 164 | Printf.sprintf "Tuple (%s)" p 165 | | Array values -> 166 | let p = List.map (string_of_expression f) values |> String.concat ", " in 167 | Printf.sprintf "Array (%s)" p 168 | | String s -> Printf.sprintf "String \"%s\"" s 169 | | Format f -> Printf.sprintf "Format \"%s\"" (Fmt.string_of_format_string f) 170 | | BinOp (op, lhs, rhs) -> 171 | Printf.sprintf 172 | "%s (%s) (%s)" 173 | (Binop.string_of_binop f op) 174 | (string_of_expression f lhs) 175 | (string_of_expression f rhs) 176 | | UnaryOp (op, e) -> 177 | Printf.sprintf "%s (%s)" (Unaryop.string_of_unaryop op) (string_of_expression f e) 178 | | App (lhs, rhs) -> 179 | Printf.sprintf 180 | "App (%s) (%s)" 181 | (string_of_expression f lhs) 182 | (string_of_expression f rhs) 183 | | LetAnd (is_rec, l, rhs) -> 184 | let l = List.map (string_of_let_binding f) l |> String.concat " and " in 185 | Printf.sprintf 186 | "Let %s %s in (%s)" 187 | (if is_rec then "rec" else "") 188 | l 189 | (string_of_expression f rhs) 190 | | Ctor (name, rhs) -> 191 | (match rhs with 192 | | Some rhs -> Printf.sprintf "Ctor (%s) (%s)" (f name) (string_of_expression f rhs) 193 | | None -> Printf.sprintf "Ctor (%s)" (f name)) 194 | | IfThenElse (cond, then_, else_) -> 195 | Printf.sprintf 196 | "If (%s) then (%s) else (%s)" 197 | (string_of_expression f cond) 198 | (string_of_expression f then_) 199 | (string_of_expression f else_) 200 | | Var ident -> Printf.sprintf "Var %s" (f ident) 201 | | Match (expr, arms) -> 202 | let string_of_when = function 203 | | Some w -> Printf.sprintf "when (%s)" (string_of_expression f w) 204 | | None -> "" 205 | in 206 | let string_of_arm (pat, when_, arm) = 207 | Printf.sprintf 208 | "(%s) %s -> (%s)" 209 | (Pat.string_of_pattern f pat) 210 | (string_of_when when_) 211 | (string_of_expression f arm) 212 | in 213 | let p = List.map string_of_arm arms |> String.concat " | " in 214 | Printf.sprintf "Match (%s) with %s" (string_of_expression f expr) p 215 | | Lambda (param, body) -> 216 | let p = Pat.string_of_pattern f param in 217 | Printf.sprintf "(%s) -> (%s)" p (string_of_expression f body) 218 | | Nil -> "Nil" 219 | | Record fields -> 220 | let aux (name, expr) = 221 | Printf.sprintf "%s = (%s)" (f name) (string_of_expression f expr) 222 | in 223 | List.map aux fields |> String.concat "; " |> Printf.sprintf "{%s}" 224 | | RecordField (v, field) -> 225 | Printf.sprintf "RecordField (%s).%s" (string_of_expression f v) (f field) 226 | | RecordFieldAssign (v, field, e) -> 227 | Printf.sprintf 228 | "RecordFieldAssign (%s).%s <- (%s)" 229 | (string_of_expression f v) 230 | (f field) 231 | (string_of_expression f e) 232 | | RecordUpdate (e, fields) -> 233 | let aux (name, expr) = 234 | Printf.sprintf "%s = (%s)" (f name) (string_of_expression f expr) 235 | in 236 | List.map aux fields 237 | |> String.concat "; " 238 | |> Printf.sprintf "{%s with %s}" (string_of_expression f e) 239 | | ArrayAssign (ary, idx, v) -> 240 | Printf.sprintf 241 | "(%s).(%s) <- (%s)" 242 | (string_of_expression f ary) 243 | (string_of_expression f idx) 244 | (string_of_expression f v) 245 | ;; 246 | -------------------------------------------------------------------------------- /mlml/analysis/closure.ml: -------------------------------------------------------------------------------- 1 | module Expr = Tree.Expression 2 | module Mod = Tree.Module 3 | module Pat = Tree.Pattern 4 | module SS = Tree.Simple_set 5 | module Binop = Tree.Binop 6 | 7 | (* TODO: Improve this function's name *) 8 | let rec intros_and_free_of_binding is_rec = function 9 | | Expr.FunBind (ident, param, body) -> 10 | let param = Pat.introduced_idents param in 11 | let param = if is_rec then SS.add ident param else param in 12 | let body = free_variables body in 13 | [ident], SS.diff body param 14 | | Expr.VarBind (pat, body) -> 15 | let intros = Pat.introduced_ident_list pat in 16 | let body = free_variables body in 17 | intros, body 18 | 19 | and free_variables = function 20 | | Expr.Int _ | Expr.String _ | Expr.Nil | Expr.Format _ -> SS.empty 21 | | Expr.BinOp (op, l, r) -> 22 | let lr = SS.union (free_variables l) (free_variables r) in 23 | (match op with Binop.Custom sym -> SS.add sym lr | _ -> lr) 24 | | Expr.UnaryOp (_op, e) -> free_variables e 25 | | Expr.App (l, r) -> SS.union (free_variables l) (free_variables r) 26 | | Expr.Array values | Expr.Tuple values -> 27 | List.map free_variables values |> List.fold_left SS.union SS.empty 28 | | Expr.LetAnd (is_rec, l, in_) -> 29 | let in_ = free_variables in_ in 30 | let idents, l = List.map (intros_and_free_of_binding is_rec) l |> List.split in 31 | let intros = List.flatten idents |> SS.of_list in 32 | List.fold_left SS.union (SS.diff in_ intros) l 33 | | Expr.IfThenElse (c, t, e) -> 34 | SS.union (free_variables c) @@ SS.union (free_variables t) (free_variables e) 35 | | Expr.Ctor (_, expr) -> 36 | (match expr with Some expr -> free_variables expr | None -> SS.empty) 37 | | Expr.Match (expr, arms) -> 38 | let expr = free_variables expr in 39 | let aux (pat, when_, v) = 40 | let pat_intros = Pat.introduced_idents pat in 41 | let v = free_variables v in 42 | match when_ with 43 | | Some when_ -> 44 | let when_ = free_variables when_ in 45 | SS.diff (SS.union when_ v) pat_intros 46 | | None -> SS.diff v pat_intros 47 | in 48 | let arms = List.map aux arms |> List.fold_left SS.union SS.empty in 49 | SS.union expr arms 50 | | Expr.Lambda (param, body) -> 51 | let param = Pat.introduced_idents param in 52 | let body = free_variables body in 53 | SS.diff body param 54 | | Expr.Var x -> SS.singleton x 55 | | Expr.Record fields -> 56 | let aux (_, expr) = free_variables expr in 57 | List.map aux fields |> List.fold_left SS.union SS.empty 58 | | Expr.RecordField (v, _) -> free_variables v 59 | | Expr.RecordFieldAssign (v, _, e) -> SS.union (free_variables v) (free_variables e) 60 | | Expr.RecordUpdate (e, fields) -> 61 | let aux (_, expr) = free_variables expr in 62 | List.map aux fields |> List.fold_left SS.union (free_variables e) 63 | | Expr.ArrayAssign (ary, idx, v) -> 64 | SS.union (free_variables ary) @@ SS.union (free_variables idx) (free_variables v) 65 | ;; 66 | 67 | let free_variable_list x = free_variables x |> SS.elements 68 | let make_let_var bind body in_ = Expr.LetAnd (false, [Expr.VarBind (bind, body)], in_) 69 | 70 | let make_let_fun is_rec ident param body in_ = 71 | Expr.LetAnd (is_rec, [Expr.FunBind (ident, param, body)], in_) 72 | ;; 73 | 74 | let rec convert_let_bindings i is_rec fvs l = 75 | let fv_tuple = Expr.Tuple (List.map (fun x -> Expr.Var x) fvs) in 76 | let fv_pat = Pat.Tuple (List.map (fun x -> Pat.Var x) fvs) in 77 | let folder_body_rec acc = function 78 | | Expr.FunBind (ident, _, _) -> 79 | make_let_var (Pat.Var ident) (Expr.Tuple [Expr.Var ident; fv_tuple]) acc 80 | | Expr.VarBind _ -> acc 81 | in 82 | let aux = function 83 | | Expr.FunBind (ident, param, body) -> 84 | let body = convert_expr' i body in 85 | let real_body = if is_rec then List.fold_left folder_body_rec body l else body in 86 | let real_param = Pat.Tuple [param; fv_pat] in 87 | let evalto = Expr.Tuple [Expr.Var ident; fv_tuple] in 88 | (Pat.Var ident, Some evalto), Expr.FunBind (ident, real_param, real_body) 89 | | Expr.VarBind (pat, body) -> 90 | let body = convert_expr' i body in 91 | (pat, None), Expr.VarBind (pat, body) 92 | in 93 | List.map aux l |> List.split 94 | 95 | (* TODO: simplify application to subexpr *) 96 | and convert_expr' i expr = 97 | (* define an alias because it's a long name *) 98 | let aux = convert_expr' in 99 | match expr with 100 | | Expr.LetAnd (is_rec, l, in_) -> 101 | let in_ = aux i in_ in 102 | let fvs_binding x = intros_and_free_of_binding is_rec x |> snd |> SS.elements in 103 | let fvs = List.map fvs_binding l |> List.flatten in 104 | let folder_wrap acc = function 105 | | pat, Some evalto -> make_let_var pat evalto acc 106 | | _, None -> acc 107 | in 108 | let evals, l = convert_let_bindings i is_rec fvs l in 109 | let wrap = List.fold_left folder_wrap in_ evals in 110 | Expr.LetAnd (is_rec, l, wrap) 111 | | Expr.Lambda (param, body) -> 112 | let fvs = free_variable_list expr in 113 | let body = aux i body in 114 | let fv_tuple = Expr.Tuple (List.map (fun x -> Expr.Var x) fvs) in 115 | let fv_pat = Pat.Tuple (List.map (fun x -> Pat.Var x) fvs) in 116 | let real_param = Pat.Tuple [param; fv_pat] in 117 | let real_fun = Expr.Lambda (real_param, body) in 118 | Expr.Tuple [real_fun; fv_tuple] 119 | | Expr.App (lhs, rhs) -> 120 | let lhs = aux i lhs in 121 | let rhs = aux (i + 1) rhs in 122 | let f_name = Printf.sprintf "_f%d" i in 123 | let fv_name = Printf.sprintf "_fv%d" i in 124 | let destruct = Pat.Tuple [Pat.Var f_name; Pat.Var fv_name] in 125 | let real_app = Expr.App (Expr.Var f_name, Expr.Tuple [rhs; Expr.Var fv_name]) in 126 | make_let_var destruct lhs real_app 127 | | Expr.Int _ | Expr.Var _ | Expr.String _ | Expr.Nil | Expr.Format _ -> expr 128 | | Expr.BinOp (op, l, r) -> 129 | (match op with 130 | | Binop.Custom sym -> aux i (Expr.App (Expr.App (Expr.Var sym, l), r)) 131 | | _ -> 132 | let l = aux i l in 133 | let r = aux i r in 134 | Expr.BinOp (op, l, r)) 135 | | Expr.UnaryOp (op, e) -> Expr.UnaryOp (op, aux i e) 136 | | Expr.IfThenElse (c, t, e) -> Expr.IfThenElse (aux i c, aux i t, aux i e) 137 | | Expr.Ctor (name, param) -> 138 | (match param with 139 | | Some param -> Expr.Ctor (name, Some (aux i param)) 140 | | None -> expr) 141 | | Expr.Tuple values -> Expr.Tuple (List.map (aux i) values) 142 | | Expr.Array values -> Expr.Array (List.map (aux i) values) 143 | | Expr.Match (expr, arms) -> 144 | let expr = aux i expr in 145 | let aux' (pat, when_, v) = 146 | let when_ = match when_ with Some when_ -> Some (aux i when_) | None -> None in 147 | pat, when_, aux i v 148 | in 149 | Expr.Match (expr, List.map aux' arms) 150 | | Expr.Record fields -> 151 | let aux' (name, expr) = name, aux i expr in 152 | Expr.Record (List.map aux' fields) 153 | | Expr.RecordField (v, field) -> Expr.RecordField (aux i v, field) 154 | | Expr.RecordFieldAssign (v, field, e) -> 155 | let v = aux i v in 156 | let e = aux i e in 157 | Expr.RecordFieldAssign (v, field, e) 158 | | Expr.RecordUpdate (e, fields) -> 159 | let aux' (name, expr) = name, aux i expr in 160 | Expr.RecordUpdate (aux i e, List.map aux' fields) 161 | | Expr.ArrayAssign (ary, idx, v) -> Expr.ArrayAssign (aux i ary, aux i idx, aux i v) 162 | 163 | and convert_expr acc expr = Mod.Expression (convert_expr' 0 expr) :: acc 164 | 165 | let make_let_var_defn pat expr = Mod.LetAnd (false, [Expr.VarBind (pat, expr)]) 166 | 167 | let free_variables_defn = function 168 | | Mod.LetAnd (is_rec, l) -> 169 | let _, l = List.map (intros_and_free_of_binding is_rec) l |> List.split in 170 | List.fold_left SS.union SS.empty l 171 | | _ -> SS.empty 172 | ;; 173 | 174 | let rec convert_defn acc defn = 175 | let app d = Mod.Definition d :: acc in 176 | match defn with 177 | | Mod.LetAnd (is_rec, l) -> 178 | let fvs = free_variables_defn defn |> SS.elements in 179 | let evals, l = convert_let_bindings 0 is_rec fvs l in 180 | (* Remove VarBind from l, and use body of VarBind in resulting_expr *) 181 | let funs, vars = List.partition Expr.is_fun_bind l in 182 | let aux = function 183 | | Expr.VarBind (pat, body) -> pat, body 184 | | _ -> failwith "unreachable" 185 | in 186 | let folder acc = function 187 | | pat, Some evalto -> (pat, evalto) :: acc 188 | | _, None -> acc 189 | in 190 | let pats, values = List.fold_left folder (List.map aux vars) evals |> List.split in 191 | let resulting_pat = Pat.Tuple pats in 192 | let resulting_expr = Expr.Tuple values in 193 | app @@ make_let_var_defn resulting_pat (Expr.LetAnd (is_rec, funs, resulting_expr)) 194 | | Mod.TypeDef _ -> app defn 195 | | Mod.Module (name, expr) -> 196 | (match expr with 197 | | Mod.Path _ -> app defn 198 | | Mod.Struct l -> 199 | app @@ Mod.Module (name, Mod.Struct (List.fold_right convert_module_item l []))) 200 | | Mod.Open _ -> app @@ defn 201 | | Mod.External (name, _ty, _decl) -> 202 | (* convert to closure form *) 203 | let c = 204 | make_let_var_defn (Pat.Var name) (Expr.Tuple [Expr.Var name; Expr.Tuple []]) 205 | in 206 | Mod.Definition defn :: Mod.Definition c :: acc 207 | 208 | and convert_module_item l acc = 209 | match l with 210 | | Mod.Expression expr -> convert_expr acc expr 211 | | Mod.Definition defn -> convert_defn acc defn 212 | ;; 213 | 214 | let f l = List.fold_right convert_module_item l [] 215 | -------------------------------------------------------------------------------- /mlml/lexer/lexer.ml: -------------------------------------------------------------------------------- 1 | module Fmt = Tree.Format_string 2 | 3 | type token = 4 | | IntLiteral of int 5 | | BoolLiteral of bool 6 | | StringLiteral of string 7 | | FormatStringLiteral of Fmt.kind list 8 | | CharLiteral of char 9 | | CapitalIdent of string 10 | | LowerIdent of string 11 | | InfixSymbol of string 12 | | Plus 13 | | Minus 14 | | Star 15 | | Slash 16 | | Mod 17 | | DoubleAnd 18 | | Let 19 | | Rec 20 | | In 21 | | And 22 | | Equal 23 | | NotEqual 24 | | Lt 25 | | Gt 26 | | If 27 | | Then 28 | | Else 29 | | Type 30 | | Vertical 31 | | DoubleVertical 32 | | Excl 33 | | Of 34 | | Match 35 | | With 36 | | When 37 | | Fun 38 | | Arrow 39 | | LeftArrow 40 | | Mutable 41 | | Function 42 | | Comma 43 | | Semicolon 44 | | DoubleSemicolon 45 | | Colon 46 | | DoubleColon 47 | | LParen 48 | | RParen 49 | | LBracket 50 | | RBracket 51 | | LBrace 52 | | RBrace 53 | | Dot 54 | | DoubleDot 55 | | Apostrophe 56 | | Module 57 | | Struct 58 | | End 59 | | Open 60 | | External 61 | | LArray 62 | | RArray 63 | 64 | let to_digit c = int_of_char c - int_of_char '0' 65 | let string_of_chars chars = String.init (List.length chars) (List.nth chars) 66 | 67 | let rec read_int acc rest = 68 | match rest with 69 | | h :: t -> 70 | (match h with '0' .. '9' -> read_int ((acc * 10) + to_digit h) t | _ -> rest, acc) 71 | | _ -> [], acc 72 | ;; 73 | 74 | type char_aux = 75 | | Raw of char 76 | | Escaped of char 77 | 78 | let to_raw_char = function Raw c | Escaped c -> c 79 | 80 | let read_one_char = function 81 | | '\\' :: t -> 82 | (match t with 83 | | '\\' :: rest -> rest, Escaped '\\' 84 | | '"' :: rest -> rest, Escaped '"' 85 | | '\'' :: rest -> rest, Escaped '\'' 86 | | 'n' :: rest -> rest, Escaped '\n' 87 | | 'r' :: rest -> rest, Escaped '\r' 88 | | 't' :: rest -> rest, Escaped '\t' 89 | | 'b' :: rest -> rest, Escaped '\b' 90 | | ' ' :: rest -> rest, Escaped ' ' 91 | | _ -> 92 | failwith "Invalid escape sequence" (* TODO: Implement ASCII escape sequences *)) 93 | (* TODO: Escape % in `read_format_string` *) 94 | | '%' :: '%' :: rest -> rest, Escaped '%' 95 | | c :: rest -> rest, Raw c 96 | | [] -> failwith "attempt to read a char from empty input" 97 | ;; 98 | 99 | let read_string_part chars = 100 | let rec aux acc chars = 101 | let rest, c = read_one_char chars in 102 | match c with 103 | | Raw '%' | Raw '"' -> chars, acc 104 | | _ -> 105 | let c = to_raw_char c in 106 | let rest, acc = aux acc rest in 107 | rest, c :: acc 108 | in 109 | let rest, chars = aux [] chars in 110 | rest, string_of_chars chars 111 | ;; 112 | 113 | let rec read_format_string acc chars = 114 | let rest, c = read_one_char chars in 115 | match c with 116 | | Raw '"' -> rest, acc 117 | | Raw '%' -> 118 | let rest, ty_char = read_one_char rest in 119 | let spec = 120 | match to_raw_char ty_char with 121 | | 'd' -> Fmt.Int 122 | | 'c' -> Fmt.Char 123 | | 's' -> Fmt.String 124 | | _ -> failwith "Invalid format specifier" 125 | in 126 | let rest, acc = read_format_string acc rest in 127 | rest, spec :: acc 128 | | _ -> 129 | let rest, str = read_string_part chars in 130 | let rest, acc = read_format_string acc rest in 131 | rest, Fmt.Const str :: acc 132 | ;; 133 | 134 | let try_read_char tokens = 135 | match read_one_char tokens with 136 | | '\'' :: rest, c -> rest, Some (to_raw_char c) 137 | | _ -> tokens, None 138 | ;; 139 | 140 | let read_char tokens = 141 | match try_read_char tokens with 142 | | rest, Some c -> rest, c 143 | | _, None -> failwith "invalid char literal" 144 | ;; 145 | 146 | let rec read_ident acc rest = 147 | match rest with 148 | | h :: t -> 149 | (match h with 150 | | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '\'' -> 151 | let rest, ident = read_ident acc t in 152 | rest, h :: ident 153 | | _ -> rest, acc) 154 | | _ -> [], acc 155 | ;; 156 | 157 | let is_operator_char = function 158 | | '!' | '$' | '%' | '&' | '*' | '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' 159 | | '@' | '^' | '|' | '~' -> true 160 | | _ -> false 161 | ;; 162 | 163 | let rec read_infix_symbol acc = function 164 | | h :: t when is_operator_char h -> 165 | let rest, ident = read_infix_symbol acc t in 166 | rest, h :: ident 167 | | rest -> rest, acc 168 | ;; 169 | 170 | let rec tokenize_aux acc rest = 171 | match rest with 172 | | [] -> acc 173 | | '(' :: '*' :: rest -> 174 | let rec consume_comment level = function 175 | | '(' :: '*' :: rest -> consume_comment (level + 1) rest 176 | | '*' :: ')' :: rest when level = 0 -> rest 177 | | '*' :: ')' :: rest -> consume_comment (level - 1) rest 178 | | _ :: t -> consume_comment level t 179 | | [] -> failwith "comment does not end" 180 | in 181 | consume_comment 0 rest |> tokenize_aux acc 182 | | h :: t -> 183 | (match h with 184 | | ' ' | '\t' | '\n' -> tokenize_aux acc t 185 | | '0' .. '9' -> 186 | let rest, num = read_int 0 rest in 187 | tokenize_aux (IntLiteral num :: acc) rest 188 | | '"' -> 189 | (match read_format_string [] t with 190 | | rest, [] -> tokenize_aux (StringLiteral "" :: acc) rest 191 | | rest, [Fmt.Const s] -> tokenize_aux (StringLiteral s :: acc) rest 192 | | rest, fmt -> tokenize_aux (FormatStringLiteral fmt :: acc) rest) 193 | | '\'' -> 194 | (match try_read_char t with 195 | | rest, Some ch -> tokenize_aux (CharLiteral ch :: acc) rest 196 | | rest, None -> tokenize_aux (Apostrophe :: acc) rest) 197 | | 'a' .. 'z' | 'A' .. 'Z' | '_' -> 198 | let rest, ident = read_ident [] rest in 199 | let ident_str = string_of_chars ident in 200 | (match ident_str with 201 | | "mod" -> tokenize_aux (Mod :: acc) rest 202 | | "let" -> tokenize_aux (Let :: acc) rest 203 | | "rec" -> tokenize_aux (Rec :: acc) rest 204 | | "in" -> tokenize_aux (In :: acc) rest 205 | | "and" -> tokenize_aux (And :: acc) rest 206 | | "true" -> tokenize_aux (BoolLiteral true :: acc) rest 207 | | "false" -> tokenize_aux (BoolLiteral false :: acc) rest 208 | | "if" -> tokenize_aux (If :: acc) rest 209 | | "then" -> tokenize_aux (Then :: acc) rest 210 | | "else" -> tokenize_aux (Else :: acc) rest 211 | | "type" -> tokenize_aux (Type :: acc) rest 212 | | "of" -> tokenize_aux (Of :: acc) rest 213 | | "match" -> tokenize_aux (Match :: acc) rest 214 | | "with" -> tokenize_aux (With :: acc) rest 215 | | "when" -> tokenize_aux (When :: acc) rest 216 | | "fun" -> tokenize_aux (Fun :: acc) rest 217 | | "function" -> tokenize_aux (Function :: acc) rest 218 | | "module" -> tokenize_aux (Module :: acc) rest 219 | | "struct" -> tokenize_aux (Struct :: acc) rest 220 | | "end" -> tokenize_aux (End :: acc) rest 221 | | "open" -> tokenize_aux (Open :: acc) rest 222 | | "external" -> tokenize_aux (External :: acc) rest 223 | | "mutable" -> tokenize_aux (Mutable :: acc) rest 224 | | _ -> 225 | (match ident_str.[0] with 226 | | 'A' .. 'Z' -> tokenize_aux (CapitalIdent ident_str :: acc) rest 227 | | _ -> tokenize_aux (LowerIdent ident_str :: acc) rest)) 228 | | ',' -> tokenize_aux (Comma :: acc) t 229 | | '(' -> tokenize_aux (LParen :: acc) t 230 | | ')' -> tokenize_aux (RParen :: acc) t 231 | | '[' -> 232 | (match t with 233 | | '|' :: t -> tokenize_aux (LArray :: acc) t 234 | | _ -> tokenize_aux (LBracket :: acc) t) 235 | | ']' -> tokenize_aux (RBracket :: acc) t 236 | | '{' -> tokenize_aux (LBrace :: acc) t 237 | | '}' -> tokenize_aux (RBrace :: acc) t 238 | | '.' -> 239 | (match t with 240 | | '.' :: t -> tokenize_aux (DoubleDot :: acc) t 241 | | _ -> tokenize_aux (Dot :: acc) t) 242 | | ';' -> 243 | (match t with 244 | | ';' :: t -> tokenize_aux (DoubleSemicolon :: acc) t 245 | | _ -> tokenize_aux (Semicolon :: acc) t) 246 | | ':' -> 247 | (match t with 248 | | ':' :: t -> tokenize_aux (DoubleColon :: acc) t 249 | | _ -> tokenize_aux (Colon :: acc) t) 250 | | '!' -> 251 | (match t with 252 | | '=' :: t -> tokenize_aux (NotEqual :: acc) t 253 | | _ -> tokenize_aux (Excl :: acc) t) 254 | | '|' when List.hd t = ']' -> tokenize_aux (RArray :: acc) (List.tl t) 255 | | '=' | '<' | '>' | '@' | '^' | '|' | '&' | '+' | '-' | '*' | '/' | '$' | '%' -> 256 | let rest, sym = read_infix_symbol [] t in 257 | let sym_str = string_of_chars (h :: sym) in 258 | let token = 259 | match sym_str with 260 | | "+" -> Plus 261 | | "-" -> Minus 262 | | "->" -> Arrow 263 | | "<-" -> LeftArrow 264 | | "*" -> Star 265 | | "/" -> Slash 266 | | "=" -> Equal 267 | | "<" -> Lt 268 | | ">" -> Gt 269 | | "|" -> Vertical 270 | | "||" -> DoubleVertical 271 | | "&&" -> DoubleAnd 272 | | _ -> InfixSymbol sym_str 273 | in 274 | tokenize_aux (token :: acc) rest 275 | | _ -> failwith @@ Printf.sprintf "unexpected character: '%c'" h) 276 | ;; 277 | 278 | let string_of_token = function 279 | | IntLiteral num -> string_of_int num 280 | | BoolLiteral b -> string_of_bool b 281 | | StringLiteral str -> Printf.sprintf "\"%s\"" str 282 | | FormatStringLiteral f -> Printf.sprintf "\"%s\"" (Fmt.string_of_format_string f) 283 | | CharLiteral ch -> Printf.sprintf "'%c'" ch 284 | | CapitalIdent ident | LowerIdent ident -> ident 285 | | InfixSymbol sym -> sym 286 | | Plus -> "+" 287 | | Minus -> "-" 288 | | Star -> "*" 289 | | Slash -> "/" 290 | | DoubleAnd -> "&&" 291 | | Mod -> "mod" 292 | | Let -> "let" 293 | | Rec -> "rec" 294 | | In -> "in" 295 | | And -> "and" 296 | | Equal -> "=" 297 | | NotEqual -> "!=" 298 | | Lt -> "<" 299 | | Gt -> ">" 300 | | If -> "if" 301 | | Then -> "then" 302 | | Else -> "else" 303 | | Type -> "type" 304 | | Vertical -> "|" 305 | | DoubleVertical -> "||" 306 | | Excl -> "!" 307 | | Of -> "of" 308 | | Match -> "match" 309 | | With -> "with" 310 | | When -> "when" 311 | | Fun -> "fun" 312 | | Arrow -> "->" 313 | | LeftArrow -> "<-" 314 | | Mutable -> "mutable" 315 | | Function -> "function" 316 | | Comma -> "," 317 | | Semicolon -> ";" 318 | | DoubleSemicolon -> ";;" 319 | | Colon -> ":" 320 | | DoubleColon -> "::" 321 | | LParen -> "(" 322 | | RParen -> ")" 323 | | LBracket -> "[" 324 | | RBracket -> "]" 325 | | LBrace -> "{" 326 | | RBrace -> "}" 327 | | Dot -> "." 328 | | DoubleDot -> ".." 329 | | Apostrophe -> "'" 330 | | Module -> "module" 331 | | Struct -> "struct" 332 | | End -> "end" 333 | | Open -> "open" 334 | | External -> "external" 335 | | LArray -> "[|" 336 | | RArray -> "|]" 337 | ;; 338 | 339 | let string_of_tokens tokens = 340 | let aux acc t = string_of_token t ^ ", " ^ acc in 341 | List.fold_left aux "" @@ List.rev tokens 342 | ;; 343 | 344 | let explode s = 345 | let rec exp i l = if i < 0 then l else exp (i - 1) (s.[i] :: l) in 346 | exp (String.length s - 1) [] 347 | ;; 348 | 349 | let f source = explode source |> tokenize_aux [] |> List.rev 350 | -------------------------------------------------------------------------------- /mlml/analysis/resolve.ml: -------------------------------------------------------------------------------- 1 | (* resolve paths and convert them into string *) 2 | (* TODO: use more clear ways to resolve paths *) 3 | 4 | module Path = Tree.Path 5 | module Expr = Tree.Expression 6 | module Mod = Tree.Module 7 | module TyExpr = Tree.Type_expression 8 | module Pat = Tree.Pattern 9 | module NS = Tree.Namespace 10 | module SS = Tree.Simple_set 11 | 12 | type 'a value = 13 | | Entity of 'a 14 | (* absolute path *) 15 | | Alias of Path.t 16 | 17 | and module_env = 18 | { vars : (string, unit value) Hashtbl.t 19 | ; types : (string, unit value) Hashtbl.t 20 | ; ctors : (string, unit value) Hashtbl.t 21 | ; fields : (string, unit value) Hashtbl.t 22 | ; modules : (string, module_env value) Hashtbl.t } 23 | 24 | let create_module_env () = 25 | { vars = Hashtbl.create 32 26 | ; types = Hashtbl.create 32 27 | ; ctors = Hashtbl.create 32 28 | ; fields = Hashtbl.create 32 29 | ; modules = Hashtbl.create 32 } 30 | ;; 31 | 32 | let find_name_local env name = 33 | let or_else optb = function None -> optb | v -> v in 34 | Hashtbl.find_opt env.ctors name 35 | |> or_else (Hashtbl.find_opt env.vars name) 36 | |> or_else (Hashtbl.find_opt env.fields name) 37 | |> or_else (Hashtbl.find_opt env.types name) 38 | ;; 39 | 40 | let find_module_local env name = Hashtbl.find_opt env.modules name 41 | 42 | (* find a provided path in env and returns canonical path and `module_env` if found *) 43 | let rec find_aux root_env path = 44 | (* same as `find_module_local`, but resolves the aliases *) 45 | (* returns `module_env` and canonical path if name is alias *) 46 | let find_module_env_local env name = 47 | match find_module_local env name with 48 | | Some (Entity v) -> Some (v, None) 49 | | Some (Alias path) -> 50 | (match find_aux root_env path with 51 | | Some (p, Some m) -> Some (m, Some p) 52 | | _ -> None) 53 | | None -> None 54 | in 55 | let rec aux env path resolved = 56 | match Path.extract path with 57 | | [head] -> 58 | let current_resolved = Path.join resolved (Path.single head) in 59 | (match find_module_env_local env head with 60 | | Some (e, Some p) -> Some (p, Some e) 61 | | Some (e, None) -> Some (current_resolved, Some e) 62 | | None -> 63 | (* not a module *) 64 | (match find_name_local env head with 65 | | Some (Entity ()) -> Some (current_resolved, None) 66 | | Some (Alias path) -> find_aux root_env path 67 | | None -> None)) 68 | | head :: tail -> 69 | (match find_module_env_local env head with 70 | | Some (e, None) -> 71 | aux e (Path.of_list tail) (Path.join resolved (Path.single head)) 72 | | Some (e, Some p) -> aux e (Path.of_list tail) p 73 | | _ -> None) 74 | | [] -> None 75 | in 76 | aux root_env path Path.root 77 | 78 | and find_module_opt env path = 79 | match find_aux env path with Some (_, Some m) -> Some m | _ -> None 80 | ;; 81 | 82 | let find_module env path = 83 | match find_module_opt env path with Some v -> v | None -> failwith "NotFound" 84 | ;; 85 | 86 | let canonical_opt env path = 87 | match find_aux env path with Some (p, _) -> Some p | None -> None 88 | ;; 89 | 90 | (* `canonical env path` returns canonical form of `path` in `env` *) 91 | let canonical env path = 92 | match canonical_opt env path with 93 | | Some p -> p 94 | | None -> 95 | failwith 96 | @@ Printf.sprintf "could not canonicalize path %s" (Path.string_of_path path) 97 | ;; 98 | 99 | (* `mem env path` checks if `path` is reachable in `env` *) 100 | let mem env path = match find_aux env path with Some _ -> true | None -> false 101 | 102 | (* conversion context *) 103 | (* TODO: Replace list with some other generic mutable set type *) 104 | type context = {primary : Path.t} 105 | 106 | let create_context () = {primary = Path.root} 107 | let absolute ctx path = Path.join ctx.primary path 108 | let absolute_name ctx name = absolute ctx (Path.single name) 109 | 110 | let resolve env ctx path = 111 | let candidates = Path.subpaths ctx.primary in 112 | let make_abs c = Path.join c path in 113 | match List.find_opt (mem env) (List.map make_abs candidates) with 114 | | Some p -> canonical env p 115 | | None -> 116 | failwith @@ Printf.sprintf "could not resolve path %s" (Path.string_of_path path) 117 | ;; 118 | 119 | (* convert a path to a pair of `module_env` and local name in returned env *) 120 | let to_env_and_name env path = 121 | match Path.init_last path with 122 | | [], name -> env, name 123 | | init, last -> 124 | let m = find_module env (Path.of_list init) in 125 | m, last 126 | ;; 127 | 128 | let add_local_with_ns env name v ns = 129 | let f = 130 | match ns with 131 | | NS.Var -> Hashtbl.add env.vars 132 | | NS.Ctor -> Hashtbl.add env.ctors 133 | | NS.Field -> Hashtbl.add env.fields 134 | | NS.Type -> Hashtbl.add env.types 135 | in 136 | f name v 137 | ;; 138 | 139 | let add_local_name_with_ns env name ns = add_local_with_ns env name (Entity ()) ns 140 | let add_local_alias_with_ns env name path ns = add_local_with_ns env name (Alias path) ns 141 | 142 | let add_with_ns env path ns = 143 | let m, name = to_env_and_name env path in 144 | add_local_name_with_ns m name ns 145 | ;; 146 | 147 | let mem_local_with_ns env name = function 148 | | NS.Var -> Hashtbl.mem env.vars name 149 | | NS.Ctor -> Hashtbl.mem env.ctors name 150 | | NS.Field -> Hashtbl.mem env.fields name 151 | | NS.Type -> Hashtbl.mem env.types name 152 | ;; 153 | 154 | let mem_with_ns env path ns = 155 | let m, name = to_env_and_name env path in 156 | mem_local_with_ns m name ns 157 | ;; 158 | 159 | let insert_alias env path target = 160 | let m, name = to_env_and_name env path in 161 | Hashtbl.add m.modules name (Alias target) 162 | ;; 163 | 164 | let iter_names f env = 165 | let apply ns k _ = f k ns in 166 | Hashtbl.iter (apply NS.Var) env.vars; 167 | Hashtbl.iter (apply NS.Ctor) env.ctors; 168 | Hashtbl.iter (apply NS.Field) env.fields; 169 | Hashtbl.iter (apply NS.Type) env.types 170 | ;; 171 | 172 | let alias_names from_path from to_ = 173 | let adder v ns = 174 | let abs = Path.join from_path (Path.single v) in 175 | add_local_alias_with_ns to_ v abs ns 176 | in 177 | iter_names adder from; 178 | let adder_module k _ = 179 | let abs = Path.join from_path (Path.single k) in 180 | Hashtbl.add to_.modules k (Alias abs) 181 | in 182 | Hashtbl.iter adder_module from.modules 183 | ;; 184 | 185 | let open_path env ctx path = 186 | let from = find_module env path in 187 | let to_ = find_module env ctx.primary in 188 | alias_names path from to_ 189 | ;; 190 | 191 | let in_new_module env ctx name f = 192 | let path = absolute_name ctx name in 193 | let m, name = to_env_and_name env path in 194 | Hashtbl.add m.modules name (Entity (create_module_env ())); 195 | f {primary = path} 196 | ;; 197 | 198 | (* expression-local environment *) 199 | (* TODO: Replace this with some other generic mutable set type *) 200 | type local_env = {mutable local_vars : string SS.t} 201 | 202 | let create_local_env () = {local_vars = SS.empty} 203 | 204 | (* the main conversion *) 205 | let apply_binds local_env x = function 206 | | NS.Var -> 207 | local_env.local_vars <- SS.add x local_env.local_vars; 208 | x 209 | | _ -> failwith "unexpected binding" 210 | ;; 211 | 212 | let apply_vars local_env env ctx path ns = 213 | let path = 214 | match ns, Path.extract path with 215 | (* locally-bound variables *) 216 | | NS.Var, [head] when SS.mem head local_env.local_vars -> path 217 | | _ -> resolve env ctx path 218 | in 219 | Path.string_of_path path 220 | ;; 221 | 222 | let convert_expr' local_env env ctx expr = 223 | Expr.apply_on_names (apply_vars local_env env ctx) (apply_binds local_env) expr 224 | ;; 225 | 226 | let convert_expr env ctx expr = convert_expr' (create_local_env ()) env ctx expr 227 | 228 | let convert_type_expr env ctx expr = 229 | let binds x _ = x in 230 | let vars x _ = 231 | let path = resolve env ctx x in 232 | Path.string_of_path path 233 | in 234 | TyExpr.apply_on_names vars binds expr 235 | ;; 236 | 237 | let convert_type_def env ctx defn = 238 | match defn with 239 | | Mod.Variant l -> 240 | let aux (ctor_name, expr_opt) = 241 | let ctor_name = absolute_name ctx ctor_name in 242 | add_with_ns env ctor_name NS.Ctor; 243 | let expr_opt = 244 | match expr_opt with Some e -> Some (convert_type_expr env ctx e) | None -> None 245 | in 246 | Path.string_of_path ctor_name, expr_opt 247 | in 248 | Mod.Variant (List.map aux l) 249 | | Mod.Record l -> 250 | let aux (is_mut, field_name, expr) = 251 | let field_name = absolute_name ctx field_name in 252 | add_with_ns env field_name NS.Field; 253 | let expr = convert_type_expr env ctx expr in 254 | is_mut, Path.string_of_path field_name, expr 255 | in 256 | Mod.Record (List.map aux l) 257 | | Mod.Alias expr -> 258 | let expr = convert_type_expr env ctx expr in 259 | Mod.Alias expr 260 | ;; 261 | 262 | let rec convert_defn env ctx defn = 263 | match defn with 264 | | Mod.LetAnd (is_rec, l) -> 265 | let local_env = create_local_env () in 266 | let binds is_local x ns = 267 | match is_local with 268 | | true -> apply_binds local_env x ns 269 | | false -> 270 | let path = absolute_name ctx x in 271 | add_with_ns env path ns; 272 | Path.string_of_path path 273 | in 274 | let l = Expr.apply_on_let_bindings (apply_vars local_env env ctx) binds is_rec l in 275 | [Mod.Definition (Mod.LetAnd (is_rec, l))] 276 | | Mod.TypeDef l -> 277 | let intros (tyvars, bind, def) = 278 | let bind = absolute_name ctx bind in 279 | add_with_ns env bind NS.Type; 280 | tyvars, bind, def 281 | in 282 | let aux (tyvars, bind, def) = 283 | let def = convert_type_def env ctx def in 284 | tyvars, Path.string_of_path bind, def 285 | in 286 | let l = List.map intros l |> List.map aux in 287 | [Mod.Definition (Mod.TypeDef l)] 288 | | Mod.Module (name, Mod.Path path) -> 289 | let t = absolute_name ctx name in 290 | let path = resolve env ctx path in 291 | insert_alias env t path; 292 | [] 293 | | Mod.Module (name, Mod.Struct l) -> 294 | let f ctx = List.map (convert_module_item env ctx) l |> List.flatten in 295 | in_new_module env ctx name f 296 | | Mod.Open path -> 297 | let path = resolve env ctx path in 298 | open_path env ctx path; 299 | [] 300 | | Mod.External (name, ty, decl) -> 301 | let path = absolute_name ctx name in 302 | add_with_ns env path NS.Var; 303 | let name = Path.string_of_path path in 304 | let ty = convert_type_expr env ctx ty in 305 | [Mod.Definition (Mod.External (name, ty, decl))] 306 | 307 | and convert_module_item env ctx = function 308 | | Mod.Expression expr -> [Mod.Expression (convert_expr env ctx expr)] 309 | | Mod.Definition defn -> convert_defn env ctx defn 310 | ;; 311 | 312 | let add_primitives env = 313 | let types = 314 | ["unit"; "int"; "bool"; "char"; "string"; "bytes"; "array"; "list"; "in_channel"] 315 | in 316 | let adder x = add_local_name_with_ns env x NS.Type in 317 | List.iter adder types 318 | ;; 319 | 320 | let f l = 321 | let env = create_module_env () in 322 | let ctx = create_context () in 323 | add_primitives env; 324 | List.map (convert_module_item env ctx) l |> List.flatten 325 | ;; 326 | -------------------------------------------------------------------------------- /mlml/parser/expression.ml: -------------------------------------------------------------------------------- 1 | (* Parse the ocaml expression. *) 2 | (* https://caml.inria.fr/pub/docs/manual-ocaml/expr.html *) 3 | 4 | module L = Lexer 5 | module Pat = Pattern 6 | module Binop = Tree.Binop 7 | module Uop = Tree.Unaryop 8 | module T = Tree.Expression 9 | 10 | type t = Tree.Path.t T.t 11 | 12 | (* fun x y z -> expr *) 13 | (* => fun x -> (fun y -> (fun z -> expr)) *) 14 | let rec params_to_lambdas expr = function 15 | | h :: t -> T.Lambda (h, params_to_lambdas expr t) 16 | | [] -> expr 17 | ;; 18 | 19 | let rec parse_fun_params is_let = function 20 | | L.Arrow :: rest when not is_let -> rest, [] 21 | | L.Equal :: rest when is_let -> rest, [] 22 | | tokens -> 23 | let rest, pat = Pat.parse_pattern tokens in 24 | let rest, acc = parse_fun_params is_let rest in 25 | rest, pat :: acc 26 | ;; 27 | 28 | let parse_let_fun_params = parse_fun_params true 29 | let parse_lambda_fun_params = parse_fun_params false 30 | 31 | let rec parse_match_arm tokens = 32 | let parse_from_arrow pat when_ = function 33 | | L.Arrow :: rest -> 34 | let rest, arm = parse_expression rest in 35 | (match rest with 36 | | L.Vertical :: rest -> 37 | let rest, acc = parse_match_arm rest in 38 | rest, (pat, when_, arm) :: acc 39 | | _ -> rest, [pat, when_, arm]) 40 | | _ -> failwith "could not find '->'" 41 | in 42 | let rest, pat = Pat.parse_pattern tokens in 43 | match rest with 44 | | L.When :: rest -> 45 | let rest, when_ = parse_expression rest in 46 | parse_from_arrow pat (Some when_) rest 47 | | _ -> parse_from_arrow pat None rest 48 | 49 | and parse_let_fun_body params = function 50 | | L.Function :: L.Vertical :: rest | L.Function :: rest -> 51 | let rest, arms = parse_match_arm rest in 52 | let anon_var = "_function_match" in 53 | ( rest 54 | , params @ [Tree.Pattern.Var anon_var] 55 | , T.Match (T.Var (Tree.Path.single anon_var), arms) ) 56 | | rest -> 57 | let rest, body = parse_expression rest in 58 | rest, params, body 59 | 60 | and parse_let_bindings rest = 61 | let rec parse_until_in rest = 62 | let rest, bind = Pat.parse_pattern rest in 63 | let rest, params = parse_let_fun_params rest in 64 | let rest, params, lhs = parse_let_fun_body params rest in 65 | match rest with 66 | | L.And :: rest -> 67 | let rest, acc = parse_until_in rest in 68 | rest, (bind, params, lhs) :: acc 69 | | rest -> rest, [bind, params, lhs] 70 | and conv_params (bind, params, lhs) = 71 | match params with 72 | | h :: t -> 73 | (match bind with 74 | | Tree.Pattern.Var ident -> T.FunBind (ident, h, params_to_lambdas lhs t) 75 | | _ -> failwith "only variables are allowed to bind functions") 76 | | [] -> T.VarBind (bind, lhs) 77 | in 78 | let rest, acc = parse_until_in rest in 79 | rest, List.map conv_params acc 80 | 81 | and parse_rec = function L.Rec :: rest -> rest, true | tokens -> tokens, false 82 | 83 | and parse_in = function 84 | | L.In :: rest -> parse_expression rest 85 | | _ -> failwith "could not find `in`" 86 | 87 | and parse_fields tokens = 88 | let continue path expr = function 89 | | L.Semicolon :: rest -> 90 | let rest, acc = parse_fields rest in 91 | rest, (path, expr) :: acc 92 | | rest -> rest, [path, expr] 93 | in 94 | match Path.try_parse_path tokens with 95 | | L.Equal :: rest, Some path -> 96 | let rest, expr = parse_tuple rest in 97 | continue path expr rest 98 | | rest, None -> rest, [] 99 | | rest, Some path -> continue path (T.Var (Tree.Path.last_path path)) rest 100 | 101 | and parse_record tokens = 102 | let parse_value tokens = 103 | let rest, fields = parse_fields tokens in 104 | rest, T.Record fields 105 | and try_parse_with tokens = 106 | let rest, expr = parse_tuple tokens in 107 | match rest with 108 | | L.With :: rest -> 109 | let rest, fields = parse_fields rest in 110 | rest, Some (T.RecordUpdate (expr, fields)) 111 | | _ -> tokens, None 112 | in 113 | let aux tokens = 114 | let rest, v_opt = try_parse_with tokens in 115 | match v_opt with Some v -> rest, v | None -> parse_value tokens 116 | in 117 | let rest, v = match tokens with L.LBrace :: rest | rest -> aux rest in 118 | match rest with L.RBrace :: rest -> rest, v | _ -> failwith "could not find `}`" 119 | 120 | and try_parse_literal tokens = 121 | match tokens with 122 | | L.IntLiteral num :: tokens -> tokens, Some (T.Int num) 123 | (* TODO: Add boolean value *) 124 | | L.BoolLiteral b :: tokens -> tokens, Some (T.Int (if b then 1 else 0)) 125 | (* TODO: Add char value *) 126 | | L.CharLiteral c :: tokens -> tokens, Some (T.Int (Char.code c)) 127 | | L.StringLiteral s :: tokens -> tokens, Some (T.String s) 128 | | L.FormatStringLiteral s :: tokens -> tokens, Some (T.Format s) 129 | | L.LowerIdent ident :: rest -> rest, Some (T.Var (Tree.Path.single ident)) 130 | | L.CapitalIdent _ :: _ -> 131 | (match Path.try_parse_path tokens with 132 | | rest, None -> rest, None 133 | | rest, Some path when Tree.Path.is_capitalized path -> 134 | (* Ctor with param should be parsed in parse_ctor_with_param *) 135 | rest, Some (T.Ctor (path, None)) 136 | | rest, Some path -> rest, Some (T.Var path)) 137 | | L.LBrace :: rest -> 138 | let rest, r = parse_record rest in 139 | rest, Some r 140 | | L.LArray :: rest -> 141 | let rec aux = function 142 | | L.RArray :: rest -> rest, [] 143 | | L.Semicolon :: rest -> aux rest 144 | | tokens -> 145 | let rest, v = parse_tuple tokens in 146 | let rest, acc = aux rest in 147 | rest, v :: acc 148 | in 149 | let rest, l = aux rest in 150 | rest, Some (T.Array l) 151 | | L.LBracket :: rest -> 152 | let rec aux = function 153 | | L.RBracket :: rest -> rest, T.Nil 154 | | L.Semicolon :: rest -> aux rest 155 | | tokens -> 156 | let rest, lhs = parse_tuple tokens in 157 | let rest, rhs = aux rest in 158 | rest, T.BinOp (Binop.Cons, lhs, rhs) 159 | in 160 | let rest, l = aux rest in 161 | rest, Some l 162 | | L.LParen :: L.RParen :: tokens -> tokens, Some (T.Tuple []) 163 | | L.LParen :: tokens -> 164 | let rest, v = parse_expression tokens in 165 | (match rest with L.RParen :: rest -> rest, Some v | _ -> rest, None) 166 | | _ -> tokens, None 167 | 168 | and try_parse_dot tokens = 169 | let rest, lhs_opt = try_parse_literal tokens in 170 | let rec aux lhs = function 171 | | L.Dot :: L.LowerIdent ident :: rest -> 172 | aux (T.RecordField (lhs, Tree.Path.single ident)) rest 173 | | L.Dot :: L.LBracket :: rest -> 174 | let rest, rhs = parse_expression rest in 175 | (match rest with 176 | | L.RBracket :: rest -> aux (T.BinOp (Binop.StringIndex, lhs, rhs)) rest 177 | | _ -> tokens, None) 178 | | L.Dot :: L.LParen :: rest -> 179 | let rest, rhs = parse_expression rest in 180 | (match rest with 181 | | L.RParen :: rest -> aux (T.BinOp (Binop.ArrayIndex, lhs, rhs)) rest 182 | | _ -> tokens, None) 183 | | rest -> rest, Some lhs 184 | in 185 | match lhs_opt with Some lhs -> aux lhs rest | None -> rest, None 186 | 187 | and parse_dot tokens = 188 | match try_parse_dot tokens with 189 | | tokens, Some v -> tokens, v 190 | | h :: _, None -> 191 | failwith @@ Printf.sprintf "unexpected token: '%s'" (L.string_of_token h) 192 | | [], None -> failwith "Empty input" 193 | 194 | and parse_app tokens = 195 | let rest, f = parse_dot tokens in 196 | let rec aux lhs tokens = 197 | match try_parse_dot tokens with 198 | | rest, Some p -> aux (T.App (lhs, p)) rest 199 | | rest, None -> rest, lhs 200 | in 201 | aux f rest 202 | 203 | and parse_ctor_with_param tokens = 204 | match tokens with 205 | | L.CapitalIdent _ :: _ -> 206 | (match Path.try_parse_path tokens with 207 | | rest, Some path when Tree.Path.is_capitalized path -> 208 | (* Ctor without param should be parsed in parse_literal *) 209 | (match try_parse_dot rest with 210 | | rest, Some p -> rest, T.Ctor (path, Some p) 211 | | _, None -> parse_app tokens) 212 | | _ -> parse_app tokens) 213 | | _ -> parse_app tokens 214 | 215 | and parse_prefix = function 216 | | L.Minus :: rest -> 217 | let rest, expr = parse_prefix rest in 218 | rest, T.UnaryOp (Uop.Negate, expr) 219 | | L.Plus :: rest -> 220 | let rest, expr = parse_prefix rest in 221 | rest, T.UnaryOp (Uop.Positate, expr) 222 | | tokens -> parse_ctor_with_param tokens 223 | 224 | and parse_mult tokens = 225 | let tokens, lhs = parse_prefix tokens in 226 | let rec aux lhs tokens = 227 | match tokens with 228 | | L.Star :: rest -> 229 | let rest, rhs = parse_prefix rest in 230 | aux (T.BinOp (Binop.Mul, lhs, rhs)) rest 231 | | L.Slash :: rest -> 232 | let rest, rhs = parse_prefix rest in 233 | aux (T.BinOp (Binop.Div, lhs, rhs)) rest 234 | | L.Mod :: rest -> 235 | let rest, rhs = parse_prefix rest in 236 | aux (T.BinOp (Binop.Mod, lhs, rhs)) rest 237 | | _ -> tokens, lhs 238 | in 239 | aux lhs tokens 240 | 241 | and parse_add tokens = 242 | let tokens, lhs = parse_mult tokens in 243 | let rec aux lhs tokens = 244 | match tokens with 245 | | L.Plus :: rest -> 246 | let rest, rhs = parse_mult rest in 247 | aux (T.BinOp (Binop.Add, lhs, rhs)) rest 248 | | L.Minus :: rest -> 249 | let rest, rhs = parse_mult rest in 250 | aux (T.BinOp (Binop.Sub, lhs, rhs)) rest 251 | | _ -> tokens, lhs 252 | in 253 | aux lhs tokens 254 | 255 | and parse_cons tokens = 256 | let tokens, lhs = parse_add tokens in 257 | match tokens with 258 | | L.DoubleColon :: tokens -> 259 | let tokens, rhs = parse_cons tokens in 260 | tokens, T.BinOp (Binop.Cons, lhs, rhs) 261 | | _ -> tokens, lhs 262 | 263 | and parse_infix tokens = 264 | let tokens, lhs = parse_cons tokens in 265 | let rec aux lhs tokens = 266 | match tokens with 267 | | L.InfixSymbol sym :: rest -> 268 | let rest, rhs = parse_cons rest in 269 | aux (T.BinOp (Binop.Custom (Tree.Path.single sym), lhs, rhs)) rest 270 | | _ -> tokens, lhs 271 | in 272 | aux lhs tokens 273 | 274 | and parse_equal tokens = 275 | let tokens, lhs = parse_infix tokens in 276 | let rec aux lhs tokens = 277 | match tokens with 278 | | L.Equal :: rest -> 279 | let rest, rhs = parse_infix rest in 280 | aux (T.BinOp (Binop.Equal, lhs, rhs)) rest 281 | | L.NotEqual :: rest -> 282 | let rest, rhs = parse_infix rest in 283 | aux (T.BinOp (Binop.NotPhysicalEqual, lhs, rhs)) rest 284 | | L.Lt :: rest -> 285 | let rest, rhs = parse_infix rest in 286 | aux (T.BinOp (Binop.Lt, lhs, rhs)) rest 287 | | L.Gt :: rest -> 288 | let rest, rhs = parse_infix rest in 289 | aux (T.BinOp (Binop.Gt, lhs, rhs)) rest 290 | | _ -> tokens, lhs 291 | in 292 | aux lhs tokens 293 | 294 | and parse_and tokens = 295 | let tokens, lhs = parse_equal tokens in 296 | match tokens with 297 | | L.DoubleAnd :: tokens -> 298 | let tokens, rhs = parse_and tokens in 299 | tokens, T.BinOp (Binop.And, lhs, rhs) 300 | | _ -> tokens, lhs 301 | 302 | and parse_or tokens = 303 | let tokens, lhs = parse_and tokens in 304 | match tokens with 305 | | L.DoubleVertical :: tokens -> 306 | let tokens, rhs = parse_or tokens in 307 | tokens, T.BinOp (Binop.Or, lhs, rhs) 308 | | _ -> tokens, lhs 309 | 310 | and parse_assign tokens = 311 | let tokens, lhs = parse_or tokens in 312 | match tokens with 313 | | L.LeftArrow :: tokens -> 314 | let tokens, rhs = parse_tuple tokens in 315 | (match lhs with 316 | | T.RecordField (e, field) -> tokens, T.RecordFieldAssign (e, field, rhs) 317 | | T.BinOp (Binop.ArrayIndex, e, idx) -> tokens, T.ArrayAssign (e, idx, rhs) 318 | | _ -> failwith "lhs of <- must be record field or array index") 319 | | _ -> tokens, lhs 320 | 321 | and parse_if = function 322 | | L.If :: rest -> 323 | let rest, cond = parse_expression rest in 324 | (match rest with 325 | | L.Then :: rest -> 326 | let rest, then_ = parse_tuple rest in 327 | (match rest with 328 | | L.Else :: rest -> 329 | let rest, else_ = parse_tuple rest in 330 | rest, T.IfThenElse (cond, then_, else_) 331 | | _ -> 332 | (* (if c then v) *) 333 | (* is converted to *) 334 | (* (if c then v; () else ()) *) 335 | let unit_ = T.Tuple [] in 336 | let then_ = T.BinOp (Binop.Follow, then_, unit_) in 337 | rest, T.IfThenElse (cond, then_, unit_)) 338 | | _ -> failwith "could not find 'then'") 339 | | tokens -> parse_assign tokens 340 | 341 | and parse_match = function 342 | | L.Match :: rest -> 343 | let rest, expr = parse_expression rest in 344 | (match rest with 345 | | L.With :: L.Vertical :: rest | L.With :: rest -> 346 | let rest, arms = parse_match_arm rest in 347 | rest, T.Match (expr, arms) 348 | | _ -> failwith "could not find 'with'") 349 | | tokens -> parse_if tokens 350 | 351 | and parse_let = function 352 | | L.Fun :: rest -> 353 | let rest, params = parse_lambda_fun_params rest in 354 | let rest, params, body = parse_let_fun_body params rest in 355 | rest, params_to_lambdas body params 356 | | L.Let :: rest -> 357 | let rest, is_rec = parse_rec rest in 358 | let rest, binds = parse_let_bindings rest in 359 | let rest, rhs = parse_in rest in 360 | rest, T.LetAnd (is_rec, binds, rhs) 361 | | tokens -> parse_match tokens 362 | 363 | and parse_tuple tokens = 364 | let rec aux = function 365 | | L.Comma :: rest -> 366 | let rest, curr = parse_let rest in 367 | let rest, tail = aux rest in 368 | rest, curr :: tail 369 | | tokens -> tokens, [] 370 | in 371 | let rest, init = parse_let tokens in 372 | let rest, values = aux rest in 373 | match values with [] -> rest, init | _ -> rest, T.Tuple (init :: values) 374 | 375 | and parse_follow tokens = 376 | let tokens, lhs = parse_tuple tokens in 377 | let rec aux lhs tokens = 378 | match tokens with 379 | | L.Semicolon :: rest -> 380 | let rest, rhs = parse_tuple rest in 381 | aux (T.BinOp (Binop.Follow, lhs, rhs)) rest 382 | | _ -> tokens, lhs 383 | in 384 | aux lhs tokens 385 | 386 | and parse_expression tokens = parse_follow tokens 387 | 388 | let f = parse_expression 389 | -------------------------------------------------------------------------------- /mlml/codegen/codegen.ml: -------------------------------------------------------------------------------- 1 | open Builder 2 | module P = Parser 3 | module Expr = Tree.Expression 4 | module Mod = Tree.Module 5 | module Binop = Tree.Binop 6 | module Uop = Tree.Unaryop 7 | module B = Output_buffer 8 | module SS = Tree.Simple_set 9 | 10 | let rec codegen_binop ctx buf lhs rhs = function 11 | | Binop.Add -> 12 | (* make(a) + make(b) *) 13 | (* = (2a + 1) + (2b + 1) *) 14 | (* = 2(a + b) + 2 *) 15 | (* = make(a + b) + 1 *) 16 | let lhs = codegen_expr ctx buf lhs in 17 | let rhs, free = codegen_expr ctx buf rhs |> turn_into_register ctx buf in 18 | B.emit_inst_fmt buf "addq %s, %s" (string_of_value lhs) (string_of_register rhs); 19 | B.emit_inst_fmt buf "decq %s" (string_of_register rhs); 20 | let s = turn_into_stack ctx buf (RegisterValue rhs) in 21 | free ctx; 22 | StackValue s 23 | | Binop.Sub -> 24 | (* make(a) - make(b) *) 25 | (* = (2a + 1) - (2b + 1) *) 26 | (* = 2(a - b) *) 27 | (* = make(a - b) - 1 *) 28 | let rhs = codegen_expr ctx buf rhs in 29 | let lhs, free = codegen_expr ctx buf lhs |> turn_into_register ctx buf in 30 | B.emit_inst_fmt buf "subq %s, %s" (string_of_value rhs) (string_of_register lhs); 31 | B.emit_inst_fmt buf "incq %s" (string_of_register lhs); 32 | let s = turn_into_stack ctx buf (RegisterValue lhs) in 33 | free ctx; 34 | StackValue s 35 | | Binop.Mul -> 36 | (* make(a*b) *) 37 | (* = 1/2 * (make(a) - 1) * make(b) + 1 *) 38 | let lhs, free_l = codegen_expr ctx buf lhs |> turn_into_register ctx buf in 39 | let rhs, free_r = codegen_expr ctx buf rhs |> turn_into_register ctx buf in 40 | B.emit_inst_fmt buf "sarq $1, %s" (string_of_register lhs); 41 | B.emit_inst_fmt buf "decq %s" (string_of_register rhs); 42 | B.emit_inst_fmt buf "imulq %s, %s" (string_of_register lhs) (string_of_register rhs); 43 | free_l ctx; 44 | B.emit_inst_fmt buf "incq %s" (string_of_register rhs); 45 | let s = turn_into_stack ctx buf (RegisterValue rhs) in 46 | free_r ctx; 47 | StackValue s 48 | | Binop.Div -> 49 | let lhs, free_l = codegen_expr ctx buf lhs |> turn_into_register ctx buf in 50 | let rhs, free_r = codegen_expr ctx buf rhs |> turn_into_register ctx buf in 51 | restore_marked_int buf (RegisterValue lhs); 52 | restore_marked_int buf (RegisterValue rhs); 53 | let quot = StackValue (alloc_stack ctx) in 54 | calc_div ctx buf lhs rhs (Some quot) None; 55 | free_l ctx; 56 | free_r ctx; 57 | make_marked_int buf quot; 58 | quot 59 | | Binop.Mod -> 60 | let lhs, free_l = codegen_expr ctx buf lhs |> turn_into_register ctx buf in 61 | let rhs, free_r = codegen_expr ctx buf rhs |> turn_into_register ctx buf in 62 | restore_marked_int buf (RegisterValue lhs); 63 | restore_marked_int buf (RegisterValue rhs); 64 | let rem = StackValue (alloc_stack ctx) in 65 | calc_div ctx buf lhs rhs None (Some rem); 66 | free_l ctx; 67 | free_r ctx; 68 | make_marked_int buf rem; 69 | rem 70 | | Binop.Or -> codegen_expr ctx buf (Expr.IfThenElse (lhs, lhs, rhs)) 71 | | Binop.And -> codegen_expr ctx buf (Expr.IfThenElse (lhs, rhs, lhs)) 72 | | Binop.Follow -> 73 | ignore @@ codegen_expr ctx buf lhs; 74 | codegen_expr ctx buf rhs 75 | | Binop.NotPhysicalEqual -> 76 | let lhs = codegen_expr ctx buf lhs in 77 | let rhs = codegen_expr ctx buf rhs in 78 | comparison_to_value ctx buf Ne lhs rhs 79 | | Binop.Equal -> 80 | let lhs = codegen_expr ctx buf lhs in 81 | let rhs = codegen_expr ctx buf rhs in 82 | let ret = call_runtime ctx buf "equal" [lhs; rhs] in 83 | StackValue (turn_into_stack ctx buf (RegisterValue ret)) 84 | | Binop.Lt -> 85 | let lhs = codegen_expr ctx buf lhs in 86 | let rhs = codegen_expr ctx buf rhs in 87 | comparison_to_value ctx buf Gt lhs rhs 88 | | Binop.Gt -> 89 | let lhs = codegen_expr ctx buf lhs in 90 | let rhs = codegen_expr ctx buf rhs in 91 | comparison_to_value ctx buf Lt lhs rhs 92 | | Binop.Cons -> 93 | let lhs = codegen_expr ctx buf lhs in 94 | let rhs = codegen_expr ctx buf rhs in 95 | let reg = alloc_register ctx in 96 | let reg_value = RegisterValue reg in 97 | (* size, flag, lhs, rhs -> 8 * 4 *) 98 | alloc_heap_ptr_constsize ctx buf 32 reg_value; 99 | (* data size *) 100 | assign_to_address ctx buf (ConstantValue (24 * 2)) reg_value 0; 101 | (* nil -> 0, cons -> 1 *) 102 | assign_to_address ctx buf (make_marked_const 1) reg_value (-8); 103 | (* actual data *) 104 | assign_to_address ctx buf lhs reg_value (-16); 105 | assign_to_address ctx buf rhs reg_value (-24); 106 | let s = StackValue (turn_into_stack ctx buf reg_value) in 107 | free_register reg ctx; 108 | s 109 | | Binop.StringIndex -> 110 | let lhs = codegen_expr ctx buf lhs in 111 | let rhs = codegen_expr ctx buf rhs in 112 | let ret = call_runtime_mlml ctx buf "get_string" [lhs; rhs] in 113 | StackValue (turn_into_stack ctx buf (RegisterValue ret)) 114 | | Binop.ArrayIndex -> 115 | let lhs = codegen_expr ctx buf lhs in 116 | let rhs = codegen_expr ctx buf rhs in 117 | let ret = call_runtime_mlml ctx buf "get_array" [lhs; rhs] in 118 | StackValue (turn_into_stack ctx buf (RegisterValue ret)) 119 | | Binop.Custom _ -> failwith "custom infix operator is left in codegen" 120 | 121 | and codegen_unaryop ctx buf e = function 122 | | Uop.Positate -> codegen_expr ctx buf e 123 | | Uop.Negate -> 124 | let e = codegen_expr ctx buf e in 125 | let res = constant_value 2 |> assign_to_new_register ctx buf in 126 | B.emit_inst_fmt buf "subq %s, %s" (string_of_value e) (string_of_register res); 127 | free_register res ctx; 128 | turn_into_stack ctx buf (RegisterValue res) |> stack_value 129 | 130 | and codegen_expr ctx buf = function 131 | | Expr.Int num -> make_marked_const num 132 | | Expr.String s -> make_string_const ctx buf s 133 | | Expr.Format _ -> failwith "format string is left in codegen" 134 | | Expr.BinOp (op, lhs, rhs) -> codegen_binop ctx buf lhs rhs op 135 | | Expr.UnaryOp (op, e) -> codegen_unaryop ctx buf e op 136 | | Expr.App (lhs, rhs) -> 137 | let lhs = codegen_expr ctx buf lhs in 138 | let rhs = codegen_expr ctx buf rhs in 139 | let ret = safe_call ctx buf (Printf.sprintf "*%s" (string_of_value lhs)) [rhs] in 140 | StackValue (turn_into_stack ctx buf (RegisterValue ret)) 141 | | Expr.Var ident -> StackValue (get_variable ctx ident) 142 | | Expr.LetAnd (is_rec, l, rhs) -> 143 | let pats, values = emit_let_binding_values ctx buf is_rec l in 144 | let def (name, ptr) = define_variable ctx buf name ptr in 145 | let undef (name, _) = undef_variable ctx name in 146 | List.iter def values; 147 | let rhs = codegen_expr ctx buf rhs in 148 | List.iter undef values; 149 | List.iter (undef_variable_pattern ctx) pats; 150 | rhs 151 | | Expr.Lambda (param, body) -> emit_function_value ctx buf false "_lambda" param body 152 | | Expr.IfThenElse (cond, then_, else_) -> 153 | let cond = codegen_expr ctx buf cond in 154 | let eval_stack = push_to_stack ctx buf (ConstantValue 0) in 155 | let else_label = new_unnamed_label ctx in 156 | let join_label = new_unnamed_label ctx in 157 | branch_if_falsy ctx buf cond else_label; 158 | (* then block *) 159 | let then_ = codegen_expr ctx buf then_ in 160 | assign_to_stack ctx buf then_ eval_stack; 161 | B.emit_inst_fmt buf "jmp %s" (string_of_label join_label); 162 | (* else block *) 163 | start_label buf else_label; 164 | let else_ = codegen_expr ctx buf else_ in 165 | assign_to_stack ctx buf else_ eval_stack; 166 | start_label buf join_label; 167 | StackValue eval_stack 168 | (* array is internally identical to tuple *) 169 | | Expr.Array values | Expr.Tuple values -> 170 | let values = List.map (codegen_expr ctx buf) values in 171 | make_tuple_const ctx buf values 172 | | Expr.Ctor (name, value) -> 173 | let value = 174 | match value with 175 | | Some value -> codegen_expr ctx buf value 176 | (* TODO: Better representation of ctor without parameters *) 177 | | None -> make_marked_const 0 178 | in 179 | let idx = get_ctor_index ctx name in 180 | let reg = alloc_register ctx in 181 | let reg_value = RegisterValue reg in 182 | (* three 64-bit values -> 24 *) 183 | alloc_heap_ptr_constsize ctx buf 24 reg_value; 184 | (* size of data (2 * 8) *) 185 | assign_to_address ctx buf (ConstantValue (16 * 2)) reg_value 0; 186 | (* ctor index *) 187 | assign_to_address ctx buf (make_marked_const idx) reg_value (-8); 188 | (* the value *) 189 | assign_to_address ctx buf value reg_value (-16); 190 | let s = StackValue (turn_into_stack ctx buf reg_value) in 191 | free_register reg ctx; 192 | s 193 | | Expr.Match (v, arms) -> 194 | let v = codegen_expr ctx buf v in 195 | let join_label = new_unnamed_label ctx in 196 | let eval_stack = push_to_stack ctx buf (ConstantValue 0) in 197 | let rec aux = function 198 | | (pat, when_, rhs) :: t -> 199 | let next_label = new_unnamed_label ctx in 200 | pattern_match ctx buf pat v next_label; 201 | (match when_ with 202 | | Some cond -> 203 | let cond = codegen_expr ctx buf cond in 204 | branch_if_falsy ctx buf cond next_label 205 | | None -> ()); 206 | let rhs = codegen_expr ctx buf rhs in 207 | assign_to_stack ctx buf rhs eval_stack; 208 | B.emit_inst_fmt buf "jmp %s" (string_of_label join_label); 209 | start_label buf next_label; 210 | aux t 211 | | [] -> 212 | B.emit_inst_fmt buf "jmp %s" (string_of_label match_fail_label); 213 | start_label buf join_label; 214 | StackValue eval_stack 215 | in 216 | aux arms 217 | | Expr.Nil -> 218 | let reg = alloc_register ctx in 219 | let reg_value = RegisterValue reg in 220 | (* size, flag -> 8 * 2 *) 221 | alloc_heap_ptr_constsize ctx buf 16 reg_value; 222 | (* data size *) 223 | assign_to_address ctx buf (ConstantValue (8 * 2)) reg_value 0; 224 | (* nil -> 0, cons -> 1 *) 225 | assign_to_address ctx buf (make_marked_const 0) reg_value (-8); 226 | let s = StackValue (turn_into_stack ctx buf reg_value) in 227 | free_register reg ctx; 228 | s 229 | | Expr.Record fields -> 230 | let trans (name, expr) = get_field_index ctx name, codegen_expr ctx buf expr in 231 | let cmp (i1, _) (i2, _) = compare i1 i2 in 232 | List.map trans fields |> List.sort cmp |> List.map snd |> make_tuple_const ctx buf 233 | | Expr.RecordField (v, field) -> 234 | let v = codegen_expr ctx buf v in 235 | let idx = get_field_index ctx field in 236 | let reg = alloc_register ctx in 237 | read_from_address ctx buf v (RegisterValue reg) (-(idx + 1) * 8); 238 | let s = StackValue (turn_into_stack ctx buf (RegisterValue reg)) in 239 | free_register reg ctx; 240 | s 241 | | Expr.RecordFieldAssign (v, field, e) -> 242 | let v = codegen_expr ctx buf v in 243 | let e = codegen_expr ctx buf e in 244 | let idx = get_field_index ctx field in 245 | assign_to_address ctx buf e v (-(idx + 1) * 8); 246 | (* Evaluates to unit *) 247 | make_tuple_const ctx buf [] 248 | | Expr.RecordUpdate (target, fields) -> 249 | let target = codegen_expr ctx buf target in 250 | let reg = alloc_register ctx in 251 | shallow_copy ctx buf target (RegisterValue reg); 252 | let aux (name, v) = 253 | let v = codegen_expr ctx buf v in 254 | let i = get_field_index ctx name in 255 | assign_to_address ctx buf v (RegisterValue reg) (-(i + 1) * 8) 256 | in 257 | List.iter aux fields; 258 | let s = StackValue (turn_into_stack ctx buf (RegisterValue reg)) in 259 | free_register reg ctx; 260 | s 261 | | Expr.ArrayAssign (ary, idx, v) -> 262 | let ary = codegen_expr ctx buf ary in 263 | let idx = codegen_expr ctx buf idx in 264 | let v = codegen_expr ctx buf v in 265 | let ret = call_runtime_mlml ctx buf "set_array" [ary; idx; v] in 266 | StackValue (turn_into_stack ctx buf (RegisterValue ret)) 267 | 268 | and codegen_definition ctx buf = function 269 | | Mod.LetAnd (is_rec, l) -> 270 | let _, values = emit_let_binding_values ctx buf is_rec l in 271 | let def (name, ptr) = define_variable ctx buf name ptr in 272 | List.iter def values 273 | | Mod.TypeDef l -> 274 | let aux (_, _, def) = codegen_type_def ctx buf def in 275 | List.iter aux l 276 | | Mod.External (name, _ty, decl) -> 277 | let ptr = alloc_register ctx in 278 | label_ptr_to_register buf (Label decl) ptr; 279 | define_variable ctx buf name (RegisterValue ptr); 280 | free_register ptr ctx 281 | | Mod.Module _ -> failwith "Module is left!" 282 | | Mod.Open _ -> failwith "Open is left!" 283 | 284 | and codegen_type_def ctx _buf = function 285 | | Mod.Variant variants -> 286 | let aux i (ctor, _) = define_ctor ctx ctor i in 287 | List.iteri aux variants 288 | | Mod.Record fields -> 289 | let aux i (_is_mut, name, _) = define_field ctx name i in 290 | List.iteri aux fields 291 | | Mod.Alias _ -> () 292 | 293 | and codegen_module_item ctx buf = function 294 | | Mod.Definition def -> codegen_definition ctx buf def 295 | | Mod.Expression expr -> ignore @@ codegen_expr ctx buf expr 296 | 297 | and codegen_module ctx buf = List.iter (codegen_module_item ctx buf) 298 | 299 | and emit_function_with ctx main_buf label fn = 300 | let old_env = use_env ctx @@ new_local_env () in 301 | let buf = B.create () in 302 | let ret_label = new_unnamed_label ctx in 303 | start_global_label buf label; 304 | B.emit_inst_fmt buf "pushq %s" (register_name "rbp"); 305 | B.emit_inst_fmt buf "movq %s, %s" (register_name "rsp") (register_name "rbp"); 306 | let subq_place = B.emit_placeholder buf in 307 | (* save registers (non-volatile registers) *) 308 | let exclude_rbp_rsp = function 309 | | Register "rbp" | Register "rsp" -> false 310 | | _ -> true 311 | in 312 | let saver r = r, turn_into_stack ctx buf (RegisterValue r) in 313 | let saved_stacks = 314 | non_volatile_registers |> SS.filter exclude_rbp_rsp |> SS.elements |> List.map saver 315 | in 316 | fn ctx buf label ret_label; 317 | start_label buf ret_label; 318 | let stack_used = ctx.current_env.current_stack in 319 | let restore (r, s) = assign_to_register buf (StackValue s) r in 320 | List.iter restore saved_stacks; 321 | B.emit_inst_fmt buf "movq %s, %s" (register_name "rbp") (register_name "rsp"); 322 | B.emit_inst_fmt buf "popq %s" (register_name "rbp"); 323 | B.emit_inst buf "ret"; 324 | ignore @@ use_env ctx old_env; 325 | B.substitute buf subq_place (B.Inst (Printf.sprintf "subq $%d, %%rsp" (-stack_used))); 326 | B.prepend_buffer main_buf buf 327 | 328 | and emit_let_bindings ctx buf is_rec l = 329 | (* TODO: remove `failwith "unreachable"` *) 330 | let funs, vars = List.partition Expr.is_fun_bind l in 331 | let make_convenient_data = function 332 | | Expr.FunBind (name, param, body) -> 333 | let label = new_label ctx name in 334 | (name, label), (label, param, body) 335 | | _ -> failwith "unreachable" 336 | in 337 | let labels, funs = List.map make_convenient_data funs |> List.split in 338 | let emit param ast ctx buf _label _ = 339 | let arg = nth_arg_stack ctx buf 0 in 340 | pattern_match ctx buf param (StackValue arg) match_fail_label; 341 | (if is_rec 342 | then 343 | (* forward definition of functions *) 344 | let aux (name, label) = 345 | let ptr = function_ptr ctx buf label in 346 | define_variable ctx buf name ptr 347 | in 348 | List.iter aux labels); 349 | let value = codegen_expr ctx buf ast in 350 | assign_to_register buf value ret_register 351 | in 352 | let aux_vars = function 353 | | Expr.VarBind (pat, body) -> 354 | let body = codegen_expr ctx buf body in 355 | pattern_match ctx buf pat body match_fail_label; 356 | pat 357 | | _ -> failwith "unreachable" 358 | in 359 | let aux_funs (label, param, body) = 360 | emit_function_with ctx buf label (emit param body) 361 | in 362 | (* emit variables first. *) 363 | (* functions can be forward reference, whereas variables can't. *) 364 | let pats = List.map aux_vars vars in 365 | List.iter aux_funs funs; 366 | pats, labels 367 | 368 | and emit_function ctx main_buf is_rec name param ast = 369 | emit_let_bindings ctx main_buf is_rec [Expr.FunBind (name, param, ast)] 370 | |> snd 371 | |> List.hd 372 | |> snd 373 | 374 | and emit_let_binding_values ctx buf is_rec l = 375 | let pats, labels = emit_let_bindings ctx buf is_rec l in 376 | let conv (name, label) = name, function_ptr ctx buf label in 377 | pats, List.map conv labels 378 | 379 | and emit_function_value ctx buf is_rec name param ast = 380 | let label = emit_function ctx buf is_rec name param ast in 381 | function_ptr ctx buf label 382 | 383 | and emit_main ctx buf label items = 384 | let emit ctx buf _label _ = 385 | ignore @@ safe_call ctx buf "GC_init@PLT" []; 386 | let argc, free1 = nth_arg_register ctx 0 in 387 | let argv, free2 = nth_arg_register ctx 1 in 388 | ignore @@ call_runtime ctx buf "handle_argv" [RegisterValue argc; RegisterValue argv]; 389 | free1 ctx; 390 | free2 ctx; 391 | codegen_module ctx buf items; 392 | assign_to_register buf (ConstantValue 0) ret_register 393 | in 394 | emit_function_with ctx buf label emit 395 | ;; 396 | 397 | let emit_runtime ctx buf name f = 398 | let label = new_label ctx @@ make_name_of_runtime name in 399 | emit_function_with ctx buf label f 400 | ;; 401 | 402 | let f ast = 403 | let buf = B.create () in 404 | let ctx = new_context () in 405 | Runtime.emit_all (emit_runtime ctx buf); 406 | emit_main ctx buf (Label "main") ast; 407 | B.prepend_sub_inst buf ".section .rodata"; 408 | B.prepend_inst buf ".text"; 409 | B.contents buf 410 | ;; 411 | -------------------------------------------------------------------------------- /mlml/codegen/builder.ml: -------------------------------------------------------------------------------- 1 | module P = Parser 2 | module Pat = Tree.Pattern 3 | module B = Output_buffer 4 | module SS = Tree.Simple_set 5 | 6 | type register = Register of string 7 | type stack = Stack of int 8 | type label = Label of string 9 | 10 | type value = 11 | | StackValue of stack 12 | | RegisterValue of register 13 | | ConstantValue of int 14 | 15 | let stack_value s = StackValue s 16 | let register_value r = RegisterValue r 17 | let constant_value c = ConstantValue c 18 | let register_name r = Printf.sprintf "%%%s" r 19 | let string_of_register = function Register n -> register_name n 20 | let string_of_stack = function Stack num -> Printf.sprintf "%d(%%rbp)" num 21 | let string_of_label = function Label n -> n 22 | let string_of_constant num = "$" ^ string_of_int num 23 | 24 | let string_of_value = function 25 | | StackValue num -> string_of_stack num 26 | | RegisterValue kind -> string_of_register kind 27 | | ConstantValue num -> string_of_constant num 28 | ;; 29 | 30 | (* function-local environment *) 31 | type local_env = 32 | { mutable unused_registers : register SS.t 33 | ; mutable current_stack : int 34 | ; mutable vars : (string, stack) Hashtbl.t } 35 | 36 | type context = 37 | { mutable used_labels : label SS.t 38 | ; mutable ctors : (string, int) Hashtbl.t 39 | ; mutable fields : (string, int) Hashtbl.t 40 | ; mutable current_env : local_env } 41 | 42 | let usable_registers = 43 | SS.of_list 44 | [Register "r8"; Register "r9"; Register "r10"; Register "r11"; Register "rdx"] 45 | ;; 46 | 47 | (* https://wiki.osdev.org/System_V_ABI#x86-64 *) 48 | let volatile_registers = 49 | SS.of_list 50 | [ Register "rax" 51 | ; Register "rdi" 52 | ; Register "rsi" 53 | ; Register "rdx" 54 | ; Register "rcx" 55 | ; Register "r8" 56 | ; Register "r9" 57 | ; Register "r10" 58 | ; Register "r11" ] 59 | ;; 60 | 61 | let non_volatile_registers = 62 | SS.of_list 63 | [ Register "rbx" 64 | ; Register "rsp" 65 | ; Register "rbp" 66 | ; Register "r12" 67 | ; Register "r13" 68 | ; Register "r14" 69 | ; Register "r15" ] 70 | ;; 71 | 72 | let ret_register = Register "rax" 73 | let make_name_of_runtime = Printf.sprintf "_mlml_%s" 74 | let match_fail_name = "match_fail" 75 | let match_fail_label = Label (make_name_of_runtime match_fail_name) 76 | let argv_label = Label (make_name_of_runtime "argv") 77 | 78 | let new_local_env () = 79 | {unused_registers = usable_registers; current_stack = -8; vars = Hashtbl.create 10} 80 | ;; 81 | 82 | let new_context () = 83 | { used_labels = SS.empty 84 | ; ctors = Hashtbl.create 32 85 | ; fields = Hashtbl.create 32 86 | ; current_env = new_local_env () } 87 | ;; 88 | 89 | let use_env ctx env = 90 | let old_env = ctx.current_env in 91 | ctx.current_env <- env; 92 | old_env 93 | ;; 94 | 95 | let escape_label_name name = 96 | let aux c = match c with 'a' .. 'z' | 'A' .. 'Z' | '_' | '.' -> c | _ -> '_' in 97 | String.map aux name 98 | ;; 99 | 100 | let new_label ctx name = 101 | let name = escape_label_name name in 102 | let is_used label = SS.mem label ctx.used_labels in 103 | let use_label label = 104 | ctx.used_labels <- SS.add label ctx.used_labels; 105 | label 106 | in 107 | let rec aux i = 108 | let label = Label (Printf.sprintf "%s%d" name i) in 109 | if is_used label then aux (i + 1) else use_label label 110 | in 111 | let raw = Label name in 112 | if is_used raw then aux 1 else use_label raw 113 | ;; 114 | 115 | let new_unnamed_label ctx = new_label ctx ".L" 116 | 117 | let use_register ctx reg = 118 | if SS.mem reg ctx.current_env.unused_registers 119 | then 120 | (ctx.current_env).unused_registers 121 | <- SS.filter (fun x -> x != reg) ctx.current_env.unused_registers 122 | else failwith @@ Printf.sprintf "Register '%s' is unavailable" (string_of_register reg) 123 | ;; 124 | 125 | let alloc_register context = 126 | match SS.choose_opt context.current_env.unused_registers with 127 | | Some h -> 128 | (context.current_env).unused_registers 129 | <- SS.remove h context.current_env.unused_registers; 130 | h 131 | | None -> failwith "Could not allocate register" 132 | ;; 133 | 134 | let free_register reg ctx = 135 | if not (SS.mem reg ctx.current_env.unused_registers) 136 | then (ctx.current_env).unused_registers <- SS.add reg ctx.current_env.unused_registers 137 | ;; 138 | 139 | let make_marked_int buf v = 140 | (* TODO: Use imul or add? *) 141 | B.emit_inst_fmt buf "shlq $1, %s" (string_of_value v); 142 | B.emit_inst_fmt buf "incq %s" (string_of_value v) 143 | ;; 144 | 145 | let calc_marked_const i = (i * 2) + 1 146 | let make_marked_const i = ConstantValue (calc_marked_const i) 147 | let restore_marked_int buf v = B.emit_inst_fmt buf "sarq $1, %s" (string_of_value v) 148 | let start_label buf label = B.emit buf (B.Label (string_of_label label)) 149 | 150 | let start_global_label buf label = 151 | B.emit_inst_fmt buf ".globl %s" (string_of_label label); 152 | start_label buf label 153 | ;; 154 | 155 | let assign_to_register buf v reg = 156 | B.emit_inst_fmt buf "movq %s, %s" (string_of_value v) (string_of_register reg) 157 | ;; 158 | 159 | let turn_into_register ctx buf = function 160 | | RegisterValue r -> r, ignore 161 | | v -> 162 | let new_register = alloc_register ctx in 163 | assign_to_register buf v new_register; 164 | new_register, free_register new_register 165 | ;; 166 | 167 | let assign_to_new_register ctx buf v = 168 | let r = alloc_register ctx in 169 | assign_to_register buf v r; 170 | r 171 | ;; 172 | 173 | let rec assign_to_stack ctx buf v stack = 174 | match v with 175 | | RegisterValue _ | ConstantValue _ -> 176 | B.emit_inst_fmt buf "movq %s, %s" (string_of_value v) (string_of_stack stack) 177 | | StackValue _ -> 178 | let reg, free = turn_into_register ctx buf v in 179 | assign_to_stack ctx buf (RegisterValue reg) stack; 180 | free ctx 181 | ;; 182 | 183 | let alloc_stack ctx = 184 | let c = ctx.current_env.current_stack in 185 | let s = Stack c in 186 | (ctx.current_env).current_stack <- c - 8; 187 | s 188 | ;; 189 | 190 | let push_to_stack ctx buf v = 191 | let s = alloc_stack ctx in 192 | assign_to_stack ctx buf v s; 193 | s 194 | ;; 195 | 196 | let turn_into_stack ctx buf = function StackValue s -> s | v -> push_to_stack ctx buf v 197 | 198 | let assign_to_value ctx buf a b = 199 | match a, b with 200 | | StackValue _, StackValue _ -> 201 | let reg = assign_to_new_register ctx buf a in 202 | B.emit_inst_fmt buf "movq %s, %s" (string_of_register reg) (string_of_value b); 203 | free_register reg ctx 204 | | _ -> B.emit_inst_fmt buf "movq %s, %s" (string_of_value a) (string_of_value b) 205 | ;; 206 | 207 | let assign_to_address ctx buf src dest offset = 208 | let src, free_src = turn_into_register ctx buf src in 209 | let dest, free_dest = turn_into_register ctx buf dest in 210 | B.emit_inst_fmt 211 | buf 212 | "movq %s, %d(%s)" 213 | (string_of_register src) 214 | offset 215 | (string_of_register dest); 216 | free_src ctx; 217 | free_dest ctx 218 | ;; 219 | 220 | let read_from_address ctx buf src dest_raw offset = 221 | let src, free_src = turn_into_register ctx buf src in 222 | let dest, free_dest = turn_into_register ctx buf dest_raw in 223 | B.emit_inst_fmt 224 | buf 225 | "movq %d(%s), %s" 226 | offset 227 | (string_of_register src) 228 | (string_of_register dest); 229 | free_src ctx; 230 | B.emit_inst_fmt buf "movq %s, %s" (string_of_register dest) (string_of_value dest_raw); 231 | free_dest ctx 232 | ;; 233 | 234 | let nth_arg_register context n = 235 | let r = 236 | match n with 237 | | 0 -> Register "rdi" 238 | | 1 -> Register "rsi" 239 | | 2 -> Register "rdx" 240 | | 3 -> Register "rcx" 241 | | 4 -> Register "r8" 242 | | 5 -> Register "r9" 243 | | _ -> failwith "Too many arguments" 244 | in 245 | if SS.mem r usable_registers 246 | then ( 247 | use_register context r; 248 | r, free_register r ) 249 | else r, ignore 250 | ;; 251 | 252 | let nth_arg_stack ctx buf n = 253 | let r, free = nth_arg_register ctx n in 254 | let s = turn_into_stack ctx buf (RegisterValue r) in 255 | free ctx; 256 | s 257 | ;; 258 | 259 | let safe_call ctx buf name args = 260 | (* save registers (used but not by arguments) *) 261 | (* volatile - unused - args - %rax *) 262 | let aux i v = 263 | let reg, free = nth_arg_register ctx i in 264 | assign_to_register buf v reg; 265 | reg, free 266 | in 267 | let arg_regs, free_fns = List.mapi aux args |> List.split in 268 | let filt x = 269 | not 270 | ( SS.mem x ctx.current_env.unused_registers 271 | || List.mem x arg_regs 272 | || x = ret_register ) 273 | in 274 | let regs_to_save = SS.filter filt volatile_registers in 275 | let saver x = 276 | let s = push_to_stack ctx buf (RegisterValue x) in 277 | x, s 278 | in 279 | (* save rsp after other regs *) 280 | let saved_regs = 281 | SS.elements regs_to_save |> List.cons (Register "rsp") |> List.map saver 282 | in 283 | (* change rsp to what it should be (rbp contains initial rsp stored at functions' head) *) 284 | B.emit_inst_fmt buf "leaq %d(%%rbp), %%rsp" ctx.current_env.current_stack; 285 | B.emit_inst_fmt buf "call %s" name; 286 | List.iter (fun f -> f ctx) free_fns; 287 | let restore (x, s) = assign_to_register buf (StackValue s) x in 288 | List.iter restore saved_regs; 289 | ret_register 290 | ;; 291 | 292 | let call_runtime ctx buf name = 293 | let real_name = make_name_of_runtime name in 294 | if SS.mem (Label real_name) ctx.used_labels 295 | then safe_call ctx buf real_name 296 | else 297 | failwith @@ Printf.sprintf "could not find a runtime function named '%s'" real_name 298 | ;; 299 | 300 | let define_ctor ctx ctor idx = Hashtbl.add ctx.ctors ctor idx 301 | 302 | let get_ctor_index ctx ctor = 303 | match Hashtbl.find_opt ctx.ctors ctor with 304 | | Some i -> i 305 | | None -> failwith @@ Printf.sprintf "could not find ctor named %s" ctor 306 | ;; 307 | 308 | let define_field ctx field idx = Hashtbl.add ctx.fields field idx 309 | 310 | let get_field_index ctx field = 311 | match Hashtbl.find_opt ctx.fields field with 312 | | Some i -> i 313 | | None -> failwith @@ Printf.sprintf "could not find field named %s" field 314 | ;; 315 | 316 | let define_variable ctx buf ident v = 317 | (* TODO: Print warning when ident is accidentally "_" *) 318 | let s = turn_into_stack ctx buf v in 319 | Hashtbl.add ctx.current_env.vars ident s 320 | ;; 321 | 322 | let undef_variable ctx ident = Hashtbl.remove ctx.current_env.vars ident 323 | 324 | let get_variable ctx ident = 325 | match Hashtbl.find_opt ctx.current_env.vars ident with 326 | | Some s -> s 327 | | None -> failwith @@ Printf.sprintf "could not find variable named %s" ident 328 | ;; 329 | 330 | let label_ptr_to_register buf label reg = 331 | B.emit_inst_fmt 332 | buf 333 | "leaq %s(%%rip), %s" 334 | (string_of_label label) 335 | (string_of_register reg) 336 | ;; 337 | 338 | (* calculate aligned size *) 339 | let calc_aligned_size buf size = 340 | B.emit_inst_fmt buf "shrq $3, %s" (string_of_value size); 341 | B.emit_inst_fmt buf "incq %s" (string_of_value size); 342 | B.emit_inst_fmt buf "shlq $3, %s" (string_of_value size) 343 | ;; 344 | 345 | let calc_aligned_size_const size = ((size / 8) + 1) * 8 346 | 347 | let alloc_heap_ptr_raw ctx buf size dest = 348 | let size_tmp = assign_to_new_register ctx buf size in 349 | calc_aligned_size buf (RegisterValue size_tmp); 350 | let ptr = RegisterValue (safe_call ctx buf "GC_malloc@PLT" [RegisterValue size_tmp]) in 351 | B.emit_inst_fmt buf "addq %s, %s" (string_of_register size_tmp) (string_of_value ptr); 352 | B.emit_inst_fmt buf "subq $8, %s" (string_of_value ptr); 353 | free_register size_tmp ctx; 354 | match dest with 355 | | RegisterValue r -> assign_to_register buf ptr r 356 | | StackValue s -> assign_to_stack ctx buf ptr s 357 | | ConstantValue _ -> failwith "can't assign to constant" 358 | ;; 359 | 360 | let alloc_heap_ptr ctx buf size dest = 361 | let reg = assign_to_new_register ctx buf size in 362 | alloc_heap_ptr_raw ctx buf (RegisterValue reg) dest; 363 | free_register reg ctx 364 | ;; 365 | 366 | let alloc_heap_ptr_constsize ctx buf size dest = 367 | alloc_heap_ptr_raw ctx buf (ConstantValue size) dest 368 | ;; 369 | 370 | let make_tuple_const ctx buf values = 371 | let size = List.length values in 372 | let reg = alloc_register ctx in 373 | let reg_value = RegisterValue reg in 374 | alloc_heap_ptr_constsize ctx buf ((size + 1) * 8) reg_value; 375 | assign_to_address ctx buf (ConstantValue (size * 8 * 2)) reg_value 0; 376 | List.iteri (fun i x -> assign_to_address ctx buf x reg_value (-(i + 1) * 8)) values; 377 | let s = turn_into_stack ctx buf reg_value in 378 | free_register reg ctx; 379 | StackValue s 380 | ;; 381 | 382 | let call_runtime_mlml ctx buf name params = 383 | let params = match params with [v] -> v | l -> make_tuple_const ctx buf l in 384 | let cls = make_tuple_const ctx buf [params; make_tuple_const ctx buf []] in 385 | call_runtime ctx buf name [cls] 386 | ;; 387 | 388 | let undef_variable_pattern ctx pat = 389 | List.iter (undef_variable ctx) (Pat.introduced_ident_list pat) 390 | ;; 391 | 392 | let function_ptr ctx buf label = 393 | let reg = alloc_register ctx in 394 | label_ptr_to_register buf label reg; 395 | let s = StackValue (turn_into_stack ctx buf (RegisterValue reg)) in 396 | free_register reg ctx; 397 | s 398 | ;; 399 | 400 | type comparison = 401 | | Eq 402 | | Ne 403 | | Gt 404 | | Ge 405 | | Lt 406 | | Le 407 | 408 | let string_of_comparison = function 409 | | Eq -> "e" 410 | | Ne -> "ne" 411 | | Gt -> "g" 412 | | Ge -> "ge" 413 | | Lt -> "l" 414 | | Le -> "le" 415 | ;; 416 | 417 | let branch_by_comparison ctx buf cmp v1 v2 label = 418 | let value, free = turn_into_register ctx buf v2 in 419 | B.emit_inst_fmt buf "cmpq %s, %s" (string_of_value v1) (string_of_register value); 420 | free ctx; 421 | B.emit_inst_fmt buf "j%s %s" (string_of_comparison cmp) (string_of_label label) 422 | ;; 423 | 424 | let branch_by_value ctx buf cmp = branch_by_comparison ctx buf cmp (make_marked_const 0) 425 | let branch_if_falsy ctx buf = branch_by_value ctx buf Eq 426 | let branch_if_truthy ctx buf = branch_by_value ctx buf Ne 427 | 428 | let branch_by_value_type ctx buf cmp value label = 429 | let value, free = turn_into_register ctx buf value in 430 | (* If the value is pointer, ZF is set to 1 *) 431 | (* otherwise, ZF is set to 0 *) 432 | B.emit_inst_fmt buf "test $1, %s" (string_of_register value); 433 | free ctx; 434 | B.emit_inst_fmt buf "j%s %s" (string_of_comparison cmp) (string_of_label label) 435 | ;; 436 | 437 | let branch_if_pointer ctx buf = branch_by_value_type ctx buf Eq 438 | let branch_if_not_pointer ctx buf = branch_by_value_type ctx buf Ne 439 | 440 | let comparison_to_value ctx buf cmp v1 v2 = 441 | let v2, free = turn_into_register ctx buf v2 in 442 | (* Use rdx temporarily (8-bit register(dl) is needed) *) 443 | let rdx = Register "rdx" in 444 | use_register ctx rdx; 445 | B.emit_inst_fmt buf "cmpq %s, %s" (string_of_value v1) (string_of_register v2); 446 | free ctx; 447 | B.emit_inst_fmt buf "set%s %s" (string_of_comparison cmp) (register_name "dl"); 448 | B.emit_inst_fmt buf "movzbq %s, %s" (register_name "dl") (register_name "rdx"); 449 | make_marked_int buf (RegisterValue rdx); 450 | let s = push_to_stack ctx buf (RegisterValue rdx) in 451 | free_register rdx ctx; 452 | StackValue s 453 | ;; 454 | 455 | let string_value_to_content ctx buf v dest = 456 | let reg = alloc_register ctx in 457 | (* read the size of data *) 458 | read_from_address ctx buf v (RegisterValue reg) 0; 459 | restore_marked_int buf (RegisterValue reg); 460 | assign_to_value ctx buf v dest; 461 | B.emit_inst_fmt buf "subq %s, %s" (string_of_register reg) (string_of_value dest); 462 | free_register reg ctx 463 | ;; 464 | 465 | let shallow_copy ctx buf src dest = 466 | let ret = call_runtime_mlml ctx buf "shallow_copy" [src] in 467 | assign_to_value ctx buf (RegisterValue ret) dest 468 | ;; 469 | 470 | let make_string_const ctx buf s = 471 | let str_label = new_unnamed_label ctx in 472 | B.emit_sub buf (B.Label (string_of_label str_label)); 473 | B.emit_sub_inst_fmt buf ".string \"%s\"" @@ String.escaped s; 474 | let r = alloc_register ctx in 475 | label_ptr_to_register buf str_label r; 476 | let res = 477 | call_runtime ctx buf "c_str_to_string" [RegisterValue r] 478 | |> register_value 479 | |> push_to_stack ctx buf 480 | |> stack_value 481 | in 482 | free_register r ctx; 483 | res 484 | ;; 485 | 486 | let rec pattern_match ctx buf pat v fail_label = 487 | match pat with 488 | | Pat.Wildcard -> () 489 | | Pat.Var x -> define_variable ctx buf x v 490 | | Pat.Array values | Pat.Tuple values -> 491 | (* assume v holds heap address *) 492 | (* length match *) 493 | (* size in bytes ( *8 ), recursive data ( *2 ) *) 494 | let len = List.length values * 8 * 2 in 495 | let reg = alloc_register ctx in 496 | read_from_address ctx buf v (RegisterValue reg) 0; 497 | branch_by_comparison ctx buf Ne (RegisterValue reg) (ConstantValue len) fail_label; 498 | free_register reg ctx; 499 | (* content match *) 500 | let aux i p = 501 | let reg = alloc_register ctx in 502 | let reg_value = RegisterValue reg in 503 | read_from_address ctx buf v reg_value (-(i + 1) * 8); 504 | let s = turn_into_stack ctx buf reg_value in 505 | free_register reg ctx; 506 | pattern_match ctx buf p (StackValue s) fail_label 507 | in 508 | List.iteri aux values 509 | | Pat.Record fields -> 510 | (* assume v holds heap address *) 511 | let aux (name, p) = 512 | let i = get_field_index ctx name in 513 | let reg = alloc_register ctx in 514 | let reg_value = RegisterValue reg in 515 | read_from_address ctx buf v reg_value (-(i + 1) * 8); 516 | let s = turn_into_stack ctx buf reg_value in 517 | free_register reg ctx; 518 | pattern_match ctx buf p (StackValue s) fail_label 519 | in 520 | List.iter aux fields 521 | | Pat.Ctor (name, p) -> 522 | (* assume v holds heap address *) 523 | let actual_idx = get_ctor_index ctx name in 524 | let reg = alloc_register ctx in 525 | let reg_value = RegisterValue reg in 526 | read_from_address ctx buf v reg_value (-8); 527 | restore_marked_int buf reg_value; 528 | B.emit_inst_fmt buf "cmpq $%d, %s" actual_idx (string_of_register reg); 529 | B.emit_inst_fmt buf "jne %s" (string_of_label fail_label); 530 | (match p with 531 | | Some p -> 532 | read_from_address ctx buf v reg_value (-16); 533 | let s = turn_into_stack ctx buf reg_value in 534 | free_register reg ctx; 535 | pattern_match ctx buf p (StackValue s) fail_label 536 | | None -> free_register reg ctx) 537 | | Pat.Int x -> 538 | let reg, free = turn_into_register ctx buf v in 539 | restore_marked_int buf (RegisterValue reg); 540 | B.emit_inst_fmt buf "cmpq $%d, %s" x (string_of_register reg); 541 | B.emit_inst_fmt buf "jne %s" (string_of_label fail_label); 542 | free ctx 543 | | Pat.String s -> 544 | let sv = make_string_const ctx buf s in 545 | let ret = call_runtime ctx buf "equal" [v; sv] in 546 | branch_if_falsy ctx buf (RegisterValue ret) fail_label 547 | | Pat.Or (a, b) -> 548 | let idents = Pat.introduced_ident_list a in 549 | if idents <> Pat.introduced_ident_list b 550 | then failwith "introduced identifiers mismatch in | pattern"; 551 | let resulting_area = 552 | List.map (fun _ -> push_to_stack ctx buf (ConstantValue 0)) idents 553 | in 554 | let store_result name s = 555 | (* TODO: `v` can be freed here *) 556 | let v = get_variable ctx name in 557 | assign_to_stack ctx buf (StackValue v) s; 558 | undef_variable ctx name 559 | in 560 | let right_label = new_unnamed_label ctx in 561 | let join_label = new_unnamed_label ctx in 562 | pattern_match ctx buf a v right_label; 563 | List.iter2 store_result idents resulting_area; 564 | B.emit_inst_fmt buf "jmp %s" (string_of_label join_label); 565 | start_label buf right_label; 566 | pattern_match ctx buf b v fail_label; 567 | List.iter2 store_result idents resulting_area; 568 | start_label buf join_label; 569 | let redef_vars name s = define_variable ctx buf name (StackValue s) in 570 | List.iter2 redef_vars idents resulting_area 571 | | Pat.Cons (a, b) -> 572 | (* assume v holds heap address *) 573 | let reg = alloc_register ctx in 574 | let reg_value = RegisterValue reg in 575 | (* read the flag *) 576 | read_from_address ctx buf v reg_value (-8); 577 | restore_marked_int buf reg_value; 578 | (* nil -> 0, cons -> 1 *) 579 | B.emit_inst_fmt buf "cmpq $%d, %s" 1 (string_of_register reg); 580 | B.emit_inst_fmt buf "jne %s" (string_of_label fail_label); 581 | read_from_address ctx buf v reg_value (-16); 582 | let s1 = turn_into_stack ctx buf reg_value in 583 | read_from_address ctx buf v reg_value (-24); 584 | let s2 = turn_into_stack ctx buf reg_value in 585 | free_register reg ctx; 586 | pattern_match ctx buf a (StackValue s1) fail_label; 587 | pattern_match ctx buf b (StackValue s2) fail_label 588 | | Pat.Nil -> 589 | (* assume v holds heap address *) 590 | let reg = alloc_register ctx in 591 | let reg_value = RegisterValue reg in 592 | (* read the flag *) 593 | read_from_address ctx buf v reg_value (-8); 594 | restore_marked_int buf reg_value; 595 | (* nil -> 0, cons -> 1 *) 596 | B.emit_inst_fmt buf "cmpq $%d, %s" 0 (string_of_register reg); 597 | B.emit_inst_fmt buf "jne %s" (string_of_label fail_label); 598 | free_register reg ctx 599 | | Pat.Range (from, to_) -> 600 | let reg = assign_to_new_register ctx buf v in 601 | let rv = RegisterValue reg in 602 | restore_marked_int buf rv; 603 | branch_by_comparison ctx buf Lt (ConstantValue (Char.code from)) rv fail_label; 604 | branch_by_comparison ctx buf Gt (ConstantValue (Char.code to_)) rv fail_label; 605 | free_register reg ctx 606 | ;; 607 | 608 | let calc_div ctx buf lhs rhs quot rem = 609 | let rax = Register "rax" in 610 | assign_to_register buf (RegisterValue lhs) rax; 611 | B.emit_inst buf "cltd"; 612 | B.emit_inst_fmt buf "idivq %s" (string_of_register rhs); 613 | let rdx = Register "rdx" in 614 | match quot with 615 | | Some quot -> assign_to_value ctx buf (RegisterValue rax) quot 616 | | None -> 617 | (); 618 | (match rem with 619 | | Some rem -> assign_to_value ctx buf (RegisterValue rdx) rem 620 | | None -> ()) 621 | ;; 622 | --------------------------------------------------------------------------------