├── .gitignore ├── .travis-ci.sh ├── .travis.yml ├── AUTHORS.txt ├── INSTALL.txt ├── Makefile ├── README.md ├── _oasis ├── _tags ├── configure ├── examples ├── base64 │ └── base64.ml ├── dijkstra │ └── dijkstra.ml ├── fib │ └── fib.ml ├── quicksort │ └── qsort.ml └── topological_sort │ └── tsort.ml ├── html ├── .gitignore ├── css │ └── codemirror.css ├── index.html └── js │ ├── clike.js │ ├── codemirror.js │ ├── evilml.js │ └── mllike.js ├── include ├── evilml.hpp ├── list.ml └── option.ml ├── myocamlbuild.ml ├── setup.ml ├── src ├── META ├── emlAlpha.ml ├── emlAlpha.mli ├── emlAssoc.ml ├── emlAssoc.mli ├── emlBoxing.ml ├── emlBoxing.mli ├── emlCompile.ml ├── emlCompile.mli ├── emlConfig.ml.ab ├── emlContext.ml ├── emlContext.mli ├── emlCpp.ml ├── emlCpp.mli ├── emlDCE.ml ├── emlDCE.mli ├── emlFlatLet.ml ├── emlFlatLet.mli ├── emlLexer.mll ├── emlLocation.ml ├── emlLocation.mli ├── emlOp.ml ├── emlParser.mly ├── emlRemoveMatch.ml ├── emlRemoveMatch.mli ├── emlSyntax.ml ├── emlType.ml ├── emlType.mli ├── emlTypedExpr.ml ├── emlTyping.ml ├── emlTyping.mli ├── emlUnCurrying.ml ├── emlUnCurrying.mli ├── emlUtils.ml ├── evilml.ml └── evilmlJS.ml └── test ├── base64.ml ├── dijkstra.ml ├── fib.ml ├── qsort.ml ├── test.sh └── tsort.ml /.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | *.annot 3 | *.cmo 4 | *.cma 5 | *.cmi 6 | *.a 7 | *.o 8 | *.cmx 9 | *.cmxs 10 | *.cmxa 11 | 12 | *.cpp 13 | *.s 14 | *.out 15 | *.docdir 16 | *.byte 17 | *.native 18 | 19 | _build/ 20 | /setup.data 21 | /setup.log 22 | 23 | src/parser.mli 24 | src/parser.ml 25 | src/lexer.ml 26 | src/emlConfig.ml 27 | src/evilml_hpp.ml 28 | src/example_*.ml 29 | src/*_ml.ml 30 | -------------------------------------------------------------------------------- /.travis-ci.sh: -------------------------------------------------------------------------------- 1 | # Dependencies 2 | APT_DEPENDS="opam g++" 3 | OPAM_DEPENDS="ocamlfind ppx_deriving ppx_blob js_of_ocaml" 4 | 5 | # Install OPAM and $APT_DEPENDS 6 | echo "yes" | sudo add-apt-repository ppa:avsm/ocaml42+opam12 7 | sudo apt-get update -qq 8 | sudo apt-get install -qq ${APT_DEPENDS} 9 | 10 | # Install OCaml 11 | export OPAMYES=1 12 | export OPAMVERBOSE=1 13 | opam init 14 | eval `opam config env` 15 | 16 | # Show OCaml and OPAM versions 17 | echo OCaml version 18 | ocaml -version 19 | echo OPAM versions 20 | opam --version 21 | opam --git-version 22 | 23 | # Install $OPAM_DEPENDS 24 | opam install ${OPAM_DEPENDS} 25 | 26 | # Test 27 | ./configure --prefix=`opam config var prefix` --enable-tests 28 | make 29 | make install 30 | make test 31 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: cpp 2 | script: bash -e .travis-ci.sh 3 | cache: apt 4 | sudo: required 5 | os: 6 | - linux -------------------------------------------------------------------------------- /AUTHORS.txt: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: 5bc8414b3a9ce7e780fef3203ba11018) *) 3 | 4 | Authors of EvilML: 5 | 6 | * Akinori ABE 7 | 8 | (* OASIS_STOP *) 9 | -------------------------------------------------------------------------------- /INSTALL.txt: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: c27feebc38c1e21bd1980cf0b4998156) *) 3 | 4 | This is the INSTALL file for the EvilML distribution. 5 | 6 | This package uses OASIS to generate its build system. See section OASIS for 7 | full information. 8 | 9 | Dependencies 10 | ============ 11 | 12 | In order to compile this package, you will need: 13 | 14 | * ocaml (>= 4.02.3) for all, test test 15 | * findlib 16 | * ppx_deriving 17 | * ppx_blob for executable evilmlJS 18 | * js_of_ocaml for executable evilmlJS 19 | 20 | Installing 21 | ========== 22 | 23 | 1. Uncompress the source archive and go to the root of the package 24 | 2. Run 'ocaml setup.ml -configure' 25 | 3. Run 'ocaml setup.ml -build' 26 | 4. Run 'ocaml setup.ml -install' 27 | 28 | Uninstalling 29 | ============ 30 | 31 | 1. Go to the root of the package 32 | 2. Run 'ocaml setup.ml -uninstall' 33 | 34 | OASIS 35 | ===== 36 | 37 | OASIS is a program that generates a setup.ml file using a simple '_oasis' 38 | configuration file. The generated setup only depends on the standard OCaml 39 | installation: no additional library is required. 40 | 41 | (* OASIS_STOP *) 42 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a3c674b4239234cbbe53afe090018954) 3 | 4 | SETUP = ocaml setup.ml 5 | 6 | build: setup.data 7 | $(SETUP) -build $(BUILDFLAGS) 8 | 9 | doc: setup.data build 10 | $(SETUP) -doc $(DOCFLAGS) 11 | 12 | test: setup.data build 13 | $(SETUP) -test $(TESTFLAGS) 14 | 15 | all: 16 | $(SETUP) -all $(ALLFLAGS) 17 | 18 | install: setup.data 19 | $(SETUP) -install $(INSTALLFLAGS) 20 | 21 | uninstall: setup.data 22 | $(SETUP) -uninstall $(UNINSTALLFLAGS) 23 | 24 | reinstall: setup.data 25 | $(SETUP) -reinstall $(REINSTALLFLAGS) 26 | 27 | clean: 28 | $(SETUP) -clean $(CLEANFLAGS) 29 | 30 | distclean: 31 | $(SETUP) -distclean $(DISTCLEANFLAGS) 32 | 33 | setup.data: 34 | $(SETUP) -configure $(CONFIGUREFLAGS) 35 | 36 | configure: 37 | $(SETUP) -configure $(CONFIGUREFLAGS) 38 | 39 | .PHONY: build doc test all install uninstall reinstall clean distclean configure 40 | 41 | # OASIS_STOP 42 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Evil ML 2 | ======= 3 | 4 | [![Build Status](https://travis-ci.org/akabe/evilml.svg)](https://travis-ci.org/akabe/evilml) 5 | 6 | Evil ML is a joke compiler from ML to **C++ template language** 7 | (not ordinary C++ code). Please, don't use this for practical purposes. 8 | 9 | C++ template is a **higher-order pure functional** programming language 10 | traditionally used for **compile-time** computation, while its syntax is 11 | verbose and hard to use. 12 | [ML](https://en.wikipedia.org/wiki/ML_%28programming_language%29), 13 | a higher-order functional programming language, is simple, practical and 14 | easy to understand, so that we jokingly implemented this compiler. You can 15 | easily use black magic in C++ template programming. This will give you nightmares. 16 | 17 | P.S. `constexpr` (supported C++11 or above) is useful. Why don't you use it? 18 | 19 | Features 20 | -------- 21 | 22 | - [OCaml](http://ocaml.org)-like higher-order pure functional language 23 | (Hindley-Milner polymorphism, no value restriction). 24 | - Type inference is performed. Most types are automatically inferred. 25 | - Variant types are supported. 26 | - You can write raw C++ code in `(*! ... *)` in top level. 27 | - `#use "foo.ml"` loads .ml files in top level (double semi-colons `;;` 28 | are not needed at the end). The .ml files you can load are found in 29 | directory [evilml/include](https://github.com/akabe/evilml/blob/master/include). 30 | 31 | Difference from OCaml: 32 | 33 | - Strings have type `char list` (type `string` does not exist). 34 | - Module system and separate compilation are not supported. 35 | - User-defined operators are not allowed. 36 | - `type` keyword in top level can only define *variant types*. You cannot 37 | declare aliases of types and records. 38 | - Pattern match is only performed by `match`. Patterns cannot appear in formal 39 | arguments and l.h.s. of let bindings. 40 | - Exhaustivity checking of pattern matching is not implemented. (future work) 41 | - Identifiers are defined as regular expression `[a-zA-Z_][a-zA-Z0-9_]*`. 42 | Primes cannot be used, and names that begin `__ml_` are 43 | reserved by this compiler. Identifiers of data constructors begin capital 44 | letters. 45 | - Top-level shadowing of identifiers (variables, types, and constructors) is 46 | prohibited. 47 | 48 | Install 49 | ------- 50 | 51 | ``` 52 | ./configure 53 | make 54 | make install 55 | ``` 56 | 57 | Usage 58 | ----- 59 | 60 | You can compile `foo.ml` as follows: 61 | 62 | ``` 63 | evilml foo.ml 64 | ``` 65 | 66 | Demo: quick sort 67 | ---------------- 68 | 69 | [examples/quicksort/qsort.ml](examples/quicksort/qsort.ml) implements quick sort 70 | of a list of 8 elements. You can compile the ML program into C++ template as 71 | [online demo](http://akabe.github.io/evilml/). 72 | 73 | 1. Check the check box of "Generate stand-alone code (embedding evilml.hpp)" 74 | 2. Push the button "Compile" 75 | 3. Copy and paste the generated C++ code into file `qsort.cpp` 76 | 4. Try to compile and run it: 77 | 78 | ``` 79 | $ g++ qsort.cpp 80 | $ ./a.out 81 | 1 2 3 4 5 6 7 8 82 | ``` 83 | 84 | In order to make sure that sorting is executed in compile time, 85 | we suggest to use `g++ -S qsort.cpp` and open `qsort.s`: 86 | 87 | ```asm 88 | ... 89 | movl $1, 4(%esp) ; pass 1 to printf 90 | movl $.LC0, (%esp) 91 | call printf 92 | movl $2, 4(%esp) ; pass 2 to printf 93 | movl $.LC0, (%esp) 94 | call printf 95 | movl $3, 4(%esp) ; pass 3 to printf 96 | movl $.LC0, (%esp) 97 | call printf 98 | movl $4, 4(%esp) ; pass 4 to printf 99 | movl $.LC0, (%esp) 100 | call printf 101 | movl $5, 4(%esp) ; pass 5 to printf 102 | movl $.LC0, (%esp) 103 | call printf 104 | movl $6, 4(%esp) ; pass 6 to printf 105 | movl $.LC0, (%esp) 106 | call printf 107 | movl $7, 4(%esp) ; pass 7 to printf 108 | movl $.LC0, (%esp) 109 | call printf 110 | movl $8, 4(%esp) ; pass 8 to printf 111 | movl $.LC1, (%esp) 112 | call printf 113 | ... 114 | ``` 115 | 116 | (Of course, you can use `std::cout` to print integers in `qsort.cpp`, 117 | however we make use of `printf` for readable assembly code.) 118 | 119 | Bugs 120 | ---- 121 | 122 | - `let rec diverge _ = diverge ()` should be infinite loop, but generated C++ 123 | code causes compilation error. `let rec diverge n = diverge (n+1)` passes C++ 124 | compilation. (I don't know the formal definition of reduction rules of C++ 125 | template expressions.) 126 | - C++03 template prohibits operation of float-point values, so that this 127 | compiler outputs wrong code. 128 | -------------------------------------------------------------------------------- /_oasis: -------------------------------------------------------------------------------- 1 | OASISFormat: 0.4 2 | Name: EvilML 3 | Version: 0.0.0 4 | Synopsis: A compiler from ML to C++ template language 5 | OCamlVersion: >= 4.02.3 6 | Authors: Akinori ABE 7 | License: GPL-3 8 | Plugins: META (0.4), StdFiles (0.4), DevFiles (0.4) 9 | XStdFilesREADME: false 10 | BuildTools: ocamlbuild 11 | AlphaFeatures: ocamlbuild_more_args 12 | XOCamlbuildPluginTags: package(js_of_ocaml.ocamlbuild) 13 | FilesAB: src/emlConfig.ml.ab 14 | 15 | PostBuildCommand: js_of_ocaml +js_of_ocaml/weak.js +js_of_ocaml/toplevel.js \ 16 | -o html/js/evilml.js \ 17 | _build/src/evilmlJS.byte 18 | 19 | Executable evilml 20 | Path: src 21 | MainIs: evilml.ml 22 | BuildTools: ocamlbuild 23 | BuildDepends: ppx_deriving.show 24 | CompiledObject: best 25 | DataFiles: ../include/*.hpp, ../include/*.ml 26 | 27 | Executable evilmlJS 28 | Path: src 29 | MainIs: evilmlJS.ml 30 | BuildTools: ocamlbuild 31 | BuildDepends: ppx_deriving.show,ppx_blob,js_of_ocaml,js_of_ocaml.ppx 32 | CompiledObject: byte 33 | 34 | ## 35 | ## Tests 36 | ## 37 | 38 | Test test 39 | Run$: flag(tests) 40 | WorkingDirectory: test/ 41 | Command: sh test.sh -------------------------------------------------------------------------------- /_tags: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: 031971e0de4a85846251028d560e24d6) 3 | # Ignore VCS directories, you can use the same kind of rule outside 4 | # OASIS_START/STOP if you want to exclude directories that contains 5 | # useless stuff for the build process 6 | true: annot, bin_annot 7 | <**/.svn>: -traverse 8 | <**/.svn>: not_hygienic 9 | ".bzr": -traverse 10 | ".bzr": not_hygienic 11 | ".hg": -traverse 12 | ".hg": not_hygienic 13 | ".git": -traverse 14 | ".git": not_hygienic 15 | "_darcs": -traverse 16 | "_darcs": not_hygienic 17 | # Executable evilml 18 | : package(ppx_deriving.show) 19 | # Executable evilmlJS 20 | "src/evilmlJS.byte": package(js_of_ocaml) 21 | "src/evilmlJS.byte": package(js_of_ocaml.ppx) 22 | "src/evilmlJS.byte": package(ppx_blob) 23 | "src/evilmlJS.byte": package(ppx_deriving.show) 24 | : package(js_of_ocaml) 25 | : package(js_of_ocaml.ppx) 26 | : package(ppx_blob) 27 | : package(ppx_deriving.show) 28 | # OASIS_STOP 29 | 30 | true: -traverse 31 | <**/*.ml{,i}>: debug, warn(A-4-33-41-42-43-34-44), strict_sequence, safe_string 32 | -------------------------------------------------------------------------------- /configure: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | # OASIS_START 4 | # DO NOT EDIT (digest: dc86c2ad450f91ca10c931b6045d0499) 5 | set -e 6 | 7 | FST=true 8 | for i in "$@"; do 9 | if $FST; then 10 | set -- 11 | FST=false 12 | fi 13 | 14 | case $i in 15 | --*=*) 16 | ARG=${i%%=*} 17 | VAL=${i##*=} 18 | set -- "$@" "$ARG" "$VAL" 19 | ;; 20 | *) 21 | set -- "$@" "$i" 22 | ;; 23 | esac 24 | done 25 | 26 | ocaml setup.ml -configure "$@" 27 | # OASIS_STOP 28 | -------------------------------------------------------------------------------- /examples/base64/base64.ml: -------------------------------------------------------------------------------- 1 | (* Example: BASE64 encoding (no paddings) *) 2 | 3 | #use "list.ml" 4 | 5 | let table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" 6 | 7 | let base64 cs = 8 | let rec aux n1 b1 cs = match cs with 9 | | [] -> if n1 = 0 then [] else [b1 lsl (6 - n1)] 10 | | c1 :: cs -> 11 | let c2 = ((b1 lsl 8) lor c1) lsr (n1 + 2) in 12 | let b2 = c1 land (0xff lsr (6 - n1)) in 13 | if n1 = 4 then c2 :: b2 :: aux 0 0 cs else c2 :: aux (n1+2) b2 cs 14 | in 15 | list_map (list_nth table) (aux 0 0 (list_map int_of_char cs)) 16 | 17 | let str = base64 "Compile-time BASE64 encoding!" 18 | let len = list_length str 19 | 20 | (*! 21 | #include 22 | 23 | int main (void) { 24 | char buf[len::val + 1]; 25 | 26 | // Convert a template-style list into a built-in C array. 27 | // Usage: __ml_array_of_list::set(C_POINTER); 28 | __ml_array_of_list::set(buf); 29 | 30 | std::cout << buf << std::endl; 31 | return 0; 32 | } 33 | *) 34 | -------------------------------------------------------------------------------- /examples/dijkstra/dijkstra.ml: -------------------------------------------------------------------------------- 1 | (** Example: Dijkstra's algorithm *) 2 | 3 | #use "list.ml" 4 | 5 | let remove_worse_paths ps = 6 | let eq x y = match (x, y) with ((vx, _, _), (vy, _, _)) -> vx = vy in 7 | let rec aux ps = match ps with 8 | | [] -> [] 9 | | x :: ps -> match list_partition (eq x) ps with (_, ps) -> x :: aux ps 10 | in 11 | aux ps 12 | 13 | let insert xs x = 14 | let cost p = match p with (v, path, c) -> c in 15 | let c = cost x in 16 | let rec aux xs = match xs with 17 | | [] -> [x] 18 | | hd :: tl -> if cost hd < c then hd :: (aux tl) else x :: xs 19 | in 20 | aux xs 21 | 22 | let walk graph ps = 23 | let mk_path p x = match (p, x) with 24 | | ((v, path, cp), (v1, v2, ce)) -> 25 | if v = v1 then Some (v2, v1 :: path, cp + ce) else None 26 | in 27 | match ps with 28 | | [] -> error 29 | | p :: ps1 -> 30 | let ps2 = list_filter_map (mk_path p) graph in 31 | let ps = list_foldl insert ps1 ps2 in 32 | remove_worse_paths ps 33 | 34 | let dijkstra graph goal start = 35 | let is_goal x = match x with (v, _, _) -> v = goal in 36 | let rec aux ps = 37 | match list_find is_goal ps with 38 | | Some p -> p 39 | | None -> aux (walk graph ps) 40 | in 41 | match aux [(start, [], 0)] with (v, p, c) -> (list_rev (v :: p), c) 42 | 43 | (* +----------> [6] <-----------+ 44 | 9 | | 6 45 | [5] <-------- [3] ---------> [4] 46 | ^ 2 ^ ^ 11 ^ 47 | | 9 | | 10 | 48 | 14 | +---+ +-----+ | 15 49 | | | 7 | | 50 | +----- [1] -------> [2] -----+ *) 51 | let graph = [ (1, 2, 7); (* (vertex_begin, vertex_end, cost) *) 52 | (1, 3, 9); 53 | (1, 5, 14); 54 | (2, 3, 10); 55 | (2, 4, 15); 56 | (3, 4, 11); 57 | (3, 5, 2); 58 | (4, 6, 6); 59 | (5, 6, 9) ] 60 | 61 | let fst x = match x with (y, _) -> y 62 | let snd x = match x with (_, y) -> y 63 | 64 | (* the shortest path = 1 -> 3 -> 5 -> 6 (its cost = 20) *) 65 | let res = dijkstra graph 6 1 66 | let path = fst res 67 | let cost = snd res 68 | let v0 = list_nth path 0 69 | let v1 = list_nth path 1 70 | let v2 = list_nth path 2 71 | let v3 = list_nth path 3 72 | 73 | (*! 74 | // This is C++ code. 75 | 76 | #include 77 | 78 | int main () { // We use printf in order to output readable assembly code. 79 | std::printf("cost = %d\n", cost::val); 80 | std::printf("%d -> ", v0::val); 81 | std::printf("%d -> ", v1::val); 82 | std::printf("%d -> ", v2::val); 83 | std::printf("%d\n", v3::val); 84 | return 0; 85 | } 86 | *) 87 | -------------------------------------------------------------------------------- /examples/fib/fib.ml: -------------------------------------------------------------------------------- 1 | (* Example: Fibonacci numbers *) 2 | 3 | let rec fib n = match n with 4 | | 0 -> 0 5 | | 1 -> 1 6 | | n -> fib (n-1) + fib (n-2) 7 | 8 | let x = fib 10 9 | 10 | (*! 11 | // This is C++ code. 12 | 13 | #include 14 | 15 | int main () { // We use printf in order to output readable assembly code. 16 | std::printf("fib 10 = %d\n", x::val); // fib 10 = 55 17 | return 0; 18 | } 19 | *) 20 | -------------------------------------------------------------------------------- /examples/quicksort/qsort.ml: -------------------------------------------------------------------------------- 1 | (* Example: quick sort *) 2 | 3 | #use "list.ml" 4 | 5 | let rec qsort xs = match xs with 6 | | [] -> [] 7 | | [x] -> [x] 8 | | pivot :: rest -> 9 | match list_partition (fun x -> x < pivot) rest with 10 | | (ys, zs) -> list_append (qsort ys) (pivot :: qsort zs) 11 | 12 | let l1 = [5; 4; 8; 1; 6; 3; 7; 2] 13 | let l2 = qsort l1 14 | let x0 = list_nth l2 0 15 | let x1 = list_nth l2 1 16 | let x2 = list_nth l2 2 17 | let x3 = list_nth l2 3 18 | let x4 = list_nth l2 4 19 | let x5 = list_nth l2 5 20 | let x6 = list_nth l2 6 21 | let x7 = list_nth l2 7 22 | 23 | (*! 24 | // This is C++ code. 25 | 26 | #include 27 | 28 | int main () { // We use printf in order to output readable assembly code. 29 | std::printf("%d ", x0::val); 30 | std::printf("%d ", x1::val); 31 | std::printf("%d ", x2::val); 32 | std::printf("%d ", x3::val); 33 | std::printf("%d ", x4::val); 34 | std::printf("%d ", x5::val); 35 | std::printf("%d ", x6::val); 36 | std::printf("%d\n", x7::val); 37 | return 0; 38 | } 39 | *) 40 | -------------------------------------------------------------------------------- /examples/topological_sort/tsort.ml: -------------------------------------------------------------------------------- 1 | (** Example: topological sort *) 2 | 3 | #use "list.ml" 4 | 5 | let tsort vs es = 6 | let is_leaf es v = 7 | list_for_all (fun e -> match e with (_, v2) -> v <> v2) es 8 | in 9 | let partition_leaves vs es = 10 | list_partition (fun e -> match e with (v, _) -> list_mem v vs) es 11 | in 12 | let rec aux acc vs es = 13 | match list_partition (is_leaf es) vs with 14 | | (vs1, []) -> list_flatten (list_rev (vs1 :: acc)) 15 | | (vs1, vs2) -> 16 | match partition_leaves vs1 es with (_, es2) -> aux (vs1 :: acc) vs2 es2 17 | in 18 | aux [] vs es 19 | 20 | (* +----> [2] --> [5] <-- [7] 21 | | ^ ^ 22 | | | | 23 | [1] <-- [3] -----+ | 24 | ^ ^ | 25 | | | | 26 | +----- [4] <---------- [6] *) 27 | let vertices = [1; 2; 3; 4; 5; 6; 7] 28 | let edges = [ (1, 2); (* (vertex_begin, vertex_end) *) 29 | (2, 5); 30 | (3, 1); 31 | (3, 5); 32 | (4, 1); 33 | (4, 3); 34 | (6, 4); 35 | (6, 7); 36 | (7, 5) ] 37 | 38 | (* Result: 6, 4, 7, 3, 1, 2, 5 *) 39 | let xs = tsort vertices edges 40 | let x0 = list_nth xs 0 41 | let x1 = list_nth xs 1 42 | let x2 = list_nth xs 2 43 | let x3 = list_nth xs 3 44 | let x4 = list_nth xs 4 45 | let x5 = list_nth xs 5 46 | let x6 = list_nth xs 6 47 | 48 | (*! 49 | // This is C++ code. 50 | 51 | #include 52 | 53 | int main () { // We use printf in order to output readable assembly code. 54 | std::printf("%d ", x0::val); 55 | std::printf("%d ", x1::val); 56 | std::printf("%d ", x2::val); 57 | std::printf("%d ", x3::val); 58 | std::printf("%d ", x4::val); 59 | std::printf("%d ", x5::val); 60 | std::printf("%d\n", x6::val); 61 | return 0; 62 | } 63 | *) 64 | -------------------------------------------------------------------------------- /html/.gitignore: -------------------------------------------------------------------------------- 1 | *~ 2 | -------------------------------------------------------------------------------- /html/css/codemirror.css: -------------------------------------------------------------------------------- 1 | /* BASICS */ 2 | 3 | .CodeMirror { 4 | /* Set height, width, borders, and global font properties here */ 5 | font-family: monospace; 6 | height: 300px; 7 | color: black; 8 | } 9 | 10 | /* PADDING */ 11 | 12 | .CodeMirror-lines { 13 | padding: 4px 0; /* Vertical padding around content */ 14 | } 15 | .CodeMirror pre { 16 | padding: 0 4px; /* Horizontal padding of content */ 17 | } 18 | 19 | .CodeMirror-scrollbar-filler, .CodeMirror-gutter-filler { 20 | background-color: white; /* The little square between H and V scrollbars */ 21 | } 22 | 23 | /* GUTTER */ 24 | 25 | .CodeMirror-gutters { 26 | border-right: 1px solid #ddd; 27 | background-color: #f7f7f7; 28 | white-space: nowrap; 29 | } 30 | .CodeMirror-linenumbers {} 31 | .CodeMirror-linenumber { 32 | padding: 0 3px 0 5px; 33 | min-width: 20px; 34 | text-align: right; 35 | color: #999; 36 | white-space: nowrap; 37 | } 38 | 39 | .CodeMirror-guttermarker { color: black; } 40 | .CodeMirror-guttermarker-subtle { color: #999; } 41 | 42 | /* CURSOR */ 43 | 44 | .CodeMirror div.CodeMirror-cursor { 45 | border-left: 1px solid black; 46 | } 47 | /* Shown when moving in bi-directional text */ 48 | .CodeMirror div.CodeMirror-secondarycursor { 49 | border-left: 1px solid silver; 50 | } 51 | .CodeMirror.cm-fat-cursor div.CodeMirror-cursor { 52 | width: auto; 53 | border: 0; 54 | background: #7e7; 55 | } 56 | .CodeMirror.cm-fat-cursor div.CodeMirror-cursors { 57 | z-index: 1; 58 | } 59 | 60 | .cm-animate-fat-cursor { 61 | width: auto; 62 | border: 0; 63 | -webkit-animation: blink 1.06s steps(1) infinite; 64 | -moz-animation: blink 1.06s steps(1) infinite; 65 | animation: blink 1.06s steps(1) infinite; 66 | background-color: #7e7; 67 | } 68 | @-moz-keyframes blink { 69 | 0% {} 70 | 50% { background-color: transparent; } 71 | 100% {} 72 | } 73 | @-webkit-keyframes blink { 74 | 0% {} 75 | 50% { background-color: transparent; } 76 | 100% {} 77 | } 78 | @keyframes blink { 79 | 0% {} 80 | 50% { background-color: transparent; } 81 | 100% {} 82 | } 83 | 84 | /* Can style cursor different in overwrite (non-insert) mode */ 85 | div.CodeMirror-overwrite div.CodeMirror-cursor {} 86 | 87 | .cm-tab { display: inline-block; text-decoration: inherit; } 88 | 89 | .CodeMirror-ruler { 90 | border-left: 1px solid #ccc; 91 | position: absolute; 92 | } 93 | 94 | /* DEFAULT THEME */ 95 | 96 | .cm-s-default .cm-header {color: blue;} 97 | .cm-s-default .cm-quote {color: #090;} 98 | .cm-negative {color: #d44;} 99 | .cm-positive {color: #292;} 100 | .cm-header, .cm-strong {font-weight: bold;} 101 | .cm-em {font-style: italic;} 102 | .cm-link {text-decoration: underline;} 103 | .cm-strikethrough {text-decoration: line-through;} 104 | 105 | .cm-s-default .cm-keyword {color: #708;} 106 | .cm-s-default .cm-atom {color: #219;} 107 | .cm-s-default .cm-number {color: #164;} 108 | .cm-s-default .cm-def {color: #00f;} 109 | .cm-s-default .cm-variable, 110 | .cm-s-default .cm-punctuation, 111 | .cm-s-default .cm-property, 112 | .cm-s-default .cm-operator {} 113 | .cm-s-default .cm-variable-2 {color: #05a;} 114 | .cm-s-default .cm-variable-3 {color: #085;} 115 | .cm-s-default .cm-comment {color: #a50;} 116 | .cm-s-default .cm-string {color: #a11;} 117 | .cm-s-default .cm-string-2 {color: #f50;} 118 | .cm-s-default .cm-meta {color: #555;} 119 | .cm-s-default .cm-qualifier {color: #555;} 120 | .cm-s-default .cm-builtin {color: #30a;} 121 | .cm-s-default .cm-bracket {color: #997;} 122 | .cm-s-default .cm-tag {color: #170;} 123 | .cm-s-default .cm-attribute {color: #00c;} 124 | .cm-s-default .cm-hr {color: #999;} 125 | .cm-s-default .cm-link {color: #00c;} 126 | 127 | .cm-s-default .cm-error {color: #f00;} 128 | .cm-invalidchar {color: #f00;} 129 | 130 | .CodeMirror-composing { border-bottom: 2px solid; } 131 | 132 | /* Default styles for common addons */ 133 | 134 | div.CodeMirror span.CodeMirror-matchingbracket {color: #0f0;} 135 | div.CodeMirror span.CodeMirror-nonmatchingbracket {color: #f22;} 136 | .CodeMirror-matchingtag { background: rgba(255, 150, 0, .3); } 137 | .CodeMirror-activeline-background {background: #e8f2ff;} 138 | 139 | /* STOP */ 140 | 141 | /* The rest of this file contains styles related to the mechanics of 142 | the editor. You probably shouldn't touch them. */ 143 | 144 | .CodeMirror { 145 | position: relative; 146 | overflow: hidden; 147 | background: white; 148 | } 149 | 150 | .CodeMirror-scroll { 151 | overflow: scroll !important; /* Things will break if this is overridden */ 152 | /* 30px is the magic margin used to hide the element's real scrollbars */ 153 | /* See overflow: hidden in .CodeMirror */ 154 | margin-bottom: -30px; margin-right: -30px; 155 | padding-bottom: 30px; 156 | height: 100%; 157 | outline: none; /* Prevent dragging from highlighting the element */ 158 | position: relative; 159 | } 160 | .CodeMirror-sizer { 161 | position: relative; 162 | border-right: 30px solid transparent; 163 | } 164 | 165 | /* The fake, visible scrollbars. Used to force redraw during scrolling 166 | before actuall scrolling happens, thus preventing shaking and 167 | flickering artifacts. */ 168 | .CodeMirror-vscrollbar, .CodeMirror-hscrollbar, .CodeMirror-scrollbar-filler, .CodeMirror-gutter-filler { 169 | position: absolute; 170 | z-index: 6; 171 | display: none; 172 | } 173 | .CodeMirror-vscrollbar { 174 | right: 0; top: 0; 175 | overflow-x: hidden; 176 | overflow-y: scroll; 177 | } 178 | .CodeMirror-hscrollbar { 179 | bottom: 0; left: 0; 180 | overflow-y: hidden; 181 | overflow-x: scroll; 182 | } 183 | .CodeMirror-scrollbar-filler { 184 | right: 0; bottom: 0; 185 | } 186 | .CodeMirror-gutter-filler { 187 | left: 0; bottom: 0; 188 | } 189 | 190 | .CodeMirror-gutters { 191 | position: absolute; left: 0; top: 0; 192 | z-index: 3; 193 | } 194 | .CodeMirror-gutter { 195 | white-space: normal; 196 | height: 100%; 197 | display: inline-block; 198 | margin-bottom: -30px; 199 | /* Hack to make IE7 behave */ 200 | *zoom:1; 201 | *display:inline; 202 | } 203 | .CodeMirror-gutter-wrapper { 204 | position: absolute; 205 | z-index: 4; 206 | background: none !important; 207 | border: none !important; 208 | } 209 | .CodeMirror-gutter-background { 210 | position: absolute; 211 | top: 0; bottom: 0; 212 | z-index: 4; 213 | } 214 | .CodeMirror-gutter-elt { 215 | position: absolute; 216 | cursor: default; 217 | z-index: 4; 218 | } 219 | .CodeMirror-gutter-wrapper { 220 | -webkit-user-select: none; 221 | -moz-user-select: none; 222 | user-select: none; 223 | } 224 | 225 | .CodeMirror-lines { 226 | cursor: text; 227 | min-height: 1px; /* prevents collapsing before first draw */ 228 | } 229 | .CodeMirror pre { 230 | /* Reset some styles that the rest of the page might have set */ 231 | -moz-border-radius: 0; -webkit-border-radius: 0; border-radius: 0; 232 | border-width: 0; 233 | background: transparent; 234 | font-family: inherit; 235 | font-size: inherit; 236 | margin: 0; 237 | white-space: pre; 238 | word-wrap: normal; 239 | line-height: inherit; 240 | color: inherit; 241 | z-index: 2; 242 | position: relative; 243 | overflow: visible; 244 | -webkit-tap-highlight-color: transparent; 245 | } 246 | .CodeMirror-wrap pre { 247 | word-wrap: break-word; 248 | white-space: pre-wrap; 249 | word-break: normal; 250 | } 251 | 252 | .CodeMirror-linebackground { 253 | position: absolute; 254 | left: 0; right: 0; top: 0; bottom: 0; 255 | z-index: 0; 256 | } 257 | 258 | .CodeMirror-linewidget { 259 | position: relative; 260 | z-index: 2; 261 | overflow: auto; 262 | } 263 | 264 | .CodeMirror-widget {} 265 | 266 | .CodeMirror-code { 267 | outline: none; 268 | } 269 | 270 | /* Force content-box sizing for the elements where we expect it */ 271 | .CodeMirror-scroll, 272 | .CodeMirror-sizer, 273 | .CodeMirror-gutter, 274 | .CodeMirror-gutters, 275 | .CodeMirror-linenumber { 276 | -moz-box-sizing: content-box; 277 | box-sizing: content-box; 278 | } 279 | 280 | .CodeMirror-measure { 281 | position: absolute; 282 | width: 100%; 283 | height: 0; 284 | overflow: hidden; 285 | visibility: hidden; 286 | } 287 | .CodeMirror-measure pre { position: static; } 288 | 289 | .CodeMirror div.CodeMirror-cursor { 290 | position: absolute; 291 | border-right: none; 292 | width: 0; 293 | } 294 | 295 | div.CodeMirror-cursors { 296 | visibility: hidden; 297 | position: relative; 298 | z-index: 3; 299 | } 300 | .CodeMirror-focused div.CodeMirror-cursors { 301 | visibility: visible; 302 | } 303 | 304 | .CodeMirror-selected { background: #d9d9d9; } 305 | .CodeMirror-focused .CodeMirror-selected { background: #d7d4f0; } 306 | .CodeMirror-crosshair { cursor: crosshair; } 307 | .CodeMirror-line::selection, .CodeMirror-line > span::selection, .CodeMirror-line > span > span::selection { background: #d7d4f0; } 308 | .CodeMirror-line::-moz-selection, .CodeMirror-line > span::-moz-selection, .CodeMirror-line > span > span::-moz-selection { background: #d7d4f0; } 309 | 310 | .cm-searching { 311 | background: #ffa; 312 | background: rgba(255, 255, 0, .4); 313 | } 314 | 315 | /* IE7 hack to prevent it from returning funny offsetTops on the spans */ 316 | .CodeMirror span { *vertical-align: text-bottom; } 317 | 318 | /* Used to force a border model for a node */ 319 | .cm-force-border { padding-right: .1px; } 320 | 321 | @media print { 322 | /* Hide the cursor when printing */ 323 | .CodeMirror div.CodeMirror-cursors { 324 | visibility: hidden; 325 | } 326 | } 327 | 328 | /* See issue #2901 */ 329 | .cm-tab-wrap-hack:after { content: ''; } 330 | 331 | /* Help users use markselection to safely style text background */ 332 | span.CodeMirror-selectedtext { background: none; } 333 | -------------------------------------------------------------------------------- /html/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 45 | Evil ML: ML to C++ template language 46 | 47 | 48 |

Evil ML: ML to C++ template language

49 |

50 |

51 | Evil ML is a joke compiler from ML to C++ template language 52 | (not ordinary C++ code). Please, don't use this for practical purposes. 53 |

54 |

55 | C++ template is a higher-order pure functional programming language 56 | traditionally used for compile-time computation, while its syntax is 57 | verbose and hard to use. 58 | ML, 59 | a higher-order functional programming language, is simple, practical and 60 | easy to understand, so that we jokingly implemented this compiler. You can 61 | easily use black magic in C++ template programming. This will give you nightmares. 62 |

63 |

64 |

    65 |
  • OCaml-like higher-order pure functional language 66 | (Hindley-Milner polymorphism, no value restriction).
    • 67 |
  • Type inference is performed. Most types are automatically inferred.
    • 68 |
  • Variant types are supported.
    • 69 |
  • You can write raw C++ code in (*! ... *) in top level.
    • 70 |
  • #use "foo.ml" loads .ml files in top level (double semi-colons ;; are not needed at the end). 71 | The .ml files you can load are found in directory evilml/include.
    • 72 |
73 | See https://github.com/akabe/evilml for details.

74 |
75 | Examples: 76 | 77 | 78 | 79 | 80 | 81 |
82 |
83 |
84 | 85 | 86 | 87 | 91 |
92 |
93 |

Input: OCaml code

94 | 95 |

Type Inference Result

96 | 97 |
98 |
99 |

Output: C++ code

100 | 101 |
102 | 103 | 104 | 105 | 162 | 163 | 164 | 165 | -------------------------------------------------------------------------------- /html/js/mllike.js: -------------------------------------------------------------------------------- 1 | // CodeMirror, copyright (c) by Marijn Haverbeke and others 2 | // Distributed under an MIT license: http://codemirror.net/LICENSE 3 | 4 | (function(mod) { 5 | if (typeof exports == "object" && typeof module == "object") // CommonJS 6 | mod(require("../../lib/codemirror")); 7 | else if (typeof define == "function" && define.amd) // AMD 8 | define(["../../lib/codemirror"], mod); 9 | else // Plain browser env 10 | mod(CodeMirror); 11 | })(function(CodeMirror) { 12 | "use strict"; 13 | 14 | CodeMirror.defineMode('mllike', function(_config, parserConfig) { 15 | var words = { 16 | 'let': 'keyword', 17 | 'rec': 'keyword', 18 | 'in': 'keyword', 19 | 'of': 'keyword', 20 | 'and': 'keyword', 21 | 'if': 'keyword', 22 | 'then': 'keyword', 23 | 'else': 'keyword', 24 | 'for': 'keyword', 25 | 'to': 'keyword', 26 | 'while': 'keyword', 27 | 'do': 'keyword', 28 | 'done': 'keyword', 29 | 'fun': 'keyword', 30 | 'function': 'keyword', 31 | 'val': 'keyword', 32 | 'type': 'keyword', 33 | 'mutable': 'keyword', 34 | 'match': 'keyword', 35 | 'with': 'keyword', 36 | 'try': 'keyword', 37 | 'open': 'builtin', 38 | 'ignore': 'builtin', 39 | 'begin': 'keyword', 40 | 'end': 'keyword' 41 | }; 42 | 43 | var extraWords = parserConfig.extraWords || {}; 44 | for (var prop in extraWords) { 45 | if (extraWords.hasOwnProperty(prop)) { 46 | words[prop] = parserConfig.extraWords[prop]; 47 | } 48 | } 49 | 50 | function tokenBase(stream, state) { 51 | var ch = stream.next(); 52 | 53 | if (ch === '"') { 54 | state.tokenize = tokenString; 55 | return state.tokenize(stream, state); 56 | } 57 | if (ch === '(') { 58 | if (stream.eat('*')) { 59 | state.commentLevel++; 60 | state.tokenize = tokenComment; 61 | return state.tokenize(stream, state); 62 | } 63 | } 64 | if (ch === '~') { 65 | stream.eatWhile(/\w/); 66 | return 'variable-2'; 67 | } 68 | if (ch === '`') { 69 | stream.eatWhile(/\w/); 70 | return 'quote'; 71 | } 72 | if (ch === '/' && parserConfig.slashComments && stream.eat('/')) { 73 | stream.skipToEnd(); 74 | return 'comment'; 75 | } 76 | if (/\d/.test(ch)) { 77 | stream.eatWhile(/[\d]/); 78 | if (stream.eat('.')) { 79 | stream.eatWhile(/[\d]/); 80 | } 81 | return 'number'; 82 | } 83 | if ( /[+\-*&%=<>!?|]/.test(ch)) { 84 | return 'operator'; 85 | } 86 | stream.eatWhile(/\w/); 87 | var cur = stream.current(); 88 | return words.hasOwnProperty(cur) ? words[cur] : 'variable'; 89 | } 90 | 91 | function tokenString(stream, state) { 92 | var next, end = false, escaped = false; 93 | while ((next = stream.next()) != null) { 94 | if (next === '"' && !escaped) { 95 | end = true; 96 | break; 97 | } 98 | escaped = !escaped && next === '\\'; 99 | } 100 | if (end && !escaped) { 101 | state.tokenize = tokenBase; 102 | } 103 | return 'string'; 104 | }; 105 | 106 | function tokenComment(stream, state) { 107 | var prev, next; 108 | while(state.commentLevel > 0 && (next = stream.next()) != null) { 109 | if (prev === '(' && next === '*') state.commentLevel++; 110 | if (prev === '*' && next === ')') state.commentLevel--; 111 | prev = next; 112 | } 113 | if (state.commentLevel <= 0) { 114 | state.tokenize = tokenBase; 115 | } 116 | return 'comment'; 117 | } 118 | 119 | return { 120 | startState: function() {return {tokenize: tokenBase, commentLevel: 0};}, 121 | token: function(stream, state) { 122 | if (stream.eatSpace()) return null; 123 | return state.tokenize(stream, state); 124 | }, 125 | 126 | blockCommentStart: "(*", 127 | blockCommentEnd: "*)", 128 | lineComment: parserConfig.slashComments ? "//" : null 129 | }; 130 | }); 131 | 132 | CodeMirror.defineMIME('text/x-ocaml', { 133 | name: 'mllike', 134 | extraWords: { 135 | 'succ': 'keyword', 136 | 'trace': 'builtin', 137 | 'exit': 'builtin', 138 | 'print_string': 'builtin', 139 | 'print_endline': 'builtin', 140 | 'true': 'atom', 141 | 'false': 'atom', 142 | 'raise': 'keyword' 143 | } 144 | }); 145 | 146 | CodeMirror.defineMIME('text/x-fsharp', { 147 | name: 'mllike', 148 | extraWords: { 149 | 'abstract': 'keyword', 150 | 'as': 'keyword', 151 | 'assert': 'keyword', 152 | 'base': 'keyword', 153 | 'class': 'keyword', 154 | 'default': 'keyword', 155 | 'delegate': 'keyword', 156 | 'downcast': 'keyword', 157 | 'downto': 'keyword', 158 | 'elif': 'keyword', 159 | 'exception': 'keyword', 160 | 'extern': 'keyword', 161 | 'finally': 'keyword', 162 | 'global': 'keyword', 163 | 'inherit': 'keyword', 164 | 'inline': 'keyword', 165 | 'interface': 'keyword', 166 | 'internal': 'keyword', 167 | 'lazy': 'keyword', 168 | 'let!': 'keyword', 169 | 'member' : 'keyword', 170 | 'module': 'keyword', 171 | 'namespace': 'keyword', 172 | 'new': 'keyword', 173 | 'null': 'keyword', 174 | 'override': 'keyword', 175 | 'private': 'keyword', 176 | 'public': 'keyword', 177 | 'return': 'keyword', 178 | 'return!': 'keyword', 179 | 'select': 'keyword', 180 | 'static': 'keyword', 181 | 'struct': 'keyword', 182 | 'upcast': 'keyword', 183 | 'use': 'keyword', 184 | 'use!': 'keyword', 185 | 'val': 'keyword', 186 | 'when': 'keyword', 187 | 'yield': 'keyword', 188 | 'yield!': 'keyword', 189 | 190 | 'List': 'builtin', 191 | 'Seq': 'builtin', 192 | 'Map': 'builtin', 193 | 'Set': 'builtin', 194 | 'int': 'builtin', 195 | 'string': 'builtin', 196 | 'raise': 'builtin', 197 | 'failwith': 'builtin', 198 | 'not': 'builtin', 199 | 'true': 'builtin', 200 | 'false': 'builtin' 201 | }, 202 | slashComments: true 203 | }); 204 | 205 | }); 206 | -------------------------------------------------------------------------------- /include/evilml.hpp: -------------------------------------------------------------------------------- 1 | /* ========================================================================== * 2 | * * 3 | * Evil ML * 4 | * * 5 | * Compiler from ML to C++ template language * 6 | * * 7 | * ========================================================================== */ 8 | 9 | template struct __ml_bool { 10 | static const int tag = -1; 11 | static const bool val = b; 12 | }; 13 | 14 | template struct __ml_char { 15 | static const int tag = -1; 16 | static const char val = c; 17 | }; 18 | 19 | template struct __ml_int { 20 | static const int tag = -1; 21 | static const int val = n; 22 | }; 23 | 24 | template 25 | struct __ml_if { 26 | typedef T type; 27 | }; 28 | 29 | template 30 | struct __ml_if { 31 | typedef F type; 32 | }; 33 | 34 | template 35 | struct __ml_pair { 36 | static const int tag = 1; 37 | typedef x fst; 38 | typedef y snd; 39 | }; 40 | 41 | // Polymorphic comparison 42 | 43 | template 44 | struct __ml_compare { 45 | private: 46 | template 47 | struct aux // x::tag != y::tag 48 | : public __ml_int {}; 49 | 50 | template 51 | struct aux <0, -1, m> // x::tag == y::tag && tag == [boxed val] 52 | : public __ml_int<(x::val > y::val ? 1 : (x::val < y::val ? -1 : 0))> {}; 53 | 54 | template 55 | struct aux <0, n, 0> // x::tag == y::tag && tag == [nullary constructor] 56 | : public __ml_int<0> {}; 57 | 58 | template 59 | class aux <0, n, 1> // x::tag == y::tag && tag == [unary constructor] 60 | : public __ml_int<__ml_compare::val> {}; 61 | 62 | template 63 | class aux <0, n, 2> // x::tag == y::tag && tag == [binary constructor] 64 | { 65 | private: 66 | static const int tmp = __ml_compare::val; 67 | public: 68 | static const int val = (tmp != 0 ? tmp : __ml_compare::val); 69 | }; 70 | public: 71 | static const int tag = -1; 72 | static const int val = aux::val; 73 | }; 74 | 75 | template 76 | struct __ml_eq : public __ml_bool<__ml_compare::val == 0> {}; 77 | 78 | template 79 | struct __ml_ne : public __ml_bool<__ml_compare::val != 0> {}; 80 | 81 | template 82 | struct __ml_ge : public __ml_bool<__ml_compare::val >= 0> {}; 83 | 84 | template 85 | struct __ml_le : public __ml_bool<__ml_compare::val <= 0> {}; 86 | 87 | template 88 | struct __ml_gt : public __ml_bool<(__ml_compare::val > 0)> {}; 89 | 90 | template 91 | struct __ml_lt : public __ml_bool<(__ml_compare::val < 0)> {}; 92 | 93 | // conversion from lists into built-in C arrays 94 | 95 | template 96 | class __ml_array_of_list { 97 | private: 98 | template 99 | struct aux { // __ml_nil 100 | static inline void set (T * p) { 101 | *p = '\0'; 102 | return; 103 | } 104 | }; 105 | template 106 | struct aux { // __ml_cons 107 | static inline void set (T * p) { 108 | *p = x::fst::val; 109 | __ml_array_of_list::set(p+1); 110 | return; 111 | } 112 | }; 113 | public: 114 | static inline void set (T * p) { 115 | aux::set(p); 116 | return; 117 | } 118 | }; 119 | 120 | // Built-in functions 121 | 122 | struct __ml_succ { 123 | template 124 | struct fun { 125 | typedef __ml_int type; 126 | }; 127 | }; 128 | 129 | struct __ml_pred { 130 | template 131 | struct fun { 132 | typedef __ml_int type; 133 | }; 134 | }; 135 | 136 | struct __ml_min { 137 | template 138 | struct fun { 139 | typedef __ml_int<(x::val < y::val ? x::val : y::val)> type; 140 | }; 141 | }; 142 | 143 | struct __ml_max { 144 | template 145 | struct fun { 146 | typedef __ml_int<(x::val > y::val ? x::val : y::val)> type; 147 | }; 148 | }; 149 | 150 | struct __ml_int_of_char { 151 | template 152 | struct fun { 153 | typedef __ml_int<(unsigned char) x::val> type; 154 | }; 155 | }; 156 | 157 | struct __ml_char_of_int { 158 | template 159 | struct fun { 160 | typedef __ml_char type; 161 | }; 162 | }; 163 | 164 | // End of evilml.hpp 165 | //////////////////////////////////////////////////////////////////////////////// 166 | -------------------------------------------------------------------------------- /include/list.ml: -------------------------------------------------------------------------------- 1 | #use "option.ml" 2 | 3 | type 'a list = [] | :: of 'a * 'a list 4 | 5 | let rec list_map f xs = match xs with 6 | | [] -> [] 7 | | x :: xs -> f x :: list_map f xs 8 | 9 | let rec list_foldl f acc xs = match xs with 10 | | [] -> acc 11 | | x :: xs -> list_foldl f (f acc x) xs 12 | 13 | let rec list_foldr f xs acc = match xs with 14 | | [] -> acc 15 | | x :: xs -> f x (list_foldr f xs acc) 16 | 17 | let rec list_nth xs i = match xs with 18 | | [] -> error 19 | | x :: xs -> if i = 0 then x else list_nth xs (i-1) 20 | 21 | let list_length = list_foldl (fun n _ -> n + 1) 0 22 | let list_rev = list_foldl (fun acc x -> x :: acc) [] 23 | let list_append = list_foldr (fun x acc -> x :: acc) 24 | 25 | let list_flatten xss = list_foldr list_append xss [] 26 | 27 | let list_filter f xs = 28 | list_foldr (fun x acc -> if f x then x :: acc else acc) xs [] 29 | 30 | let list_filter_map f xs = 31 | list_foldr (fun x acc -> match f x with 32 | | Some y -> y :: acc 33 | | None -> acc) xs [] 34 | 35 | let list_partition f xs = 36 | list_foldr (fun x acc -> match acc with 37 | | (ys, zs) -> if f x then (x :: ys, zs) else (ys, x :: zs)) 38 | xs ([], []) 39 | 40 | let rec list_find f xs = match xs with 41 | | [] -> None 42 | | x :: xs -> if f x then Some x else list_find f xs 43 | 44 | let list_mem x xs = list_find (fun y -> x = y) xs <> None 45 | 46 | let rec list_assoc x xs = match xs with 47 | | [] -> None 48 | | (y, z) :: xs -> if x = y then Some z else list_assoc x xs 49 | 50 | let rec list_for_all f xs = match xs with 51 | | [] -> true 52 | | x :: xs -> if f x then list_for_all f xs else false 53 | 54 | let rec list_exists f xs = match xs with 55 | | [] -> false 56 | | x :: xs -> if f x then true else list_exists f xs 57 | -------------------------------------------------------------------------------- /include/option.ml: -------------------------------------------------------------------------------- 1 | type 'a option = None | Some of 'a 2 | -------------------------------------------------------------------------------- /myocamlbuild.ml: -------------------------------------------------------------------------------- 1 | (* OASIS_START *) 2 | (* DO NOT EDIT (digest: 2b686a81cec9fb16d1640bda36a68fbd) *) 3 | module OASISGettext = struct 4 | (* # 22 "src/oasis/OASISGettext.ml" *) 5 | 6 | 7 | let ns_ str = 8 | str 9 | 10 | 11 | let s_ str = 12 | str 13 | 14 | 15 | let f_ (str: ('a, 'b, 'c, 'd) format4) = 16 | str 17 | 18 | 19 | let fn_ fmt1 fmt2 n = 20 | if n = 1 then 21 | fmt1^^"" 22 | else 23 | fmt2^^"" 24 | 25 | 26 | let init = 27 | [] 28 | 29 | 30 | end 31 | 32 | module OASISExpr = struct 33 | (* # 22 "src/oasis/OASISExpr.ml" *) 34 | 35 | 36 | 37 | 38 | 39 | open OASISGettext 40 | 41 | 42 | type test = string 43 | 44 | 45 | type flag = string 46 | 47 | 48 | type t = 49 | | EBool of bool 50 | | ENot of t 51 | | EAnd of t * t 52 | | EOr of t * t 53 | | EFlag of flag 54 | | ETest of test * string 55 | 56 | 57 | 58 | type 'a choices = (t * 'a) list 59 | 60 | 61 | let eval var_get t = 62 | let rec eval' = 63 | function 64 | | EBool b -> 65 | b 66 | 67 | | ENot e -> 68 | not (eval' e) 69 | 70 | | EAnd (e1, e2) -> 71 | (eval' e1) && (eval' e2) 72 | 73 | | EOr (e1, e2) -> 74 | (eval' e1) || (eval' e2) 75 | 76 | | EFlag nm -> 77 | let v = 78 | var_get nm 79 | in 80 | assert(v = "true" || v = "false"); 81 | (v = "true") 82 | 83 | | ETest (nm, vl) -> 84 | let v = 85 | var_get nm 86 | in 87 | (v = vl) 88 | in 89 | eval' t 90 | 91 | 92 | let choose ?printer ?name var_get lst = 93 | let rec choose_aux = 94 | function 95 | | (cond, vl) :: tl -> 96 | if eval var_get cond then 97 | vl 98 | else 99 | choose_aux tl 100 | | [] -> 101 | let str_lst = 102 | if lst = [] then 103 | s_ "" 104 | else 105 | String.concat 106 | (s_ ", ") 107 | (List.map 108 | (fun (cond, vl) -> 109 | match printer with 110 | | Some p -> p vl 111 | | None -> s_ "") 112 | lst) 113 | in 114 | match name with 115 | | Some nm -> 116 | failwith 117 | (Printf.sprintf 118 | (f_ "No result for the choice list '%s': %s") 119 | nm str_lst) 120 | | None -> 121 | failwith 122 | (Printf.sprintf 123 | (f_ "No result for a choice list: %s") 124 | str_lst) 125 | in 126 | choose_aux (List.rev lst) 127 | 128 | 129 | end 130 | 131 | 132 | # 132 "myocamlbuild.ml" 133 | module BaseEnvLight = struct 134 | (* # 22 "src/base/BaseEnvLight.ml" *) 135 | 136 | 137 | module MapString = Map.Make(String) 138 | 139 | 140 | type t = string MapString.t 141 | 142 | 143 | let default_filename = 144 | Filename.concat 145 | (Sys.getcwd ()) 146 | "setup.data" 147 | 148 | 149 | let load ?(allow_empty=false) ?(filename=default_filename) () = 150 | if Sys.file_exists filename then 151 | begin 152 | let chn = 153 | open_in_bin filename 154 | in 155 | let st = 156 | Stream.of_channel chn 157 | in 158 | let line = 159 | ref 1 160 | in 161 | let st_line = 162 | Stream.from 163 | (fun _ -> 164 | try 165 | match Stream.next st with 166 | | '\n' -> incr line; Some '\n' 167 | | c -> Some c 168 | with Stream.Failure -> None) 169 | in 170 | let lexer = 171 | Genlex.make_lexer ["="] st_line 172 | in 173 | let rec read_file mp = 174 | match Stream.npeek 3 lexer with 175 | | [Genlex.Ident nm; Genlex.Kwd "="; Genlex.String value] -> 176 | Stream.junk lexer; 177 | Stream.junk lexer; 178 | Stream.junk lexer; 179 | read_file (MapString.add nm value mp) 180 | | [] -> 181 | mp 182 | | _ -> 183 | failwith 184 | (Printf.sprintf 185 | "Malformed data file '%s' line %d" 186 | filename !line) 187 | in 188 | let mp = 189 | read_file MapString.empty 190 | in 191 | close_in chn; 192 | mp 193 | end 194 | else if allow_empty then 195 | begin 196 | MapString.empty 197 | end 198 | else 199 | begin 200 | failwith 201 | (Printf.sprintf 202 | "Unable to load environment, the file '%s' doesn't exist." 203 | filename) 204 | end 205 | 206 | 207 | let rec var_expand str env = 208 | let buff = 209 | Buffer.create ((String.length str) * 2) 210 | in 211 | Buffer.add_substitute 212 | buff 213 | (fun var -> 214 | try 215 | var_expand (MapString.find var env) env 216 | with Not_found -> 217 | failwith 218 | (Printf.sprintf 219 | "No variable %s defined when trying to expand %S." 220 | var 221 | str)) 222 | str; 223 | Buffer.contents buff 224 | 225 | 226 | let var_get name env = 227 | var_expand (MapString.find name env) env 228 | 229 | 230 | let var_choose lst env = 231 | OASISExpr.choose 232 | (fun nm -> var_get nm env) 233 | lst 234 | end 235 | 236 | 237 | # 237 "myocamlbuild.ml" 238 | module MyOCamlbuildFindlib = struct 239 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildFindlib.ml" *) 240 | 241 | 242 | (** OCamlbuild extension, copied from 243 | * http://brion.inria.fr/gallium/index.php/Using_ocamlfind_with_ocamlbuild 244 | * by N. Pouillard and others 245 | * 246 | * Updated on 2009/02/28 247 | * 248 | * Modified by Sylvain Le Gall 249 | *) 250 | open Ocamlbuild_plugin 251 | 252 | type conf = 253 | { no_automatic_syntax: bool; 254 | } 255 | 256 | (* these functions are not really officially exported *) 257 | let run_and_read = 258 | Ocamlbuild_pack.My_unix.run_and_read 259 | 260 | 261 | let blank_sep_strings = 262 | Ocamlbuild_pack.Lexers.blank_sep_strings 263 | 264 | 265 | let exec_from_conf exec = 266 | let exec = 267 | let env_filename = Pathname.basename BaseEnvLight.default_filename in 268 | let env = BaseEnvLight.load ~filename:env_filename ~allow_empty:true () in 269 | try 270 | BaseEnvLight.var_get exec env 271 | with Not_found -> 272 | Printf.eprintf "W: Cannot get variable %s\n" exec; 273 | exec 274 | in 275 | let fix_win32 str = 276 | if Sys.os_type = "Win32" then begin 277 | let buff = Buffer.create (String.length str) in 278 | (* Adapt for windowsi, ocamlbuild + win32 has a hard time to handle '\\'. 279 | *) 280 | String.iter 281 | (fun c -> Buffer.add_char buff (if c = '\\' then '/' else c)) 282 | str; 283 | Buffer.contents buff 284 | end else begin 285 | str 286 | end 287 | in 288 | fix_win32 exec 289 | 290 | let split s ch = 291 | let buf = Buffer.create 13 in 292 | let x = ref [] in 293 | let flush () = 294 | x := (Buffer.contents buf) :: !x; 295 | Buffer.clear buf 296 | in 297 | String.iter 298 | (fun c -> 299 | if c = ch then 300 | flush () 301 | else 302 | Buffer.add_char buf c) 303 | s; 304 | flush (); 305 | List.rev !x 306 | 307 | 308 | let split_nl s = split s '\n' 309 | 310 | 311 | let before_space s = 312 | try 313 | String.before s (String.index s ' ') 314 | with Not_found -> s 315 | 316 | (* ocamlfind command *) 317 | let ocamlfind x = S[Sh (exec_from_conf "ocamlfind"); x] 318 | 319 | (* This lists all supported packages. *) 320 | let find_packages () = 321 | List.map before_space (split_nl & run_and_read (exec_from_conf "ocamlfind" ^ " list")) 322 | 323 | 324 | (* Mock to list available syntaxes. *) 325 | let find_syntaxes () = ["camlp4o"; "camlp4r"] 326 | 327 | 328 | let well_known_syntax = [ 329 | "camlp4.quotations.o"; 330 | "camlp4.quotations.r"; 331 | "camlp4.exceptiontracer"; 332 | "camlp4.extend"; 333 | "camlp4.foldgenerator"; 334 | "camlp4.listcomprehension"; 335 | "camlp4.locationstripper"; 336 | "camlp4.macro"; 337 | "camlp4.mapgenerator"; 338 | "camlp4.metagenerator"; 339 | "camlp4.profiler"; 340 | "camlp4.tracer" 341 | ] 342 | 343 | 344 | let dispatch conf = 345 | function 346 | | After_options -> 347 | (* By using Before_options one let command line options have an higher 348 | * priority on the contrary using After_options will guarantee to have 349 | * the higher priority override default commands by ocamlfind ones *) 350 | Options.ocamlc := ocamlfind & A"ocamlc"; 351 | Options.ocamlopt := ocamlfind & A"ocamlopt"; 352 | Options.ocamldep := ocamlfind & A"ocamldep"; 353 | Options.ocamldoc := ocamlfind & A"ocamldoc"; 354 | Options.ocamlmktop := ocamlfind & A"ocamlmktop"; 355 | Options.ocamlmklib := ocamlfind & A"ocamlmklib" 356 | 357 | | After_rules -> 358 | 359 | (* When one link an OCaml library/binary/package, one should use 360 | * -linkpkg *) 361 | flag ["ocaml"; "link"; "program"] & A"-linkpkg"; 362 | 363 | if not (conf.no_automatic_syntax) then begin 364 | (* For each ocamlfind package one inject the -package option when 365 | * compiling, computing dependencies, generating documentation and 366 | * linking. *) 367 | List.iter 368 | begin fun pkg -> 369 | let base_args = [A"-package"; A pkg] in 370 | (* TODO: consider how to really choose camlp4o or camlp4r. *) 371 | let syn_args = [A"-syntax"; A "camlp4o"] in 372 | let (args, pargs) = 373 | (* Heuristic to identify syntax extensions: whether they end in 374 | ".syntax"; some might not. 375 | *) 376 | if Filename.check_suffix pkg "syntax" || 377 | List.mem pkg well_known_syntax then 378 | (syn_args @ base_args, syn_args) 379 | else 380 | (base_args, []) 381 | in 382 | flag ["ocaml"; "compile"; "pkg_"^pkg] & S args; 383 | flag ["ocaml"; "ocamldep"; "pkg_"^pkg] & S args; 384 | flag ["ocaml"; "doc"; "pkg_"^pkg] & S args; 385 | flag ["ocaml"; "link"; "pkg_"^pkg] & S base_args; 386 | flag ["ocaml"; "infer_interface"; "pkg_"^pkg] & S args; 387 | 388 | (* TODO: Check if this is allowed for OCaml < 3.12.1 *) 389 | flag ["ocaml"; "compile"; "package("^pkg^")"] & S pargs; 390 | flag ["ocaml"; "ocamldep"; "package("^pkg^")"] & S pargs; 391 | flag ["ocaml"; "doc"; "package("^pkg^")"] & S pargs; 392 | flag ["ocaml"; "infer_interface"; "package("^pkg^")"] & S pargs; 393 | end 394 | (find_packages ()); 395 | end; 396 | 397 | (* Like -package but for extensions syntax. Morover -syntax is useless 398 | * when linking. *) 399 | List.iter begin fun syntax -> 400 | flag ["ocaml"; "compile"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 401 | flag ["ocaml"; "ocamldep"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 402 | flag ["ocaml"; "doc"; "syntax_"^syntax] & S[A"-syntax"; A syntax]; 403 | flag ["ocaml"; "infer_interface"; "syntax_"^syntax] & 404 | S[A"-syntax"; A syntax]; 405 | end (find_syntaxes ()); 406 | 407 | (* The default "thread" tag is not compatible with ocamlfind. 408 | * Indeed, the default rules add the "threads.cma" or "threads.cmxa" 409 | * options when using this tag. When using the "-linkpkg" option with 410 | * ocamlfind, this module will then be added twice on the command line. 411 | * 412 | * To solve this, one approach is to add the "-thread" option when using 413 | * the "threads" package using the previous plugin. 414 | *) 415 | flag ["ocaml"; "pkg_threads"; "compile"] (S[A "-thread"]); 416 | flag ["ocaml"; "pkg_threads"; "doc"] (S[A "-I"; A "+threads"]); 417 | flag ["ocaml"; "pkg_threads"; "link"] (S[A "-thread"]); 418 | flag ["ocaml"; "pkg_threads"; "infer_interface"] (S[A "-thread"]); 419 | flag ["ocaml"; "package(threads)"; "compile"] (S[A "-thread"]); 420 | flag ["ocaml"; "package(threads)"; "doc"] (S[A "-I"; A "+threads"]); 421 | flag ["ocaml"; "package(threads)"; "link"] (S[A "-thread"]); 422 | flag ["ocaml"; "package(threads)"; "infer_interface"] (S[A "-thread"]); 423 | 424 | | _ -> 425 | () 426 | end 427 | 428 | module MyOCamlbuildBase = struct 429 | (* # 22 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 430 | 431 | 432 | (** Base functions for writing myocamlbuild.ml 433 | @author Sylvain Le Gall 434 | *) 435 | 436 | 437 | 438 | 439 | 440 | open Ocamlbuild_plugin 441 | module OC = Ocamlbuild_pack.Ocaml_compiler 442 | 443 | 444 | type dir = string 445 | type file = string 446 | type name = string 447 | type tag = string 448 | 449 | 450 | (* # 62 "src/plugins/ocamlbuild/MyOCamlbuildBase.ml" *) 451 | 452 | 453 | type t = 454 | { 455 | lib_ocaml: (name * dir list * string list) list; 456 | lib_c: (name * dir * file list) list; 457 | flags: (tag list * (spec OASISExpr.choices)) list; 458 | (* Replace the 'dir: include' from _tags by a precise interdepends in 459 | * directory. 460 | *) 461 | includes: (dir * dir list) list; 462 | } 463 | 464 | 465 | let env_filename = 466 | Pathname.basename 467 | BaseEnvLight.default_filename 468 | 469 | 470 | let dispatch_combine lst = 471 | fun e -> 472 | List.iter 473 | (fun dispatch -> dispatch e) 474 | lst 475 | 476 | 477 | let tag_libstubs nm = 478 | "use_lib"^nm^"_stubs" 479 | 480 | 481 | let nm_libstubs nm = 482 | nm^"_stubs" 483 | 484 | 485 | let dispatch t e = 486 | let env = 487 | BaseEnvLight.load 488 | ~filename:env_filename 489 | ~allow_empty:true 490 | () 491 | in 492 | match e with 493 | | Before_options -> 494 | let no_trailing_dot s = 495 | if String.length s >= 1 && s.[0] = '.' then 496 | String.sub s 1 ((String.length s) - 1) 497 | else 498 | s 499 | in 500 | List.iter 501 | (fun (opt, var) -> 502 | try 503 | opt := no_trailing_dot (BaseEnvLight.var_get var env) 504 | with Not_found -> 505 | Printf.eprintf "W: Cannot get variable %s\n" var) 506 | [ 507 | Options.ext_obj, "ext_obj"; 508 | Options.ext_lib, "ext_lib"; 509 | Options.ext_dll, "ext_dll"; 510 | ] 511 | 512 | | After_rules -> 513 | (* Declare OCaml libraries *) 514 | List.iter 515 | (function 516 | | nm, [], intf_modules -> 517 | ocaml_lib nm; 518 | let cmis = 519 | List.map (fun m -> (String.uncapitalize m) ^ ".cmi") 520 | intf_modules in 521 | dep ["ocaml"; "link"; "library"; "file:"^nm^".cma"] cmis 522 | | nm, dir :: tl, intf_modules -> 523 | ocaml_lib ~dir:dir (dir^"/"^nm); 524 | List.iter 525 | (fun dir -> 526 | List.iter 527 | (fun str -> 528 | flag ["ocaml"; "use_"^nm; str] (S[A"-I"; P dir])) 529 | ["compile"; "infer_interface"; "doc"]) 530 | tl; 531 | let cmis = 532 | List.map (fun m -> dir^"/"^(String.uncapitalize m)^".cmi") 533 | intf_modules in 534 | dep ["ocaml"; "link"; "library"; "file:"^dir^"/"^nm^".cma"] 535 | cmis) 536 | t.lib_ocaml; 537 | 538 | (* Declare directories dependencies, replace "include" in _tags. *) 539 | List.iter 540 | (fun (dir, include_dirs) -> 541 | Pathname.define_context dir include_dirs) 542 | t.includes; 543 | 544 | (* Declare C libraries *) 545 | List.iter 546 | (fun (lib, dir, headers) -> 547 | (* Handle C part of library *) 548 | flag ["link"; "library"; "ocaml"; "byte"; tag_libstubs lib] 549 | (S[A"-dllib"; A("-l"^(nm_libstubs lib)); A"-cclib"; 550 | A("-l"^(nm_libstubs lib))]); 551 | 552 | flag ["link"; "library"; "ocaml"; "native"; tag_libstubs lib] 553 | (S[A"-cclib"; A("-l"^(nm_libstubs lib))]); 554 | 555 | flag ["link"; "program"; "ocaml"; "byte"; tag_libstubs lib] 556 | (S[A"-dllib"; A("dll"^(nm_libstubs lib))]); 557 | 558 | (* When ocaml link something that use the C library, then one 559 | need that file to be up to date. 560 | This holds both for programs and for libraries. 561 | *) 562 | dep ["link"; "ocaml"; tag_libstubs lib] 563 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 564 | 565 | dep ["compile"; "ocaml"; tag_libstubs lib] 566 | [dir/"lib"^(nm_libstubs lib)^"."^(!Options.ext_lib)]; 567 | 568 | (* TODO: be more specific about what depends on headers *) 569 | (* Depends on .h files *) 570 | dep ["compile"; "c"] 571 | headers; 572 | 573 | (* Setup search path for lib *) 574 | flag ["link"; "ocaml"; "use_"^lib] 575 | (S[A"-I"; P(dir)]); 576 | ) 577 | t.lib_c; 578 | 579 | (* Add flags *) 580 | List.iter 581 | (fun (tags, cond_specs) -> 582 | let spec = BaseEnvLight.var_choose cond_specs env in 583 | let rec eval_specs = 584 | function 585 | | S lst -> S (List.map eval_specs lst) 586 | | A str -> A (BaseEnvLight.var_expand str env) 587 | | spec -> spec 588 | in 589 | flag tags & (eval_specs spec)) 590 | t.flags 591 | | _ -> 592 | () 593 | 594 | 595 | let dispatch_default conf t = 596 | dispatch_combine 597 | [ 598 | dispatch t; 599 | MyOCamlbuildFindlib.dispatch conf; 600 | ] 601 | 602 | 603 | end 604 | 605 | 606 | # 606 "myocamlbuild.ml" 607 | open Ocamlbuild_plugin;; 608 | let package_default = 609 | {MyOCamlbuildBase.lib_ocaml = []; lib_c = []; flags = []; includes = []} 610 | ;; 611 | 612 | let conf = {MyOCamlbuildFindlib.no_automatic_syntax = false} 613 | 614 | let dispatch_default = MyOCamlbuildBase.dispatch_default conf package_default;; 615 | 616 | # 617 "myocamlbuild.ml" 617 | (* OASIS_STOP *) 618 | (* Ocamlbuild_plugin.dispatch dispatch_default;; *) 619 | -------------------------------------------------------------------------------- /src/META: -------------------------------------------------------------------------------- 1 | # OASIS_START 2 | # DO NOT EDIT (digest: a4f407cdb229d46a3346b75b3edb4c5e) 3 | version = "0.0.0" 4 | description = "A compiler from ML to C++ template language" 5 | requires = "ppx_deriving.show" 6 | archive(byte) = "libevilml.cma" 7 | archive(byte, plugin) = "libevilml.cma" 8 | archive(native) = "libevilml.cmxa" 9 | archive(native, plugin) = "libevilml.cmxs" 10 | exists_if = "libevilml.cma" 11 | # OASIS_STOP 12 | 13 | -------------------------------------------------------------------------------- /src/emlAlpha.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open EmlUtils 19 | open Format 20 | open EmlTypedExpr 21 | open EmlBoxing 22 | 23 | type renamer = StringSet.t * (string * string) list 24 | 25 | let make_renamer tbl0 tops = 26 | let add ?(loc = EmlLocation.dummy) (seen, tbl) id1 id2 = 27 | if StringSet.mem id2 seen 28 | then errorf ~loc "Duplicated identifier %s" id2 (); 29 | (StringSet.add id2 seen, (id1, id2) :: tbl) 30 | in 31 | let aux rnm top = match top.EmlLocation.data with 32 | | Top_code _ | Top_type _ -> rnm 33 | | Top_let (_, id, _, _) -> add ~loc:top.EmlLocation.loc rnm id id 34 | in 35 | let rnm = 36 | List.fold_left (fun rnm (id1, id2) -> add rnm id1 id2) 37 | (StringSet.empty, []) tbl0 in 38 | List.fold_left aux rnm tops 39 | 40 | let genid seen s = 41 | let rec aux n = 42 | let s' = s ^ string_of_int n in 43 | if StringSet.mem s' seen then aux (n+1) else s' 44 | in 45 | let s' = if StringSet.mem s seen then aux 1 else s in 46 | (StringSet.add s' seen, s') 47 | 48 | let rename_args tbl = List.map (Option.map (fun x -> List.assoc x tbl)) 49 | 50 | let rec conv_expr tbl seen e = match e.data with 51 | | Const _ | Error -> (seen, e) 52 | | Ext (Tag e0) -> 53 | let (seen', e0') = conv_expr tbl seen e0 in 54 | (seen', { e with data = Ext (Tag e0') }) 55 | | Ext (Proj (e0, n, i)) -> 56 | let (seen', e0') = conv_expr tbl seen e0 in 57 | (seen', { e with data = Ext (Proj (e0', n, i)) }) 58 | | Ext (Box e0) -> 59 | let (seen', e0') = conv_expr tbl seen e0 in 60 | (seen', { e with data = Ext (Box e0') }) 61 | | Ext (Unbox e0) -> 62 | let (seen', e0') = conv_expr tbl seen e0 in 63 | (seen', { e with data = Ext (Unbox e0') }) 64 | | Var s -> (seen, { e with data = Var (List.assoc s tbl) }) 65 | | Constr (s, el) -> 66 | let (seen', el') = List.fold_map (conv_expr tbl) seen el in 67 | (seen', { e with data = Constr (s, el') }) 68 | | Tuple el -> 69 | let (seen', el') = List.fold_map (conv_expr tbl) seen el in 70 | (seen', { e with data = Tuple el' }) 71 | | Op op -> 72 | let (seen', op') = EmlOp.fold_map (conv_expr tbl) seen op in 73 | (seen', { e with data = Op op' }) 74 | | If (e1, e2, e3) -> 75 | let (seen', e1') = conv_expr tbl seen e1 in 76 | let (seen', e2') = conv_expr tbl seen' e2 in 77 | let (seen', e3') = conv_expr tbl seen' e3 in 78 | (seen', { e with data = If (e1', e2', e3') }) 79 | | App (e0, el) -> 80 | let (seen', e0') = conv_expr tbl seen e0 in 81 | let (seen', el') = List.fold_map (conv_expr tbl) seen' el in 82 | (seen', { e with data = App (e0', el') }) 83 | | Abs (args, e0) -> 84 | let org_args = List.filter_map (fun x -> x) args in 85 | let (seen', new_args) = List.fold_map genid seen org_args in 86 | let tbl' = List.combine org_args new_args @ tbl in 87 | let (seen', e0') = conv_expr tbl' seen' e0 in 88 | (seen', { e with data = Abs (rename_args tbl' args, e0') }) 89 | | Let (rf, id, ts, e1, e2) -> 90 | let (seen', new_id) = genid seen id in 91 | let tbl' = (id, new_id) :: tbl in 92 | let (seen', e1') = if rf then conv_expr tbl' seen' e1 93 | else conv_expr tbl seen' e1 in 94 | let (seen', e2') = conv_expr tbl' seen' e2 in 95 | (seen', { e with data = Let (rf, new_id, ts, e1', e2') }) 96 | 97 | let convert (seen, tbl) tops = 98 | let aux = function (* top-level identifiers will not be renamed. *) 99 | | Top_code _ | Top_type _ as e -> e 100 | | Top_let(rf, id, ts, e) -> Top_let(rf, id, ts, snd (conv_expr tbl seen e)) 101 | in 102 | List.map (EmlLocation.map aux) tops 103 | -------------------------------------------------------------------------------- /src/emlAlpha.mli: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | type renamer 19 | 20 | val make_renamer : (string * string) list -> EmlBoxing.top list -> renamer 21 | 22 | val convert : renamer -> EmlBoxing.top list -> EmlBoxing.top list 23 | -------------------------------------------------------------------------------- /src/emlAssoc.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open Format 19 | open EmlUtils 20 | open EmlTypedExpr 21 | open EmlRemoveMatch 22 | 23 | let fresh_then_name = gen_fresh_name "__ml_then" 24 | let fresh_else_name = gen_fresh_name "__ml_else" 25 | 26 | (** [let_wrap id e] returns expression [let id = e in id]. *) 27 | let let_wrap id e = 28 | mk_exp_var ~loc:e.loc id e.typ 29 | |> mk_exp_simple_let ~loc:e.loc false id e 30 | 31 | (** [lazy_wrap id e] wraps expression [e] as [let id = e in id]. *) 32 | let lazy_wrap id e = 33 | let e_abs = { loc = e.loc; typ = EmlType.Arrow ([EmlType.Unit], e.typ); 34 | data = Abs ([None], e); } in 35 | let_wrap id e_abs 36 | 37 | (** [if e1 then e2 else e3] is converted into 38 | [(if e1 39 | then (let __ml_then _ = e2 in __then) 40 | else (let __ml_else _ = e3 in __else)) ()] 41 | because C++ template if is implemented as a function (call-by-value). *) 42 | let conv_if ~loc e1 e2 e3 = 43 | let e2' = lazy_wrap (fresh_then_name ()) e2 in 44 | let e3' = lazy_wrap (fresh_else_name ()) e3 in 45 | let e_if = mk_exp_if ~loc e1 e2' e3' in 46 | mk_exp_app ~loc e_if [mk_exp_unit ~loc ()] 47 | 48 | let rec conv_expr e = match e.data with 49 | | Const _ | Error | Var _ -> e 50 | | Ext (Tag e0) -> { e with data = Ext (Tag (conv_expr e0)) } 51 | | Ext (Proj (e0, n, i)) -> { e with data = Ext (Proj (conv_expr e0, n, i)) } 52 | | Tuple el -> { e with data = Tuple (List.map conv_expr el) } 53 | | Op op -> { e with data = Op (EmlOp.map conv_expr op) } 54 | | Abs (args, e0) -> { e with data = Abs (args, conv_expr e0) } 55 | | App (e0, el) -> 56 | { e with data = App (conv_expr e0, List.map conv_expr el) } 57 | | Constr (id, el) -> 58 | { e with data = Constr (id, List.map conv_expr el) } 59 | | If (e1, e2, e3) -> 60 | conv_if ~loc:e.loc (conv_expr e1) (conv_expr e2) (conv_expr e3) 61 | | Let (rf, id, ts, e1, e2) -> 62 | { e with data = Let (rf, id, ts, conv_expr e1, conv_expr e2) } 63 | 64 | let convert = map conv_expr 65 | (* 66 | let rec conv_expr tbl e = match e.data with 67 | | Const _ | Ext Match_error -> e 68 | | Var x -> 69 | (try let f = List.assoc x tbl in f ~loc:e.loc 70 | with Not_found -> e) 71 | | Ext (Tag e0) -> { e with data = Ext (Tag (conv_expr tbl e0)) } 72 | | Ext (Proj (e0, i)) -> { e with data = Ext (Proj (conv_expr tbl e0, i)) } 73 | | Tuple el -> { e with data = Tuple (List.map (conv_expr tbl) el) } 74 | | EmlOp op -> { e with data = EmlOp (EmlOp.map (conv_expr tbl) op) } 75 | | Abs (args, e0) -> { e with data = Abs (args, conv_expr tbl e0) } 76 | | App (e0, el) -> 77 | { e with data = App (conv_expr tbl e0, 78 | List.map (conv_expr tbl >> conv_arg) el) } 79 | | Constr (id, el) -> 80 | { e with data = Constr (id, List.map (conv_expr tbl >> conv_arg) el) } 81 | | If (e1, e2, e3) -> 82 | conv_if ~loc:e.loc (conv_expr tbl e1) (conv_expr tbl e2) (conv_expr tbl e3) 83 | | Let (rf, id, ts, e1, e2) -> 84 | if rf 85 | then { e with data = Let (false, id, ts, conv_let_rec_rhs tbl id e1, 86 | conv_expr tbl e2) } 87 | else { e with data = Let (rf, id, ts, conv_expr tbl e1, conv_expr tbl e2) } 88 | 89 | (** [let rec id1 = e1] |-> [let rec id2 n = [id1 |-> id2 (n+1)]e1 in id2 0] *) 90 | and conv_let_rec_rhs tbl id1 e1 = 91 | let cnt = "__cnt" in 92 | let id2 = "__rec_" ^ id1 in 93 | let t_fun = EmlType.Arrow ([EmlType.Int], e1.typ) in 94 | let e_id2 = mk_exp_var ~loc:e1.loc id2 t_fun in 95 | let e1' = conv_let_rec_subst tbl id1 e_id2 cnt e1 in 96 | let e_abs = { loc = e1.loc; typ = t_fun; 97 | data = Abs ([Some cnt], e1'); } in (* fun __cnt -> e1' *) 98 | let e_app = mk_exp_app ~loc:e1.loc (mk_exp_var ~loc:e1.loc id2 t_fun) 99 | [mk_exp_int ~loc:e1.loc 0] in (* __rec_id 0 *) 100 | mk_exp_simple_let ~loc:e1.loc true id2 e_abs e_app 101 | 102 | (** [conv_let_rec_subst tbl id1 id2 cnt e] substitutes all occurence of [id1] in 103 | expression [e] with [id2 (cnt + 1)]. *) 104 | and conv_let_rec_subst tbl id1 id2 cnt e = 105 | let mk_subst ~loc = (* Generate expr [id2 (cnt + 1)] *) 106 | let e_vcnt = mk_exp_var ~loc cnt EmlType.Int in 107 | let e_1 = mk_exp_int ~loc 1 in 108 | let e_sub = { loc; typ = EmlType.Int; data = EmlOp (EmlOp.Add (e_vcnt, e_1)); } in 109 | mk_exp_app ~loc { id2 with loc } [e_sub] 110 | in 111 | let tbl' = (id1, mk_subst) :: tbl in 112 | conv_expr tbl' e 113 | 114 | let convert = 115 | let aux = function 116 | | Top_variant_type (name, args, cs) -> Top_variant_type (name, args, cs) 117 | | Top_let (rf, id, ts, e) -> 118 | if rf then Top_let (false, id, ts, conv_let_rec_rhs [] id e) 119 | else Top_let (rf, id, ts, conv_expr [] e) 120 | in 121 | List.map (L.map aux) 122 | *) 123 | -------------------------------------------------------------------------------- /src/emlAssoc.mli: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | val convert : EmlRemoveMatch.top list -> EmlRemoveMatch.top list 19 | -------------------------------------------------------------------------------- /src/emlBoxing.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open EmlUtils 19 | open Format 20 | open EmlTypedExpr 21 | 22 | module M = EmlRemoveMatch 23 | 24 | type expr = ext_expr base_expr [@@deriving show] 25 | and ext_expr = 26 | | Box of expr 27 | | Unbox of expr 28 | | Tag of expr (* Obtain the tag of a data constructor *) 29 | | Proj of expr * int * int (* Projection operator *) 30 | 31 | type top = ext_expr base_top [@@deriving show] 32 | 33 | (** Insert boxing if a given expression has a base type. *) 34 | let box_expr e = 35 | let (need, typ) = EmlType.box_type e.typ in 36 | { loc = e.loc; typ; data = if need then Ext (Box e) else e.data; } 37 | 38 | (** Insert unboxing if a given expression has a boxed type. *) 39 | let unbox_expr e = match EmlType.unbox_type e.typ with 40 | | (true, typ) -> { loc = e.loc; typ; data = Ext (Unbox e); } 41 | | _ -> e 42 | 43 | type expected_type = 44 | | Nothing 45 | | Boxed 46 | | Unboxed 47 | 48 | let box_unbox_type tt t = match tt with 49 | | Nothing -> t 50 | | Boxed -> snd (EmlType.box_type t) 51 | | Unboxed -> snd (EmlType.unbox_type t) 52 | 53 | let box_unbox_scheme tt ts = match tt with 54 | | Nothing -> ts 55 | | Boxed -> snd (EmlType.box_scheme ts) 56 | | Unboxed -> snd (EmlType.unbox_scheme ts) 57 | 58 | let box_unbox_expr tt e = match tt with 59 | | Nothing -> e 60 | | Boxed -> box_expr e 61 | | Unboxed -> unbox_expr e 62 | 63 | let rec conv_expr tt ctx e = match e.data with 64 | | Const c -> box_unbox_expr tt { e with data = Const c } 65 | | Var id -> 66 | let typ = (*try EmlType.instantiate (List.assoc id ctx) 67 | with Not_found -> e.typ*) 68 | EmlType.instantiate (EmlContext.lookup_var ~loc:e.loc id ctx) in 69 | box_unbox_expr tt { e with data = Var id; typ } 70 | | Error -> (* box/unbox is not needed since Error has forall 'a. 'a. *) 71 | { e with data = Error; typ = box_unbox_type tt e.typ; } 72 | | Ext (M.Tag e0) -> 73 | box_unbox_expr tt { e with data = Ext (Tag (conv_expr Nothing ctx e0)) } 74 | | Let (rf, id, ts, e1, e2) -> 75 | let (ts', e1') = conv_let_rhs ctx rf id ts e1 in 76 | let e2' = conv_expr tt (EmlContext.add_var id ts' ctx) e2 in 77 | { e with data = Let (rf, id, ts', e1', e2'); typ = e2'.typ } 78 | (* Constructors: all arguments are boxed. *) 79 | | Constr (id, el) -> 80 | { e with typ = box_unbox_type tt e.typ; 81 | data = Constr (id, List.map (conv_expr Boxed ctx) el) } 82 | (* Projection: obtained elements are boxed. *) 83 | | Ext (M.Proj (e0, n, i)) -> 84 | let e0' = conv_expr Nothing ctx e0 in 85 | let (_, typ) = EmlType.box_type e.typ in 86 | { e with typ; data = Ext (Proj (e0', n, i)) } 87 | |> box_unbox_expr tt 88 | (* Tuples: elements of tuples are boxed. *) 89 | | Tuple el -> mk_exp_tuple ~loc:e.loc (List.map (conv_expr Boxed ctx) el) 90 | (* Operators: all arguments and a return value are unboxed. *) 91 | | Op op -> 92 | let op' = EmlOp.map (conv_expr Unboxed ctx) op in 93 | box_unbox_expr tt (mk_exp_op ~loc:e.loc op') 94 | (* If: the 1st argument is unboxed, others are boxed. *) 95 | | If (e1, e2, e3) -> 96 | mk_exp_if ~loc:e.loc (conv_expr Unboxed ctx e1) 97 | (conv_expr Boxed ctx e2) (conv_expr Boxed ctx e3) 98 | |> box_unbox_expr tt 99 | (* Functions: all arguments and return values of functions are boxed. *) 100 | | Abs (args, e0) -> 101 | let t_args = match EmlType.unarrow e.typ with 102 | | None -> assert false 103 | | Some (t_args, _) -> List.map (EmlType.box_type >> snd) t_args in 104 | let ctx' = EmlContext.add_args args t_args ctx in 105 | let e0' = conv_expr Boxed ctx' e0 in 106 | let t_fun = EmlType.Arrow (t_args, e0'.typ) in 107 | { loc = e.loc; typ = t_fun; data = Abs (args, e0'); } 108 | | App (e0, el) -> 109 | let e0' = conv_expr Boxed ctx e0 in 110 | let el' = List.map (conv_expr Boxed ctx) el in 111 | box_unbox_expr tt (mk_exp_app ~loc:e.loc e0' el') 112 | 113 | and conv_let_rhs ctx rf id ts e = 114 | let ts' = box_unbox_scheme Boxed ts in 115 | let ctx' = if rf then EmlContext.add_var id ts' ctx else ctx in 116 | let e' = conv_expr Boxed ctx' e in 117 | (ts', e') 118 | 119 | let conv_constr (tag, id, args) = 120 | (tag, id, List.map (EmlType.box_type >> snd) args) 121 | 122 | let convert ctx tops = 123 | let f_vtype _ ctx = function 124 | | EmlType.Variant (name, args, constrs) -> 125 | let constrs' = List.map conv_constr constrs in 126 | let decl = EmlType.Variant (name, args, constrs') in 127 | let ctx' = EmlContext.add_type decl ctx in 128 | (ctx', Top_type decl) 129 | in 130 | let f_let _ ctx rf id ts e = 131 | let (ts', e') = conv_let_rhs ctx rf id ts e in 132 | (EmlContext.add_var id ts' ctx, Top_let (rf, id, ts', e')) 133 | in 134 | snd (fold_map f_vtype f_let ctx tops) 135 | -------------------------------------------------------------------------------- /src/emlBoxing.mli: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | type expr = ext_expr EmlTypedExpr.base_expr [@@deriving show] 19 | and ext_expr = 20 | | Box of expr 21 | | Unbox of expr 22 | | Tag of expr (* Obtain the tag of a data constructor *) 23 | | Proj of expr * int * int (* Projection operator *) 24 | 25 | type top = ext_expr EmlTypedExpr.base_top [@@deriving show] 26 | 27 | val convert : 28 | EmlContext.t -> 29 | EmlRemoveMatch.top list -> 30 | top list 31 | -------------------------------------------------------------------------------- /src/emlCompile.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open EmlUtils 19 | open Format 20 | 21 | module L = EmlLocation 22 | 23 | (** Build-in functions and their types *) 24 | let builtin_ctx = 25 | [ 26 | "succ", EmlType.Arrow ([EmlType.Int], EmlType.Int); 27 | "pred", EmlType.Arrow ([EmlType.Int], EmlType.Int); 28 | "min", EmlType.Arrow ([EmlType.Int; EmlType.Int], EmlType.Int); 29 | "max", EmlType.Arrow ([EmlType.Int; EmlType.Int], EmlType.Int); 30 | "char_of_int", EmlType.Arrow ([EmlType.Int], EmlType.Char); 31 | "int_of_char", EmlType.Arrow ([EmlType.Char], EmlType.Int); 32 | ] 33 | |> List.fold_left 34 | (fun ctx (id, t) -> EmlContext.add_var id (EmlType.scheme t) ctx) 35 | EmlContext.empty 36 | 37 | (** Build-in functions and their real names *) 38 | let builtin_tbl = 39 | [ 40 | "succ", "__ml_succ"; 41 | "pred", "__ml_pred"; 42 | "min", "__ml_min"; 43 | "max", "__ml_max"; 44 | "int_of_char", "__ml_int_of_char"; 45 | "char_of_int", "__ml_char_of_int"; 46 | ] 47 | 48 | (** Set an input filename to `lexbuf'. *) 49 | let init_lexbuf lexbuf fname = 50 | let open Lexing in 51 | lexbuf.lex_curr_p <- { pos_fname = fname; pos_lnum = 1; 52 | pos_bol = 0; pos_cnum = 0; } 53 | 54 | let parsing loader = 55 | let rec aux used tops0 fname lexbuf = 56 | init_lexbuf lexbuf fname; 57 | let tops = EmlParser.main EmlLexer.main lexbuf in (* parsing *) 58 | (* Load .ml files specified by #use-directives. *) 59 | List.fold_right 60 | (fun top tops' -> 61 | match top.L.data with 62 | | EmlSyntax.Top_use fname -> 63 | if List.mem fname used then tops' 64 | else aux (fname :: used) tops' fname (loader top.L.loc fname) 65 | | _ -> top :: tops') 66 | tops tops0 67 | in 68 | aux [] [] 69 | 70 | let default_loader _ = failwith "#use-directive is not supported" 71 | 72 | let run ?(loader = default_loader) ?(hook_typing = ignore) ~header fname lexbuf = 73 | parsing loader fname lexbuf 74 | |> EmlTyping.typing builtin_ctx (* type inference *) 75 | |> (fun tops -> hook_typing tops ; tops) (* Hook typing results *) 76 | |> EmlRemoveMatch.convert (* Convert match-expressions into if-expressions *) 77 | |> EmlUnCurrying.convert (* UnCurrying functions *) 78 | |> EmlDCE.convert (* Dead code elimination *) 79 | |> EmlAssoc.convert (* Transformation for C++ *) 80 | |> EmlBoxing.convert builtin_ctx (* Insert boxing/unboxing *) 81 | |> (fun tops -> (* Alpha conversion (renaming identifiers) *) 82 | EmlAlpha.convert (EmlAlpha.make_renamer builtin_tbl tops) tops) 83 | |> EmlFlatLet.convert (* Flatten let-expressions *) 84 | |> EmlCpp.convert ~header (* Convert ML code into C++ template code *) 85 | -------------------------------------------------------------------------------- /src/emlCompile.mli: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | val run : 19 | ?loader:(EmlLocation.t -> string -> Lexing.lexbuf) -> 20 | ?hook_typing:(EmlTyping.top list -> unit) -> 21 | header:string -> 22 | string -> 23 | Lexing.lexbuf -> EmlCpp.decl list 24 | -------------------------------------------------------------------------------- /src/emlConfig.ml.ab: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | let include_dir = "$(datadir)/$(pkg_name)" -------------------------------------------------------------------------------- /src/emlContext.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open EmlUtils 19 | 20 | type elt = 21 | | Var of string * EmlType.scheme 22 | | Constr of string * EmlType.constr_tag * EmlType.scheme 23 | | Type of EmlType.decl 24 | 25 | type t = elt list 26 | 27 | let empty = [] 28 | 29 | let add_var id tysc ctx = Var (id, tysc) :: ctx 30 | 31 | let add_args ids tys ctx = 32 | List.fold_left2 (fun acc t -> function 33 | | Some x -> Var (x, EmlType.scheme t) :: acc 34 | | None -> acc) ctx tys ids 35 | 36 | let add_type (EmlType.Variant (ty_name, ty_vars, constrs) as decl) ctx = 37 | let add_constr ctx (tag, c_name, c_args) = 38 | let tysc = EmlType.constr_scheme ty_name ty_vars c_args in 39 | Constr (c_name, tag, tysc) :: ctx 40 | in 41 | List.fold_left add_constr (Type decl :: ctx) constrs 42 | 43 | let lookup_var ~loc id ctx = 44 | let aux = function 45 | | Var (s, tysc) when id = s -> Some tysc 46 | | _ -> None 47 | in 48 | match List.find_map aux ctx with 49 | | Some tysc -> tysc 50 | | None -> errorf ~loc "Unbound variable `%s'" id () 51 | 52 | let lookup_constr ~loc id ctx = 53 | let aux = function 54 | | Constr (s, tag, tysc) when id = s -> 55 | Some (tag, EmlType.unarrow (EmlType.instantiate tysc)) 56 | | _ -> None 57 | in 58 | match List.find_map aux ctx with 59 | | Some (tag, Some (t_args, t_ret)) -> (tag, t_args, t_ret) 60 | | Some (_, None) -> errorf ~loc "Constructor %s has strange type" id () 61 | | None -> errorf ~loc "Unbound constructor `%s'" id () 62 | 63 | let lookup_type ~loc id ctx = 64 | let aux = function 65 | | Type (EmlType.Variant (s, _, _) as decl) when id = s -> Some decl 66 | | _ -> None 67 | in 68 | match List.find_map aux ctx with 69 | | Some decl -> decl 70 | | None -> errorf ~loc "Unbound type constructor `%s'" id () 71 | 72 | let fv_in_context = 73 | List.fold_left 74 | (fun acc -> function 75 | | Var (_, ts) -> EmlType.VarSet.union acc (EmlType.fv_in_scheme ts) 76 | | _ -> acc) 77 | EmlType.VarSet.empty 78 | 79 | let generalize_type ctx t = 80 | let bv = fv_in_context ctx in (* Type variables bound in a typing context *) 81 | let fv = EmlType.fv_in_type t in (* Type variables free in a type *) 82 | EmlType.generalize (EmlType.VarSet.diff fv bv) t 83 | -------------------------------------------------------------------------------- /src/emlContext.mli: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | type t 19 | 20 | val empty : t 21 | 22 | val add_var : string -> EmlType.scheme -> t -> t 23 | 24 | val add_args : string option list -> EmlType.t list -> t -> t 25 | 26 | val add_type : EmlType.decl -> t -> t 27 | 28 | val lookup_var : loc:EmlLocation.t -> string -> t -> EmlType.scheme 29 | 30 | val lookup_constr : 31 | loc:EmlLocation.t -> string -> t -> 32 | EmlType.constr_tag * EmlType.t list * EmlType.t 33 | 34 | val lookup_type : loc:EmlLocation.t -> string -> t -> EmlType.decl 35 | 36 | val fv_in_context : t -> EmlType.VarSet.t 37 | 38 | val generalize_type : t -> EmlType.t -> EmlType.scheme 39 | -------------------------------------------------------------------------------- /src/emlCpp.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open EmlUtils 19 | open Format 20 | 21 | module F = EmlFlatLet 22 | 23 | type template_flag = bool 24 | type typename_flag = bool 25 | 26 | type expr = 27 | { 28 | dep : bool; (* true if an expr is dependent on template parameters *) 29 | data : expr_desc; 30 | } 31 | and expr_desc = 32 | | Error 33 | | Const of EmlSyntax.const 34 | | Var of string 35 | | Op of expr EmlOp.t 36 | | App of expr * type_expr list 37 | | Tmember of template_flag * expr * string 38 | | Vmember of expr * string 39 | 40 | and type_expr = typename_flag * expr 41 | 42 | type decl = 43 | | Code of string 44 | | Static of string * EmlType.t * expr 45 | | EmlTypedef of string * type_expr 46 | | Class of string * decl list * decl list (* private/public *) 47 | | Template_class of string * string option list * decl list * decl list 48 | 49 | (** {2 Conversion} *) 50 | 51 | let member_fst = "fst" 52 | let member_snd = "snd" 53 | let member_tag = "tag" 54 | let member_val = "val" 55 | let member_fun = "fun" 56 | let member_ret = "type" 57 | 58 | let get_constr_name = function 59 | | "[]" -> "__ml_nil" 60 | | "::" -> "__ml_cons" 61 | | id -> id 62 | 63 | let mk_type_expr e : type_expr = match e.data with 64 | | Tmember (_, { dep = true; _ }, _) -> (true, e) 65 | | _ -> (false, e) 66 | 67 | let mk_exp_const c = { dep = false; data = Const c; } 68 | let mk_exp_var ?(deps = []) id = { dep = List.mem id deps; data = Var id; } 69 | let mk_exp_op op = { dep = EmlOp.exists (fun ei -> ei.dep) op; data = Op op; } 70 | let mk_exp_vmem e mem = { dep = e.dep; data = Vmember (e, mem); } 71 | let mk_exp_tmem ?(deps = []) ?(template = false) e mem = 72 | let flag = template && not (List.is_empty deps) in 73 | { dep = e.dep; data = Tmember (flag, e, mem); } 74 | 75 | let mk_exp_app e0 el = 76 | let dep = e0.dep || List.exists (fun ei -> ei.dep) el in 77 | { dep; data = App (e0, List.map mk_type_expr el); } 78 | 79 | let mk_exp_box ~typ e = 80 | mk_exp_app (mk_exp_var (sfprintf "__ml_%a" EmlType.pp typ ())) [e] 81 | 82 | let mk_exp_unbox e = mk_exp_vmem e member_val 83 | let mk_exp_pair e1 e2 = mk_exp_app (mk_exp_var "__ml_pair") [e1; e2] 84 | 85 | let mk_exp_tuple el = match List.rev el with 86 | | [] -> assert false 87 | | last :: rest -> List.fold_left (fun acc ei -> mk_exp_pair ei acc) last rest 88 | 89 | let rec mk_exp_proj e n i = match n, i with 90 | | _, 0 -> mk_exp_tmem e member_fst 91 | | 2, 1 -> mk_exp_tmem e member_snd 92 | | _, i -> mk_exp_proj (mk_exp_tmem e member_snd) (n - 1) (i - 1) 93 | 94 | let mk_decl_typedef id e = EmlTypedef (id, mk_type_expr e) 95 | let mk_decl_tag tag = 96 | Static (member_tag, EmlType.Int, mk_exp_const (EmlSyntax.Int tag)) 97 | let mk_decl_ret e = [mk_decl_typedef member_ret e] 98 | 99 | (** [deps] is a list of variable names dependent on template parameters. *) 100 | let rec conv_expr deps { F.data; _ } = match data with 101 | | F.Error -> { dep = false; data = Error; } 102 | | F.Const c -> mk_exp_const c 103 | | F.Var id -> mk_exp_var ~deps id 104 | | F.If (e1, e2, e3) -> 105 | mk_exp_tmem 106 | (mk_exp_app 107 | (mk_exp_var "__ml_if") 108 | [conv_expr deps e1; conv_expr deps e2; conv_expr deps e3]) 109 | member_ret 110 | | F.Op op -> conv_op deps op 111 | | F.Tuple el -> mk_exp_tuple (List.map (conv_expr deps) el) 112 | | F.Constr (id, []) -> mk_exp_var (get_constr_name id) 113 | | F.Constr (id, el) -> 114 | mk_exp_app (mk_exp_var (get_constr_name id)) (List.map (conv_expr deps) el) 115 | | F.App (e0, el) -> 116 | mk_exp_tmem 117 | (mk_exp_app 118 | (mk_exp_tmem ~deps ~template:true (conv_expr deps e0) member_fun) 119 | (List.map (conv_expr deps) el)) 120 | member_ret 121 | | F.Box e0 -> mk_exp_box ~typ:e0.F.typ (conv_expr deps e0) 122 | | F.Unbox e0 -> mk_exp_unbox (conv_expr deps e0) 123 | | F.Tag e0 -> mk_exp_vmem (conv_expr deps e0) member_tag 124 | | F.Proj (e0, n, i) -> mk_exp_proj (conv_expr deps e0) n i 125 | 126 | and conv_op deps op = 127 | let aux typ mk id_cmp e1 e2 = 128 | let e1' = conv_expr deps e1 in 129 | let e2' = conv_expr deps e2 in 130 | match typ with 131 | | EmlType.Tconstr ("__ml_boxed", _) -> 132 | mk_exp_op (mk (mk_exp_unbox e1') (mk_exp_unbox e2')) 133 | | _ when EmlType.is_basetype typ -> mk_exp_op (mk e1' e2') 134 | | _ -> mk_exp_vmem (mk_exp_app (mk_exp_var id_cmp) [e1'; e2']) member_val 135 | in 136 | match op with 137 | | EmlOp.Eq (e1, e2) -> 138 | aux e1.F.typ (fun e1 e2 -> EmlOp.Eq (e1, e2)) "__ml_eq" e1 e2 139 | | EmlOp.Ne (e1, e2) -> 140 | aux e1.F.typ (fun e1 e2 -> EmlOp.Ne (e1, e2)) "__ml_ne" e1 e2 141 | | EmlOp.Ge (e1, e2) -> 142 | aux e1.F.typ (fun e1 e2 -> EmlOp.Ge (e1, e2)) "__ml_ge" e1 e2 143 | | EmlOp.Le (e1, e2) -> 144 | aux e1.F.typ (fun e1 e2 -> EmlOp.Le (e1, e2)) "__ml_le" e1 e2 145 | | EmlOp.Gt (e1, e2) -> 146 | aux e1.F.typ (fun e1 e2 -> EmlOp.Gt (e1, e2)) "__ml_gt" e1 e2 147 | | EmlOp.Lt (e1, e2) -> 148 | aux e1.F.typ (fun e1 e2 -> EmlOp.Lt (e1, e2)) "__ml_lt" e1 e2 149 | | op -> mk_exp_op (EmlOp.map (conv_expr deps) op) 150 | 151 | and conv_let_expr deps (lets, e) = 152 | let (deps', lets') = List.fold_map conv_let_expr_desc deps lets in 153 | (lets', conv_expr deps' e) 154 | 155 | and conv_let_expr_desc deps = function 156 | | F.Let_fun (_, id, _, opt_deps, e) -> 157 | let deps' = List.filter_map identity opt_deps @ deps in 158 | let (lets', e') = conv_let_expr deps' e in 159 | let d_fun = Template_class (member_fun, opt_deps, lets', mk_decl_ret e') in 160 | let deps' = if e'.dep then id :: deps' else deps' in 161 | (deps', Class (id, [], [d_fun])) 162 | | F.Let_val (id, _, e) -> 163 | match e.F.data with 164 | | F.Box e0 when EmlType.is_basetype (EmlType.observe e0.F.typ) -> 165 | (* let id = __ml_box e0 *) 166 | let e0' = conv_expr deps e0 in 167 | let decl = Class (id, [], [mk_decl_tag (-1); 168 | Static (member_val, e0.F.typ, e0')]) in 169 | let deps' = if e0'.dep then id :: deps else deps in 170 | (deps', decl) 171 | | _ when EmlType.is_basetype (EmlType.observe e.F.typ) -> 172 | (* let id = (e : basetype) *) 173 | let e' = conv_expr deps e in 174 | let decl = Static (id, e.F.typ, e') in 175 | let deps' = if e'.dep then id :: deps else deps in 176 | (deps', decl) 177 | | _ -> 178 | let e' = conv_expr deps e in 179 | let decl = mk_decl_typedef id e' in 180 | let deps' = if e'.dep then id :: deps else deps in 181 | (deps', decl) 182 | 183 | let conv_constr (tag, id, t_deps) = 184 | let id = get_constr_name id in 185 | let d_tag = mk_decl_tag tag in 186 | let s_deps = List.mapi (fun i _ -> "x" ^ string_of_int i) t_deps in 187 | match s_deps with 188 | | [] -> Class (id, [], [d_tag]) 189 | | [x1] -> 190 | Template_class (id, [Some x1], [], 191 | [d_tag; 192 | mk_decl_typedef member_fst (mk_exp_var ~deps:s_deps x1)]) 193 | | x1 :: xs -> 194 | let e = mk_exp_tuple (List.map (fun s -> mk_exp_var ~deps:s_deps s) xs) in 195 | let pub = [d_tag; 196 | mk_decl_typedef member_fst (mk_exp_var ~deps:s_deps x1); 197 | mk_decl_typedef member_snd e] in 198 | Template_class (id, List.map (fun s -> Some s) s_deps, [], pub) 199 | 200 | let convert ~header = 201 | let aux rev_tops = function 202 | | F.Top_let led -> snd (conv_let_expr_desc [] led) :: rev_tops 203 | | F.Top_type (EmlType.Variant (_, _, constrs)) -> 204 | let constrs' = List.rev_map conv_constr constrs in 205 | constrs' @ rev_tops 206 | | F.Top_code s -> Code s :: rev_tops 207 | in 208 | List.fold_left aux [Code header] >> List.rev 209 | 210 | (** {2 Pretty printing} *) 211 | 212 | let pp_list_line pp = 213 | pp_list ~pp_delim:(fun ppf -> pp_force_newline ppf ()) pp 214 | 215 | let pp_template_arg ppf = function 216 | | None -> pp_print_string ppf "class" 217 | | Some s -> fprintf ppf "class %s" s 218 | 219 | let rec pp_expr ppf e = match e.data with 220 | | Error | Const EmlSyntax.Unit -> pp_print_string ppf "void" 221 | | Const (EmlSyntax.Bool b) -> pp_print_bool ppf b 222 | | Const (EmlSyntax.Char c) -> fprintf ppf "%d" (int_of_char c) 223 | | Const (EmlSyntax.Int n) -> pp_print_int ppf n 224 | | Const (EmlSyntax.Float x) -> pp_print_float ppf x 225 | | Var id -> pp_print_string ppf id 226 | | Tmember (b, e0, field) -> 227 | fprintf ppf "%a::@;<0 2>%s%s" 228 | pp_expr e0 (if b then "template " else "") field 229 | | Vmember (e0, field) -> fprintf ppf "%a::@;<0 2>%s" pp_expr e0 field 230 | | Op (EmlOp.Not e1) -> fprintf ppf "!@[%a@]" pp_expr e1 231 | | Op (EmlOp.And(e1,e2)) -> fprintf ppf "(@[%a@ && %a@])" pp_expr e1 pp_expr e2 232 | | Op (EmlOp.Or (e1,e2)) -> fprintf ppf "(@[%a@ || %a@])" pp_expr e1 pp_expr e2 233 | | Op (EmlOp.Pos e1) | Op (EmlOp.FPos e1) -> fprintf ppf "+@[%a@]" pp_expr e1 234 | | Op (EmlOp.Neg e1) | Op (EmlOp.FNeg e1) -> fprintf ppf "-@[%a@]" pp_expr e1 235 | | Op (EmlOp.Add (e1, e2)) | Op (EmlOp.FAdd (e1, e2)) -> 236 | fprintf ppf "(@[%a@ + %a@])" pp_expr e1 pp_expr e2 237 | | Op (EmlOp.Sub (e1, e2)) | Op (EmlOp.FSub (e1, e2)) -> 238 | fprintf ppf "(@[%a@ - %a@])" pp_expr e1 pp_expr e2 239 | | Op (EmlOp.Mul (e1, e2)) | Op (EmlOp.FMul (e1, e2)) -> 240 | fprintf ppf "(@[%a@ * %a@])" pp_expr e1 pp_expr e2 241 | | Op (EmlOp.Div (e1, e2)) | Op (EmlOp.FDiv (e1, e2)) -> 242 | fprintf ppf "(@[%a@ / %a@])" pp_expr e1 pp_expr e2 243 | | Op (EmlOp.Mod(e1,e2)) -> fprintf ppf "(@[%a@ %% %a@])" pp_expr e1 pp_expr e2 244 | | Op (EmlOp.Eq(e1,e2)) -> fprintf ppf "(@[%a@ == %a@])" pp_expr e1 pp_expr e2 245 | | Op (EmlOp.Ne(e1,e2)) -> fprintf ppf "(@[%a@ != %a@])" pp_expr e1 pp_expr e2 246 | | Op (EmlOp.Lt(e1,e2)) -> fprintf ppf "(@[%a@ < %a@])" pp_expr e1 pp_expr e2 247 | | Op (EmlOp.Gt(e1,e2)) -> fprintf ppf "(@[%a@ > %a@])" pp_expr e1 pp_expr e2 248 | | Op (EmlOp.Le(e1,e2)) -> fprintf ppf "(@[%a@ <= %a@])" pp_expr e1 pp_expr e2 249 | | Op (EmlOp.Ge(e1,e2)) -> fprintf ppf "(@[%a@ >= %a@])" pp_expr e1 pp_expr e2 250 | | Op (EmlOp.Lnot e1) -> fprintf ppf "(@[~ %a@])" pp_expr e1 251 | | Op (EmlOp.Land(e1,e2)) -> fprintf ppf "(@[%a@ & %a@])" pp_expr e1 pp_expr e2 252 | | Op (EmlOp.Lor(e1,e2)) -> fprintf ppf "(@[%a@ | %a@])" pp_expr e1 pp_expr e2 253 | | Op (EmlOp.Lxor(e1,e2)) -> fprintf ppf "(@[%a@ ^ %a@])" pp_expr e1 pp_expr e2 254 | | Op (EmlOp.Lsl(e1,e2)) -> 255 | fprintf ppf "(@[(unsigned int)@ %a@ << %a@])" pp_expr e1 pp_expr e2 256 | | Op (EmlOp.Lsr(e1,e2)) -> 257 | fprintf ppf "(@[(unsigned int)@ %a@ >> %a@])" pp_expr e1 pp_expr e2 258 | | Op (EmlOp.Asr(e1,e2)) -> 259 | fprintf ppf "(@[(signed int)@ %a@ >> %a@])" pp_expr e1 pp_expr e2 260 | | App (e0, el) -> 261 | let sp = match List.last el with 262 | | (_, { data = App _; _ }) -> " " 263 | | _ -> "" in 264 | fprintf ppf "%a@;<0 2><@[%a@]%s>" 265 | pp_expr e0 (pp_list_comma pp_type_expr) el sp 266 | 267 | and pp_type_expr ppf = function 268 | | (false, e) -> pp_expr ppf e 269 | | (true, e) -> fprintf ppf "typename@;<1 2>@[%a@]" pp_expr e 270 | 271 | let rec pp_decl ppf = function 272 | | Code s -> pp_print_string ppf s 273 | | Static (id, t, e) -> 274 | fprintf ppf "static const %a %s = %a;" EmlType.pp t id pp_expr e 275 | | EmlTypedef (id, e) -> 276 | fprintf ppf "typedef %a %s;" pp_type_expr e id 277 | | Class (id, priv, pub) -> pp_class ppf id priv pub 278 | | Template_class (id, args, priv, pub) -> 279 | fprintf ppf "template <@[%a@]>@\n" (pp_list_comma pp_template_arg) args; 280 | pp_class ppf id priv pub 281 | 282 | and pp_class ppf id priv pub = 283 | match priv with 284 | | [] -> 285 | fprintf ppf "struct %s {@\n @[%a@]@\n};" id (pp_list_line pp_decl) pub 286 | | _ -> 287 | fprintf ppf "class %s {@\n\ 288 | private:@\n @[%a@]@\n\ 289 | public:@\n @[%a@]@\n\ 290 | };" 291 | id (pp_list_line pp_decl) priv (pp_list_line pp_decl) pub 292 | -------------------------------------------------------------------------------- /src/emlCpp.mli: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | type decl 19 | 20 | val convert : header:string -> EmlFlatLet.top list -> decl list 21 | val pp_decl : Format.formatter -> decl -> unit 22 | -------------------------------------------------------------------------------- /src/emlDCE.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open EmlUtils 19 | open Format 20 | open EmlTypedExpr 21 | open EmlRemoveMatch 22 | 23 | module L = EmlLocation 24 | 25 | let rec conv_expr fv e = match e.data with 26 | | Const _ | Error -> (fv, e) 27 | | Var id -> (StringSet.add id fv, e) 28 | | Constr (id, el) -> 29 | let (fv', el') = List.fold_map conv_expr fv el in 30 | (StringSet.add id fv', { e with data = Constr (id, el') }) 31 | | Ext (Tag e0) -> 32 | let (fv', e0') = conv_expr fv e0 in 33 | (fv', { e with data = Ext (Tag e0') }) 34 | | Ext (Proj (e0, n, i)) -> 35 | let (fv', e0') = conv_expr fv e0 in 36 | (fv', { e with data = Ext (Proj (e0', n, i)) }) 37 | | Tuple el -> 38 | let (fv', el') = List.fold_map conv_expr fv el in 39 | (fv', { e with data = Tuple el' }) 40 | | Op op -> 41 | let (fv', op') = EmlOp.fold_map conv_expr fv op in 42 | (fv', { e with data = Op op' }) 43 | | If (e1, e2, e3) -> 44 | let (fv', e1') = conv_expr fv e1 in 45 | let (fv', e2') = conv_expr fv' e2 in 46 | let (fv', e3') = conv_expr fv' e3 in 47 | (fv', { e with data = If (e1', e2', e3') }) 48 | | App (e0, el) -> 49 | let (fv', e0') = conv_expr fv e0 in 50 | let (fv', el') = List.fold_map conv_expr fv' el in 51 | (fv', { e with data = App (e0', el') }) 52 | | Abs (args, e0) -> 53 | let bv = StringSet.of_list (List.filter_map identity args) in 54 | let (fv0, e0') = conv_expr StringSet.empty e0 in 55 | let fv' = StringSet.union fv (StringSet.diff fv0 bv) in 56 | (fv', { e with data = Abs (args, e0') }) 57 | | Let (rf, id, ts, e1, e2) -> 58 | let (fv2, e2') = conv_expr StringSet.empty e2 in 59 | if StringSet.mem id fv2 60 | then begin 61 | let (fv12, e1') = conv_expr_let_rhs fv2 id e1 in 62 | (StringSet.union fv fv12, { e with data = Let (rf, id, ts, e1', e2') }) 63 | end else begin 64 | eprintf "DCE: local variable `%s' is eliminated.@." id; 65 | (StringSet.union fv fv2, e2') 66 | end 67 | 68 | and conv_expr_let_rhs fv id e = 69 | let (fv', e') = conv_expr fv e in 70 | (StringSet.remove id fv', e') 71 | 72 | (** [find_string str sub] finds substring [sub] from [str]. *) 73 | let find_string str sub = 74 | let ifind f m n = (* Find index [i] that satisfies [f i]. *) 75 | let rec aux i = if i > n then None else if f i then Some i else aux (i+1) in 76 | aux m 77 | in 78 | let strlen = String.length str in 79 | let sublen = String.length sub in 80 | ifind (fun i -> None = ifind (fun j -> sub.[j] <> str.[i+j]) 0 (sublen - 1)) 81 | 0 (strlen - sublen) 82 | 83 | let check_word_boundary s i = 84 | match String.get s i with 85 | | exception _ -> true 86 | | c -> not (('a' <= c && c <= 'z') || ('A' <= c && c <= 'Z') || c = '_') 87 | 88 | let find_word str sub = 89 | match find_string str sub with 90 | | None -> false 91 | | Some bp -> check_word_boundary str (bp - 1) && 92 | check_word_boundary str (bp + String.length sub) 93 | 94 | (** [check_top_ident fv codes id] checks whether top-level identifier [id] is 95 | used after its definition, or not. *) 96 | let check_top_ident fv codes id = 97 | StringSet.mem id fv || List.exists (fun s -> find_word s id) codes 98 | 99 | let check_variant_type fv codes constrs = 100 | List.fold_left 101 | (fun (used, fv) (_, id, _) -> 102 | if check_top_ident fv codes id 103 | then (true, StringSet.remove id fv) 104 | else (used, fv)) 105 | (false, fv) constrs 106 | 107 | let convert tops0 = 108 | let aux top (fv, codes, tops) = match top.L.data with 109 | | Top_code s -> (fv, s :: codes, top :: tops) 110 | | Top_type (EmlType.Variant (name, _, constrs)) -> 111 | begin 112 | match check_variant_type fv codes constrs with 113 | | (true, fv') -> (fv', codes, top :: tops) 114 | | (false, _) -> 115 | eprintf "DCE: type (constructor) `%s' is eliminated.@." name; 116 | (fv, codes, tops) 117 | end 118 | | Top_let (rf, id, ts, e) -> 119 | if check_top_ident fv codes id 120 | then begin 121 | let (fv', e') = conv_expr_let_rhs fv id e in 122 | (fv', codes, { top with L.data = Top_let (rf, id, ts, e') } :: tops) 123 | end else begin 124 | eprintf "DCE: top-level variable `%s' is eliminated.@." id; 125 | (fv, codes, tops) 126 | end 127 | in 128 | let (_, _, tops') = List.fold_right aux tops0 (StringSet.empty, [], []) in 129 | tops' 130 | -------------------------------------------------------------------------------- /src/emlDCE.mli: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | val convert : EmlRemoveMatch.top list -> EmlRemoveMatch.top list 19 | -------------------------------------------------------------------------------- /src/emlFlatLet.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open Format 19 | open EmlUtils 20 | 21 | module L = EmlLocation 22 | module E = EmlTypedExpr 23 | module B = EmlBoxing 24 | 25 | type expr = 26 | { 27 | typ : EmlType.t; 28 | data : expr_desc; 29 | } [@@deriving show] 30 | and expr_desc = 31 | | Error 32 | | Const of EmlSyntax.const 33 | | Var of string 34 | | If of expr * expr * expr 35 | | Op of expr EmlOp.t 36 | | Tuple of expr list 37 | | Constr of string * expr list 38 | | App of expr * expr list 39 | | Box of expr 40 | | Unbox of expr 41 | | Tag of expr (* Obtain the tag of a data constructor *) 42 | | Proj of expr * int * int (* Projection operator *) 43 | 44 | and let_expr = let_expr_desc list * expr [@@deriving show] 45 | and let_expr_desc = 46 | | Let_val of string * EmlType.scheme * expr 47 | | Let_fun of bool * string * EmlType.scheme * string option list * let_expr 48 | 49 | type top = 50 | | Top_type of EmlType.decl 51 | | Top_let of let_expr_desc 52 | | Top_code of string [@@deriving show] 53 | 54 | let fresh_fun_name = gen_fresh_name "__ml_fun" 55 | 56 | let rec conv_expr rev_lets { E.data; E.typ; _ } = match data with 57 | | E.Error -> (rev_lets, { typ; data = Error }) 58 | | E.Const c -> (rev_lets, { typ; data = Const c }) 59 | | E.Var id -> (rev_lets, { typ; data = Var id }) 60 | | E.Op op -> 61 | let (rev_lets', op') = EmlOp.fold_map conv_expr rev_lets op in 62 | (rev_lets', { typ; data = Op op' }) 63 | | E.Ext (B.Box e1) -> 64 | let (rev_lets', e1') = conv_expr rev_lets e1 in 65 | (rev_lets', { typ; data = Box e1'; }) 66 | | E.Ext (B.Unbox e1) -> 67 | let (rev_lets', e1') = conv_expr rev_lets e1 in 68 | (rev_lets', { typ; data = Unbox e1'; }) 69 | | E.Ext (B.Tag e1) -> 70 | let (rev_lets', e1') = conv_expr rev_lets e1 in 71 | (rev_lets', { typ; data = Tag e1'; }) 72 | | E.Ext (B.Proj (e1, n, i)) -> 73 | let (rev_lets', e1') = conv_expr rev_lets e1 in 74 | (rev_lets', { typ; data = Proj (e1', n, i); }) 75 | | E.If (e1, e2, e3) -> 76 | let (rev_lets', e1') = conv_expr rev_lets e1 in 77 | let (rev_lets', e2') = conv_expr rev_lets' e2 in 78 | let (rev_lets', e3') = conv_expr rev_lets' e3 in 79 | (rev_lets', { typ; data = If (e1', e2', e3'); }) 80 | | E.Tuple el -> 81 | let (rev_lets', el') = List.fold_map conv_expr rev_lets el in 82 | (rev_lets', { typ; data = Tuple el' }) 83 | | E.Constr (id, el) -> 84 | let (rev_lets', el') = List.fold_map conv_expr rev_lets el in 85 | (rev_lets', { typ; data = Constr (id, el') }) 86 | | E.App (e0, el) -> 87 | let (rev_lets', e0') = conv_expr rev_lets e0 in 88 | let (rev_lets', el') = List.fold_map conv_expr rev_lets' el in 89 | (rev_lets', { typ; data = App (e0', el') }) 90 | | E.Abs (args, e1) -> (* Give a name for anonymous functions *) 91 | let id = fresh_fun_name () in 92 | let led = conv_abs false id (EmlType.scheme typ) args e1 in 93 | let e2 = { data = Var id; typ; } in 94 | (led :: rev_lets, e2) 95 | | E.Let (rf, id, ts, { E.data = E.Abs (args, e11); _ }, e2) -> 96 | let led = conv_abs rf id ts args e11 in 97 | conv_expr (led :: rev_lets) e2 98 | | E.Let (_, id, ts, e1, e2) -> 99 | let rev_lets' = conv_let_val rev_lets id ts e1 in 100 | conv_expr rev_lets' e2 101 | 102 | and conv_abs rf id ts args e = 103 | let (rev_lets, e') = conv_expr [] e in 104 | Let_fun (rf, id, ts, args, (List.rev rev_lets, e')) 105 | 106 | and conv_let_val rev_lets id ts e = 107 | let (rev_lets', e') = conv_expr rev_lets e in 108 | let led = Let_val (id, ts, e') in 109 | led :: rev_lets' 110 | 111 | let convert tops = 112 | let aux rev_tops e = match e.L.data with 113 | | E.Top_code s -> Top_code s :: rev_tops 114 | | E.Top_type decl -> Top_type decl :: rev_tops 115 | | E.Top_let (rf, id, ts, { E.data = E.Abs (args, e11); _ }) -> 116 | (Top_let (conv_abs rf id ts args e11)) :: rev_tops 117 | | E.Top_let (_, id, ts, e1) -> 118 | let rev_tops' = conv_let_val [] id ts e1 119 | |> List.map (fun l -> Top_let l) in 120 | rev_tops' @ rev_tops 121 | in 122 | List.fold_left aux [] tops |> List.rev 123 | -------------------------------------------------------------------------------- /src/emlFlatLet.mli: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | type expr = 19 | { 20 | typ : EmlType.t; 21 | data : expr_desc; 22 | } [@@deriving show] 23 | and expr_desc = 24 | | Error 25 | | Const of EmlSyntax.const 26 | | Var of string 27 | | If of expr * expr * expr 28 | | Op of expr EmlOp.t 29 | | Tuple of expr list 30 | | Constr of string * expr list 31 | | App of expr * expr list 32 | | Box of expr 33 | | Unbox of expr 34 | | Tag of expr (* Obtain the tag of a data constructor *) 35 | | Proj of expr * int * int (* Projection operator *) 36 | 37 | and let_expr = let_expr_desc list * expr [@@deriving show] 38 | and let_expr_desc = 39 | | Let_val of string * EmlType.scheme * expr 40 | | Let_fun of bool * string * EmlType.scheme * string option list * let_expr 41 | 42 | type top = 43 | | Top_type of EmlType.decl 44 | | Top_let of let_expr_desc 45 | | Top_code of string [@@deriving show] 46 | 47 | val convert : EmlBoxing.top list -> top list 48 | -------------------------------------------------------------------------------- /src/emlLexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open EmlParser 3 | open EmlUtils 4 | 5 | let code_buf = Buffer.create 16 6 | 7 | let get_code () = 8 | let n = Buffer.length code_buf in 9 | Buffer.sub code_buf 0 (n - 2) |> String.trim 10 | 11 | let keyword_table = Hashtbl.create 53 12 | let () = List.iter (fun (kwd, tok) -> Hashtbl.add keyword_table kwd tok) 13 | [ 14 | "begin", BEGIN; 15 | "end", END; 16 | "if", IF; 17 | "then", THEN; 18 | "else", ELSE; 19 | "true", LITERAL_BOOL true; 20 | "false", LITERAL_BOOL false; 21 | "let", LET; 22 | "rec", REC; 23 | "in", IN; 24 | "fun", FUN; 25 | "match", MATCH; 26 | "type", TYPE; 27 | "of", OF; 28 | "with", WITH; 29 | "not", NOT; 30 | "unit", UNIT; 31 | "bool", BOOL; 32 | "char", CHAR; 33 | "int", INT; 34 | "float", FLOAT; 35 | "mod", MOD; 36 | "land", LAND; 37 | "lor", LOR; 38 | "lxor", LXOR; 39 | "lnot", LNOT; 40 | "lsl", LSL; 41 | "lsr", LSR; 42 | "asr", ASR; 43 | "error", ERROR; 44 | ] 45 | 46 | let make_ident lexbuf = 47 | let s = Lexing.lexeme lexbuf in 48 | try 49 | Hashtbl.find keyword_table s 50 | with Not_found -> 51 | if String.has_prefix "__ml_" s 52 | then errorf ~loc:(EmlLocation.from_lexbuf lexbuf) 53 | "Prefix `__ml_' is reserved: %s" s () 54 | else if 'A' <= s.[0] && s.[0] <= 'Z' then UIDENT s else LIDENT s 55 | 56 | let get_int lexbuf = 57 | let s = Lexing.lexeme lexbuf in 58 | try int_of_string s 59 | with _ -> errorf ~loc:(EmlLocation.from_lexbuf lexbuf) 60 | "Error: Illegal integer literal %s" s () 61 | 62 | let get_float lexbuf = 63 | let s = Lexing.lexeme lexbuf in 64 | try float_of_string s 65 | with _ -> errorf ~loc:(EmlLocation.from_lexbuf lexbuf) 66 | "Error: Illegal float literal %s" s () 67 | 68 | let get_quoted lexbuf = 69 | let s = Lexing.lexeme lexbuf in 70 | try 71 | String.sub s 1 (String.length s - 2) 72 | |> Scanf.unescaped 73 | with Scanf.Scan_failure msg -> 74 | errorf ~loc:(EmlLocation.from_lexbuf lexbuf) 75 | "Error: %s" msg () 76 | } 77 | 78 | let bdigit = [ '0'-'1' ] 79 | let odigit = [ '0'-'7' ] 80 | let digit = [ '0'-'9' ] 81 | let xdigit = [ '0'-'9' 'a'-'f' 'A'-'F' ] 82 | let upper = [ 'A'-'Z' ] 83 | let lower = [ 'a'-'z' ] 84 | let sign = [ '+' '-' ] 85 | 86 | let int_literal = digit+ | "0x" xdigit+ | "0b" bdigit+ 87 | let float_literal = digit+ ('.' digit*)? (['e' 'E'] sign? digit+)? 88 | let char_literal = '\'' ([^ '\\' '\''] | '\\' _ 89 | | '\\' digit+ 90 | | "\\x" xdigit xdigit) '\'' 91 | let str_literal = '\"' ([^ '\\' '\"'] | '\\' _)* '\"' 92 | let identifier = (upper | lower | '_') (digit | upper | lower | '_') * 93 | 94 | rule main = parse 95 | [' ' '\t'] { main lexbuf } 96 | | ['\n' '\r'] { Lexing.new_line lexbuf ; main lexbuf } 97 | | "(*" { comment lexbuf ; main lexbuf } 98 | | "(*!" { Buffer.clear code_buf ; cpp_code lexbuf ; 99 | CPP_CODE (get_code ()) } 100 | | "#use" { HASH_USE } 101 | | "&&" { ANDAND } 102 | | "||" { BARBAR } 103 | | '|' { BAR } 104 | | "<>" { LESS_GREATER } 105 | | "<=" { LESS_EQUAL } 106 | | ">=" { GREATER_EQUAL } 107 | | '=' { EQUAL } 108 | | '<' { LESS } 109 | | '>' { GREATER } 110 | | "->" { ARROW } 111 | | "+." { PLUSDOT } 112 | | "-." { MINUSDOT } 113 | | "*." { STARDOT } 114 | | "/." { SLASHDOT } 115 | | '+' { PLUS } 116 | | '-' { MINUS } 117 | | '*' { STAR } 118 | | '/' { SLASH } 119 | | "::" { COLONCOLON } 120 | | ':' { COLON } 121 | | ';' { SEMICOLON } 122 | | ',' { COMMA } 123 | | '(' { LPAREN } 124 | | ')' { RPAREN } 125 | | '[' { LBRACKET } 126 | | ']' { RBRACKET } 127 | | '_' { UNDERSCORE } 128 | | '\'' { QUOTE } 129 | | int_literal { LITERAL_INT (get_int lexbuf) } 130 | | float_literal { LITERAL_FLOAT (get_float lexbuf) } 131 | | char_literal { LITERAL_CHAR ((get_quoted lexbuf).[0]) } 132 | | str_literal { LITERAL_STRING (get_quoted lexbuf) } 133 | | identifier { make_ident lexbuf } 134 | | eof { EOF } 135 | | _ { errorf ~loc:(EmlLocation.from_lexbuf lexbuf) 136 | "Unknown token: %s" (Lexing.lexeme lexbuf) () } 137 | 138 | and comment = parse 139 | "(*" { comment lexbuf ; comment lexbuf } 140 | | "*)" { () } 141 | | ['\n' '\r'] { Lexing.new_line lexbuf ; comment lexbuf } 142 | | eof { Format.eprintf "Warning: unterminated comment@." } 143 | | _ { comment lexbuf } 144 | 145 | and cpp_code = parse 146 | "(*" { Buffer.add_string code_buf (Lexing.lexeme lexbuf) ; 147 | cpp_code lexbuf ; cpp_code lexbuf } 148 | | "*)" { Buffer.add_string code_buf (Lexing.lexeme lexbuf) } 149 | | ['\n' '\r'] { Lexing.new_line lexbuf ; 150 | Buffer.add_string code_buf (Lexing.lexeme lexbuf) ; 151 | cpp_code lexbuf } 152 | | eof { Format.eprintf "Warning: unterminated C++ code block@." } 153 | | _ { Buffer.add_string code_buf (Lexing.lexeme lexbuf) ; 154 | cpp_code lexbuf } 155 | -------------------------------------------------------------------------------- /src/emlLocation.ml: -------------------------------------------------------------------------------- 1 | type position = 2 | { 3 | fname : string; 4 | lnum_start : int; 5 | cnum_start : int; 6 | lnum_end : int; 7 | cnum_end : int; 8 | } 9 | 10 | type t = position option 11 | 12 | let dummy = None 13 | 14 | let from_position2 p1 p2 = 15 | let open Lexing in 16 | Some { fname = p1.pos_fname; 17 | lnum_start = p1.pos_lnum; 18 | cnum_start = p1.pos_cnum - p1.pos_bol; 19 | lnum_end = p2.pos_lnum; 20 | cnum_end = p2.pos_cnum - p2.pos_bol; } 21 | 22 | let from_lexbuf lexbuf = 23 | from_position2 (Lexing.lexeme_start_p lexbuf) (Lexing.lexeme_end_p lexbuf) 24 | 25 | let from_symbol () = 26 | from_position2 (Parsing.symbol_start_pos ()) (Parsing.symbol_end_pos ()) 27 | 28 | let from_rhs n = 29 | from_position2 (Parsing.rhs_start_pos n) (Parsing.rhs_end_pos n) 30 | 31 | let from_rhs2 m n = 32 | from_position2 (Parsing.rhs_start_pos m) (Parsing.rhs_end_pos n) 33 | 34 | let pp ppf = 35 | let open Format in 36 | function 37 | | None -> () 38 | | Some p -> 39 | fprintf ppf "File %S, from line %d character %d, to line %d character %d" 40 | p.fname p.lnum_start p.cnum_start p.lnum_end p.cnum_end 41 | 42 | type 'a loc = 43 | { 44 | loc : t; 45 | data : 'a; 46 | } 47 | 48 | let pp_loc pp ppf l = pp ppf l.data 49 | let map f l = { loc = l.loc; data = f l.data; } 50 | -------------------------------------------------------------------------------- /src/emlLocation.mli: -------------------------------------------------------------------------------- 1 | type position = 2 | { 3 | fname : string; 4 | lnum_start : int; 5 | cnum_start : int; 6 | lnum_end : int; 7 | cnum_end : int; 8 | } 9 | 10 | type t = position option 11 | 12 | val dummy : t 13 | val from_position2 : Lexing.position -> Lexing.position -> t 14 | val from_lexbuf : Lexing.lexbuf -> t 15 | val from_symbol : unit -> t 16 | val from_rhs : int -> t 17 | val from_rhs2 : int -> int -> t 18 | val pp : Format.formatter -> t -> unit 19 | 20 | type 'a loc = 21 | { 22 | loc : t; 23 | data : 'a; 24 | } 25 | 26 | val pp_loc : 27 | (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a loc -> unit 28 | val map : ('a -> 'b) -> 'a loc -> 'b loc 29 | -------------------------------------------------------------------------------- /src/emlOp.ml: -------------------------------------------------------------------------------- 1 | open Format 2 | open EmlUtils 3 | 4 | type 'a t = 5 | (* comparison *) 6 | | Eq of 'a * 'a 7 | | Ne of 'a * 'a 8 | | Gt of 'a * 'a 9 | | Lt of 'a * 'a 10 | | Ge of 'a * 'a 11 | | Le of 'a * 'a 12 | (* boolean operator *) 13 | | Not of 'a 14 | | And of 'a * 'a 15 | | Or of 'a * 'a 16 | (* bit-wise operator *) 17 | | Lnot of 'a 18 | | Land of 'a * 'a 19 | | Lor of 'a * 'a 20 | | Lxor of 'a * 'a 21 | | Lsl of 'a * 'a 22 | | Lsr of 'a * 'a 23 | | Asr of 'a * 'a 24 | (* numerical operator *) 25 | | Pos of 'a (* unary operator + *) 26 | | Neg of 'a (* unary operator - *) 27 | | Add of 'a * 'a 28 | | Sub of 'a * 'a 29 | | Mul of 'a * 'a 30 | | Div of 'a * 'a 31 | | Mod of 'a * 'a 32 | | FPos of 'a (* unary operator +. *) 33 | | FNeg of 'a (* unary operator -. *) 34 | | FAdd of 'a * 'a 35 | | FSub of 'a * 'a 36 | | FMul of 'a * 'a 37 | | FDiv of 'a * 'a 38 | [@@deriving show] 39 | 40 | let map f = function 41 | | Eq (x, y) -> Eq (f x, f y) 42 | | Ne (x, y) -> Ne (f x, f y) 43 | | Gt (x, y) -> Gt (f x, f y) 44 | | Lt (x, y) -> Lt (f x, f y) 45 | | Ge (x, y) -> Ge (f x, f y) 46 | | Le (x, y) -> Le (f x, f y) 47 | | Not x -> Not (f x) 48 | | And (x, y) -> And (f x, f y) 49 | | Or (x, y) -> Or (f x, f y) 50 | | Lnot x -> Lnot (f x) 51 | | Land (x, y) -> Land (f x, f y) 52 | | Lor (x, y) -> Lor (f x, f y) 53 | | Lxor (x, y) -> Lxor (f x, f y) 54 | | Lsl (x, y) -> Lsl (f x, f y) 55 | | Lsr (x, y) -> Lsr (f x, f y) 56 | | Asr (x, y) -> Asr (f x, f y) 57 | | Pos x -> Pos (f x) 58 | | Neg x -> Neg (f x) 59 | | Add (x, y) -> Add (f x, f y) 60 | | Sub (x, y) -> Sub (f x, f y) 61 | | Mul (x, y) -> Mul (f x, f y) 62 | | Div (x, y) -> Div (f x, f y) 63 | | Mod (x, y) -> Mod (f x, f y) 64 | | FPos x -> FPos (f x) 65 | | FNeg x -> FNeg (f x) 66 | | FAdd (x, y) -> FAdd (f x, f y) 67 | | FSub (x, y) -> FSub (f x, f y) 68 | | FMul (x, y) -> FMul (f x, f y) 69 | | FDiv (x, y) -> FDiv (f x, f y) 70 | 71 | let fold f acc = function 72 | | Eq (x, y) | Ne (x, y) | Gt (x, y) | Lt (x, y) | Ge (x, y) | Le (x, y) 73 | | And (x, y) | Or (x, y) | Add (x, y) | Sub (x, y) | Mul (x, y) 74 | | Div (x, y) | FAdd (x, y) | FSub (x, y) | FMul (x, y) | FDiv (x, y) 75 | | Mod (x, y) | Land (x, y) | Lor (x, y) | Lxor (x, y) | Lsl (x, y) 76 | | Lsl (x, y) | Lsr (x, y) | Asr (x, y) -> f (f acc x) y 77 | | Not x | Lnot x | Pos x | Neg x | FPos x | FNeg x -> f acc x 78 | 79 | let fold_map f init op = 80 | let acc = ref init in 81 | let aux x = 82 | let (acc', x') = f !acc x in 83 | acc := acc'; 84 | x' 85 | in 86 | (!acc, map aux op) 87 | 88 | let exists f op = fold (fun acc x -> acc || f x) false op 89 | -------------------------------------------------------------------------------- /src/emlParser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open EmlUtils 3 | open Format 4 | open EmlSyntax 5 | open EmlLocation 6 | 7 | let mk ?(loc = from_symbol ()) data = { loc; data; } 8 | 9 | let mk_exp_unary_plus e = 10 | match e.data with 11 | | Const (EmlSyntax.Int n) -> mk (Const (EmlSyntax.Int n)) 12 | | Const (EmlSyntax.Float n) -> mk (Const (EmlSyntax.Float n)) 13 | | _ -> mk (EmlOp (EmlOp.Pos e)) 14 | 15 | let mk_exp_unary_minus e = 16 | match e.data with 17 | | Const (EmlSyntax.Int n) -> mk (Const (EmlSyntax.Int (~- n))) 18 | | Const (EmlSyntax.Float n) -> mk (Const (EmlSyntax.Float (~-. n))) 19 | | _ -> mk (EmlOp (EmlOp.Neg e)) 20 | 21 | let mk_exp_cons ?loc e1 e2 = Constr ("::", [e1; e2]) |> mk ?loc 22 | 23 | let mk_exp_list ?loc elms = 24 | let nil = Constr ("[]", []) |> mk ?loc in 25 | List.fold_left (fun e x -> mk_exp_cons ?loc x e) nil elms 26 | 27 | let mk_exp_string ?loc s = 28 | String.to_list s 29 | |> List.map (fun c -> Const (Char c) |> mk ?loc) 30 | |> List.rev 31 | |> mk_exp_list ?loc 32 | 33 | let mk_pat_list ?loc elms = 34 | let nil = Pconstr ("[]", []) |> mk ?loc in 35 | List.fold_left (fun e x -> Pconstr ("::", [x; e]) |> mk ?loc) nil elms 36 | 37 | let mk_pat_string ?loc s = 38 | String.to_list s 39 | |> List.map (fun c -> Pconst (Pchar c) |> mk ?loc) 40 | |> List.rev 41 | |> mk_pat_list ?loc 42 | 43 | let mk_type ?loc name rev_args rev_constrs = 44 | mk ?loc (Top_variant_type (name, List.rev rev_args, List.rev rev_constrs)) 45 | 46 | let check_top_shadowing tops = 47 | let aux (types, vars) { loc; data; } = match data with 48 | | Top_variant_type (s, _, constrs) -> 49 | (* Check top-level shadowing of types and constructors. *) 50 | if List.mem s types then errorf ~loc "Type %s is already defined" s (); 51 | let names = List.map fst constrs in 52 | List.iter (fun s -> 53 | if List.mem s vars 54 | then errorf ~loc "Constructor %s is already defined" s ()) names; 55 | (s :: types, names @ vars) 56 | | Top_let (_, s, _) -> 57 | (* Check top-level shadowing of variables. *) 58 | if List.mem s vars 59 | then errorf ~loc "Top-level identifier %s is already defined" s (); 60 | (types, s :: vars) 61 | | Top_code _ | Top_use _ -> (types, vars) 62 | in 63 | ignore (List.fold_left aux ([], []) tops) 64 | %} 65 | 66 | %token CPP_CODE 67 | %token LITERAL_BOOL 68 | %token LITERAL_CHAR 69 | %token LITERAL_INT 70 | %token LITERAL_FLOAT 71 | %token LITERAL_STRING 72 | %token ERROR 73 | %token ANDAND BARBAR NOT 74 | %token LAND LOR LXOR LNOT LSL LSR ASR 75 | %token EQUAL LESS_GREATER LESS GREATER LESS_EQUAL GREATER_EQUAL 76 | %token PLUS MINUS STAR SLASH MOD PLUSDOT MINUSDOT STARDOT SLASHDOT 77 | %token UNIT BOOL CHAR INT FLOAT ARROW 78 | %token BEGIN END 79 | %token COLON 80 | %token COLONCOLON 81 | %token COMMA 82 | %token ELSE 83 | %token EOF 84 | %token FUN 85 | %token IF 86 | %token IN 87 | %token LBRACKET 88 | %token LET 89 | %token LIDENT 90 | %token LPAREN 91 | %token MATCH 92 | %token SEMICOLON 93 | %token THEN 94 | %token TYPE 95 | %token OF 96 | %token BAR 97 | %token QUOTE 98 | %token RBRACKET 99 | %token REC 100 | %token RPAREN 101 | %token UNDERSCORE 102 | %token UIDENT 103 | %token WITH 104 | %token HASH_USE 105 | 106 | %nonassoc prec_fun prec_let prec_match 107 | %nonassoc prec_if 108 | %nonassoc prec_tuple 109 | %left COMMA 110 | %right ARROW 111 | %left BAR 112 | %right BARBAR 113 | %right ANDAND 114 | %left EQUAL LESS GREATER LESS_GREATER LESS_EQUAL GREATER_EQUAL 115 | %right COLONCOLON SEMICOLON 116 | %left PLUS MINUS PLUSDOT MINUSDOT 117 | %left STAR STARDOT SLASH SLASHDOT MOD LAND LOR LXOR 118 | %right LSL LSR ASR 119 | %nonassoc NOT LNOT prec_unary_plus prec_unary_minus 120 | %left prec_app 121 | 122 | %start main 123 | %type main 124 | %% 125 | 126 | main: 127 | toplevel EOF { let tops = List.rev $1 in check_top_shadowing tops ; tops } 128 | | error { errorf ~loc:(EmlLocation.from_symbol ()) "syntax error" () } 129 | 130 | /********************************************************************* 131 | * Toplevel 132 | *********************************************************************/ 133 | 134 | toplevel: 135 | { [] } 136 | | toplevel toplevel_phrase { $2 :: $1 } 137 | 138 | toplevel_phrase: 139 | CPP_CODE 140 | { mk (Top_code $1) } 141 | | HASH_USE LITERAL_STRING 142 | { mk (Top_use $2) } 143 | | TYPE LIDENT EQUAL type_decl 144 | { mk_type $2 [] $4 } 145 | | TYPE type_var LIDENT EQUAL type_decl 146 | { mk_type $3 [$2] $5 } 147 | | TYPE LPAREN formal_type_args RPAREN LIDENT EQUAL type_decl 148 | { mk_type $5 $3 $7 } 149 | | LET LIDENT EQUAL expr 150 | %prec prec_let 151 | { mk (Top_let (false, $2, $4)) } 152 | | LET LIDENT formal_args EQUAL expr 153 | %prec prec_let 154 | { mk (Top_let (false, $2, mk (Abs (List.rev $3, $5)))) } 155 | | LET REC LIDENT formal_args EQUAL expr 156 | %prec prec_let 157 | { mk (Top_let (true, $3, mk (Abs (List.rev $4, $6)))) } 158 | 159 | formal_type_args: 160 | type_var COMMA type_var { [$3; $1] } 161 | | formal_type_args COMMA type_var { $3 :: $1 } 162 | 163 | type_decl: 164 | type_decl_constr { [$1] } 165 | | BAR type_decl_constr { [$2] } 166 | | type_decl BAR type_decl_constr { $3 :: $1 } 167 | 168 | type_decl_constr: 169 | vconstr_ident { ($1, []) } 170 | | vconstr_ident OF simple_type { ($1, [$3]) } 171 | | vconstr_ident OF tuple_type { ($1, List.rev $3) } 172 | 173 | vconstr_ident: 174 | UIDENT { $1 } 175 | | LBRACKET RBRACKET { "[]" } 176 | | COLONCOLON { "::" } 177 | 178 | /********************************************************************* 179 | * EmlTypes 180 | *********************************************************************/ 181 | 182 | type_expr: 183 | simple_type { $1 } 184 | | tuple_type { EmlType.Tuple (List.rev $1) } 185 | | arrow_type { let (args, ret) = $1 in EmlType.Arrow (args, ret) } 186 | 187 | arrow_type: 188 | simple_type ARROW simple_type { ([$1], $3) } 189 | | simple_type ARROW arrow_type { let (args, ret) = $3 in ($1 :: args, ret) } 190 | 191 | tuple_type: 192 | simple_type STAR simple_type { [$3; $1] } 193 | | tuple_type STAR simple_type { $3 :: $1 } 194 | 195 | simple_type: 196 | type_var { EmlType.fresh_var ?name:$1 () } 197 | | UNIT { EmlType.Unit } 198 | | BOOL { EmlType.Bool } 199 | | CHAR { EmlType.Char } 200 | | INT { EmlType.Int } 201 | | FLOAT { EmlType.Float } 202 | | LIDENT { EmlType.Tconstr ($1, []) } 203 | | simple_type LIDENT { EmlType.Tconstr ($2, [$1]) } 204 | | LPAREN actual_type_args RPAREN LIDENT { EmlType.Tconstr ($4, List.rev $2) } 205 | | LPAREN type_expr RPAREN { $2 } 206 | 207 | actual_type_args: 208 | type_expr COMMA type_expr { [$3; $1] } 209 | | actual_type_args COMMA type_expr { $3 :: $1 } 210 | 211 | type_var: 212 | UNDERSCORE { None } 213 | | QUOTE LIDENT { Some ("'" ^ $2) } 214 | | QUOTE UIDENT { Some ("'" ^ $2) } 215 | 216 | /********************************************************************* 217 | * Expressions 218 | *********************************************************************/ 219 | 220 | expr: 221 | app_expr 222 | { $1 } 223 | | FUN formal_args ARROW expr 224 | %prec prec_fun 225 | { mk (Abs (List.rev $2, $4)) } 226 | | IF expr THEN expr ELSE expr 227 | %prec prec_if 228 | { mk (If ($2, $4, $6)) } 229 | | LET LIDENT EQUAL expr IN expr 230 | %prec prec_let 231 | { mk (Let (false, $2, $4, $6)) } 232 | | LET LIDENT formal_args EQUAL expr IN expr 233 | %prec prec_let 234 | { mk (Let (false, $2, mk (Abs (List.rev $3, $5)), $7)) } 235 | | LET REC LIDENT formal_args EQUAL expr IN expr 236 | %prec prec_let 237 | { mk (Let (true, $3, mk (Abs (List.rev $4, $6)), $8)) } 238 | | MATCH expr WITH match_cases 239 | %prec prec_match 240 | { mk (Match ($2, List.rev $4)) } 241 | | expr COLONCOLON expr { mk_exp_cons $1 $3 } 242 | | expr ANDAND expr { mk (EmlOp (EmlOp.And ($1, $3))) } 243 | | expr BARBAR expr { mk (EmlOp (EmlOp.Or ($1, $3))) } 244 | | expr EQUAL expr { mk (EmlOp (EmlOp.Eq ($1, $3))) } 245 | | expr LESS expr { mk (EmlOp (EmlOp.Lt ($1, $3))) } 246 | | expr GREATER expr { mk (EmlOp (EmlOp.Gt ($1, $3))) } 247 | | expr LESS_EQUAL expr { mk (EmlOp (EmlOp.Le ($1, $3))) } 248 | | expr GREATER_EQUAL expr { mk (EmlOp (EmlOp.Ge ($1, $3))) } 249 | | expr LESS_GREATER expr { mk (EmlOp (EmlOp.Ne ($1, $3))) } 250 | | expr PLUS expr { mk (EmlOp (EmlOp.Add ($1, $3))) } 251 | | expr MINUS expr { mk (EmlOp (EmlOp.Sub ($1, $3))) } 252 | | expr STAR expr { mk (EmlOp (EmlOp.Mul ($1, $3))) } 253 | | expr SLASH expr { mk (EmlOp (EmlOp.Div ($1, $3))) } 254 | | expr MOD expr { mk (EmlOp (EmlOp.Mod ($1, $3))) } 255 | | expr PLUSDOT expr { mk (EmlOp (EmlOp.FAdd ($1, $3))) } 256 | | expr MINUSDOT expr { mk (EmlOp (EmlOp.FSub ($1, $3))) } 257 | | expr STARDOT expr { mk (EmlOp (EmlOp.FMul ($1, $3))) } 258 | | expr SLASHDOT expr { mk (EmlOp (EmlOp.FDiv ($1, $3))) } 259 | | expr LAND expr { mk (EmlOp (EmlOp.Land ($1, $3))) } 260 | | expr LOR expr { mk (EmlOp (EmlOp.Lor ($1, $3))) } 261 | | expr LXOR expr { mk (EmlOp (EmlOp.Lxor ($1, $3))) } 262 | | expr LSL expr { mk (EmlOp (EmlOp.Lsl ($1, $3))) } 263 | | expr LSR expr { mk (EmlOp (EmlOp.Lsr ($1, $3))) } 264 | | expr ASR expr { mk (EmlOp (EmlOp.Asr ($1, $3))) } 265 | | NOT expr { mk (EmlOp (EmlOp.Not $2)) } 266 | | LNOT expr { mk (EmlOp (EmlOp.Lnot $2)) } 267 | | PLUSDOT expr %prec prec_unary_plus { mk (EmlOp (EmlOp.FPos $2)) } 268 | | MINUSDOT expr %prec prec_unary_minus { mk (EmlOp (EmlOp.FNeg $2)) } 269 | | PLUS expr %prec prec_unary_plus { mk_exp_unary_plus $2 } 270 | | MINUS expr %prec prec_unary_minus { mk_exp_unary_minus $2 } 271 | | tuple_expr %prec prec_tuple { mk (Tuple (List.rev $1)) } 272 | 273 | tuple_expr: 274 | expr COMMA expr { [$3; $1] } 275 | | tuple_expr COMMA expr { $3 :: $1 } 276 | 277 | app_expr: 278 | UIDENT { mk (Constr ($1, [])) } 279 | | UIDENT simple_expr { match $2.data with 280 | | Tuple l -> mk (Constr ($1, l)) 281 | | _ -> mk (Constr ($1, [$2])) } 282 | | fun_app_expr { match $1 with 283 | | (e, []) -> e 284 | | (e, l) -> mk (App (e, List.rev l)) } 285 | 286 | fun_app_expr: 287 | simple_expr 288 | { ($1, []) } 289 | | fun_app_expr simple_expr 290 | %prec prec_app 291 | { match $1 with (f, args) -> (f, $2 :: args) } 292 | 293 | simple_expr: 294 | LPAREN RPAREN { mk (Const Unit) } 295 | | LITERAL_BOOL { mk (Const (Bool $1)) } 296 | | LITERAL_CHAR { mk (Const (Char $1)) } 297 | | LITERAL_INT { mk (Const (Int $1)) } 298 | | LITERAL_FLOAT { mk (Const (Float $1)) } 299 | | LITERAL_STRING { mk_exp_string $1 } 300 | | LIDENT { mk (Var $1) } 301 | | LPAREN expr COLON type_expr RPAREN { mk (Constraint ($2, $4)) } 302 | | LBRACKET RBRACKET { mk (Constr ("[]", [])) } 303 | | LBRACKET exprs_semi RBRACKET { mk_exp_list $2 } 304 | | ERROR { mk Error } 305 | | LPAREN expr RPAREN { $2 } 306 | | BEGIN expr END { $2 } 307 | 308 | exprs_semi: 309 | expr { [$1] } 310 | | exprs_semi SEMICOLON expr { $3 :: $1 } 311 | 312 | formal_args: 313 | formal_arg { [$1] } 314 | | formal_args formal_arg { $2 :: $1 } 315 | 316 | formal_arg: 317 | UNDERSCORE { None } 318 | | LIDENT { Some $1 } 319 | 320 | match_cases: 321 | pattern ARROW expr { [($1, $3)] } 322 | | BAR pattern ARROW expr { [($2, $4)] } 323 | | match_cases BAR pattern ARROW expr { ($3, $5) :: $1 } 324 | 325 | /********************************************************************* 326 | * Patterns 327 | *********************************************************************/ 328 | 329 | pattern: 330 | simple_pattern 331 | { $1 } 332 | | UIDENT simple_pattern 333 | { let args = match $2.data with Ptuple l -> l | _ -> [$2] in 334 | mk (Pconstr ($1, args)) } 335 | | tuple_pattern 336 | %prec prec_tuple 337 | { mk (Ptuple (List.rev $1)) } 338 | 339 | simple_pattern: 340 | UNDERSCORE { mk (Pvar None) } 341 | | LIDENT { mk (Pvar (Some $1)) } 342 | | LPAREN RPAREN { mk (Pconst Punit) } 343 | | LITERAL_BOOL { mk (Pconst (Pbool $1)) } 344 | | LITERAL_CHAR { mk (Pconst (Pchar $1)) } 345 | | LITERAL_INT { mk (Pconst (Pint $1)) } 346 | | LITERAL_STRING { mk_pat_string $1 } 347 | | UIDENT { mk (Pconstr ($1, [])) } 348 | | LBRACKET RBRACKET { mk (Pconstr ("[]", [])) } 349 | | simple_pattern COLONCOLON simple_pattern { mk (Pconstr ("::", [$1; $3])) } 350 | | LBRACKET list_pattern RBRACKET { mk_pat_list $2 } 351 | | LPAREN pattern RPAREN { $2 } 352 | 353 | tuple_pattern: 354 | pattern COMMA pattern { [$3; $1] } 355 | | tuple_pattern COMMA pattern { $3 :: $1 } 356 | 357 | list_pattern: 358 | pattern { [$1] } 359 | | list_pattern SEMICOLON pattern { $3 :: $1 } 360 | -------------------------------------------------------------------------------- /src/emlRemoveMatch.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open Format 19 | open EmlTypedExpr 20 | open EmlUtils 21 | 22 | module T = EmlTyping 23 | 24 | type expr = ext_expr base_expr [@@deriving show] 25 | and ext_expr = 26 | | Tag of expr (* Obtain the tag of a data constructor *) 27 | | Proj of expr * int * int (* Projection operator *) 28 | 29 | type top = ext_expr base_top [@@deriving show] 30 | 31 | let mk_exp_proj ~loc ~typ e n i = { loc; typ; data = Ext (Proj (e, n, i)); } 32 | let mk_exp_tag ~loc e = { loc; typ = EmlType.Int; data = Ext (Tag e); } 33 | let mk_exp_eq ~loc e1 e2 = 34 | { loc; typ = EmlType.Bool; data = Op (EmlOp.Eq (e1, e2)); } 35 | let mk_exp_if_eq ~loc e_lhs e_rhs e2 e3 = 36 | mk_exp_if ~loc (mk_exp_eq ~loc e_lhs e_rhs) e2 e3 37 | 38 | let rec conv_pat e e_then e_else p = 39 | let loc = e.loc in 40 | match p.data with 41 | | T.Pvar None | T.Pconst EmlSyntax.Punit -> e_then 42 | | T.Pvar (Some id) -> (* let id = e in e_then *) 43 | mk_exp_simple_let ~loc false id e e_then 44 | | T.Pconst (EmlSyntax.Pbool true) -> (* if e then e_then else e_else *) 45 | mk_exp_if ~loc e e_then e_else 46 | | T.Pconst (EmlSyntax.Pbool false) -> (* if e then e_else else e_then *) 47 | mk_exp_if ~loc e e_else e_then 48 | | T.Pconst (EmlSyntax.Pchar c) -> (* if e = c then e_then else e_else *) 49 | mk_exp_if_eq ~loc e (mk_exp_char ~loc c) e_then e_else 50 | | T.Pconst (EmlSyntax.Pint n) -> (* if e = n then e_then else e_else *) 51 | mk_exp_if_eq ~loc e (mk_exp_int ~loc n) e_then e_else 52 | | T.Ptuple pl -> conv_pat_list ~loc e e_then e_else pl 53 | | T.Pconstr (tag, _, pl) -> 54 | let e_then' = conv_pat_list ~loc e e_then e_else pl in 55 | mk_exp_if_eq ~loc (mk_exp_tag ~loc e) (mk_exp_int ~loc tag) e_then' e_else 56 | 57 | and conv_pat_list ~loc e e_then e_else pl = 58 | let n = List.length pl in 59 | List.fold_righti 60 | (fun i pi acc -> 61 | conv_pat (mk_exp_proj ~loc ~typ:pi.typ e n i) acc e_else pi) 62 | pl e_then 63 | 64 | let rec conv_expr e = match e.data with 65 | | Error -> { e with data = Error } 66 | | Const c -> { e with data = Const c } 67 | | Var id -> { e with data = Var id } 68 | | Constr (id, el) -> { e with data = Constr (id, List.map conv_expr el) } 69 | | Tuple el -> { e with data = Tuple (List.map conv_expr el) } 70 | | Op op -> { e with data = Op (EmlOp.map conv_expr op) } 71 | | Abs (args, e0) -> { e with data = Abs (args, conv_expr e0) } 72 | | App (e0, el) -> 73 | { e with data = App (conv_expr e0, List.map conv_expr el) } 74 | | If (e1, e2, e3) -> 75 | { e with data = If (conv_expr e1, conv_expr e2, conv_expr e3) } 76 | | Let (rf, id, ts, e1, e2) -> 77 | { e with data = Let (rf, id, ts, conv_expr e1, conv_expr e2) } 78 | | Ext (T.Constraint (e1, _)) -> conv_expr e1 (* Remove type constraints *) 79 | | Ext (T.Match (e0, cases)) -> 80 | let e0' = conv_expr e0 in 81 | List.fold_right (fun (pi, ei) acc -> conv_pat e0' (conv_expr ei) acc pi) 82 | cases { e with typ = EmlType.fresh_var (); data = Error; } 83 | 84 | let convert = map conv_expr 85 | -------------------------------------------------------------------------------- /src/emlRemoveMatch.mli: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | type expr = ext_expr EmlTypedExpr.base_expr [@@deriving show] 19 | and ext_expr = 20 | | Tag of expr (* Obtain the tag of a data constructor *) 21 | | Proj of expr * int * int (* Projection operator *) 22 | 23 | type top = ext_expr EmlTypedExpr.base_top [@@deriving show] 24 | 25 | val convert : EmlTyping.top list -> top list 26 | -------------------------------------------------------------------------------- /src/emlSyntax.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open Format 19 | open EmlUtils 20 | open EmlLocation 21 | 22 | type const_pattern = 23 | | Punit 24 | | Pbool of bool 25 | | Pchar of char 26 | | Pint of int 27 | [@@deriving show] 28 | 29 | type pattern = pattern_desc EmlLocation.loc 30 | and pattern_desc = 31 | | Pvar of string option 32 | | Pconst of const_pattern 33 | | Ptuple of pattern list 34 | | Pconstr of string * pattern list 35 | [@@deriving show] 36 | 37 | type const = 38 | | Unit 39 | | Bool of bool 40 | | Char of char 41 | | Int of int 42 | | Float of float 43 | [@@deriving show] 44 | 45 | type expr = expr_desc EmlLocation.loc 46 | and expr_desc = 47 | | Const of const 48 | | Var of string 49 | | Constr of string * expr list 50 | | Tuple of expr list 51 | | If of expr * expr * expr 52 | | EmlOp of expr EmlOp.t 53 | | App of expr * expr list 54 | | Abs of string option list * expr 55 | | Let of bool * string * expr * expr 56 | | Match of expr * (pattern * expr) list 57 | | Constraint of expr * EmlType.t 58 | | Error 59 | [@@deriving show] 60 | 61 | type top = top_desc EmlLocation.loc 62 | and top_desc = 63 | | Top_variant_type of string 64 | * string option list 65 | * (string * EmlType.t list) list 66 | | Top_let of bool * string * expr 67 | | Top_code of string 68 | | Top_use of string 69 | [@@deriving show] 70 | -------------------------------------------------------------------------------- /src/emlType.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open EmlUtils 19 | open Format 20 | 21 | type type_var = int [@@deriving show] 22 | 23 | type t = 24 | | Unit 25 | | Bool 26 | | Char 27 | | Int 28 | | Float 29 | | Arrow of t list * t 30 | | Tuple of t list 31 | | Tconstr of string * t list 32 | | Var of string option * type_var 33 | | Ref of t ref (* for destructive unification *) 34 | 35 | (** {2 Sets of type variables} *) 36 | 37 | module VarSet = Set.Make(struct 38 | type t = type_var 39 | let compare = Pervasives.compare 40 | end) 41 | 42 | (** {2 Types} *) 43 | 44 | let fresh_type_var = 45 | let c = ref 0 in 46 | fun () -> incr c ; !c 47 | 48 | let make_var ?name i = Ref (ref (Var (name, i))) 49 | 50 | let fresh_var ?name () = make_var ?name (fresh_type_var ()) 51 | 52 | let rec observe = function 53 | | Ref r -> observe !r 54 | | t -> t 55 | 56 | let name_of_int n = 57 | let chrs = "abcdefghijklmnopqrstuvwxyz" in 58 | let m = String.length chrs in 59 | let rec aux s n = 60 | if n < 0 then s else aux (Char.escaped chrs.[n mod m] ^ s) (n / m - 1) 61 | in 62 | aux "" n 63 | 64 | let is_basetype t = match observe t with 65 | | Bool | Char | Int | Float -> true 66 | | _ -> false 67 | 68 | let unarrow t = match observe t with 69 | | Arrow (args, ret) -> Some (args, ret) 70 | | _ -> None 71 | 72 | let box_type t = 73 | let rec conv t = match observe t with 74 | | Bool | Char | Int | Float -> Tconstr ("__ml_boxed", [t]) 75 | | Arrow (args, ret) -> Arrow (List.map conv args, conv ret) 76 | | Tconstr (name, tl) when name <> "__ml_boxed" -> 77 | Tconstr (name, List.map conv tl) 78 | | Tuple tl -> Tuple (List.map conv tl) 79 | | _ -> t 80 | in 81 | (is_basetype t, conv t) 82 | 83 | let unbox_type t = match observe t with 84 | | Tconstr ("__ml_boxed", [t']) -> (true, t') 85 | | _ -> (false, t) 86 | 87 | let fv_in_type = 88 | let rec aux acc t = match observe t with 89 | | Ref _ -> assert false 90 | | Unit | Bool | Char | Int | Float -> acc 91 | | Var (_, i) -> VarSet.add i acc 92 | | Tuple tl -> List.fold_left aux acc tl 93 | | Tconstr (_, tl) -> List.fold_left aux acc tl 94 | | Arrow (args, ret) -> List.fold_left aux (aux acc ret) args 95 | in 96 | aux VarSet.empty 97 | 98 | let get_var_name = 99 | let tbl = ref [] in 100 | fun (x : type_var) -> 101 | try List.assoc x !tbl 102 | with Not_found -> 103 | let name = "'" ^ name_of_int (List.length !tbl) in 104 | tbl := (x, name) :: !tbl; 105 | name 106 | 107 | let rec pp ppf t = 108 | let rec aux b ppf t = match observe t with 109 | | Ref _ -> assert false 110 | | Var (_, i) -> pp_var ppf i 111 | | Unit -> pp_print_string ppf "unit" 112 | | Bool -> pp_print_string ppf "bool" 113 | | Char -> pp_print_string ppf "char" 114 | | Int -> pp_print_string ppf "int" 115 | | Float -> pp_print_string ppf "float" 116 | | Tuple tl -> fprintf ppf "(@[%a@])" (pp_tuple (aux true)) tl 117 | | Tconstr (s, []) -> pp_print_string ppf s 118 | | Tconstr (s, [t]) -> fprintf ppf "@[%a@] %s" (aux true) t s 119 | | Tconstr (s, tl) -> fprintf ppf "(@[%a@]) %s" 120 | (pp_list_comma (aux false)) tl s 121 | | Arrow (args, ret) -> 122 | if b then pp_print_char ppf '('; 123 | List.iter (fprintf ppf "%a -> " (aux true)) args; 124 | aux false ppf ret; 125 | if b then pp_print_char ppf ')' 126 | in 127 | aux false ppf t 128 | 129 | and pp_tuple pp = 130 | let pp_delim ppf = 131 | pp_print_space ppf (); 132 | pp_print_string ppf "* " 133 | in 134 | pp_list ~pp_delim pp 135 | 136 | and pp_var ppf i = pp_print_string ppf (get_var_name i) 137 | 138 | let rec occurs_check x t = match observe t with 139 | | Ref _ -> assert false 140 | | Var (_, y) -> x != y 141 | | Unit | Bool | Char | Int | Float -> true 142 | | Arrow (args, ret) -> List.for_all (occurs_check x) (ret :: args) 143 | | Tuple tl | Tconstr (_, tl) -> List.for_all (occurs_check x) tl 144 | 145 | (** [bind x t] binds type variable [x] to type [t]. *) 146 | let rec bind = function 147 | | Ref { contents = (Ref _ as t) } -> bind t 148 | | Ref ({ contents = Var _ } as r) -> fun t -> r := t 149 | | _ -> failwith "EmlType.bind" 150 | 151 | let unify ~loc t0 u0 = 152 | let rec aux t u = match observe t, observe u with 153 | | Unit, Unit -> () 154 | | Bool, Bool -> () 155 | | Char, Char -> () 156 | | Int, Int -> () 157 | | Float, Float -> () 158 | | Var (_, x), Var (_, y) when x == y -> () 159 | | Var (_, x), _ when occurs_check x u -> bind t u 160 | | _, Var (_, y) when occurs_check y t -> bind u t 161 | | Tuple tl, Tuple ul -> List.iter2 aux tl ul 162 | | Tconstr (ts, tl), Tconstr (us, ul) when ts = us -> 163 | (try List.iter2 aux tl ul 164 | with Invalid_argument _ -> 165 | errorf ~loc "The type constructor %s expects %d argument(s), \ 166 | but is here applied to %d argument(s)" 167 | ts (List.length tl) (List.length ul) ()) 168 | | Arrow (t1 :: tl, tr), Arrow (u1 :: ul, ur) -> 169 | aux t1 u1 ; aux (Arrow (tl, tr)) (Arrow (ul, ur)) 170 | | Arrow ([], tr), Arrow ([], ur) -> aux tr ur 171 | | Arrow ([], tr), Arrow _ -> aux tr u 172 | | Arrow _, Arrow ([], ur) -> aux t ur 173 | | _ -> errorf ~loc "This expression has type %a\n\ 174 | but an expression was expected of type %a\n\ 175 | Type %a is not compatible with %a" 176 | pp t0 pp u0 pp t pp u () 177 | in 178 | aux t0 u0 179 | 180 | (** {2 Type scheme} *) 181 | 182 | type scheme = VarSet.t * t 183 | 184 | type context = (string * scheme) list 185 | 186 | let scheme t = (VarSet.empty, t) 187 | 188 | let generalize vars t0 = 189 | let old_vars = VarSet.elements vars in 190 | let new_vars = List.map (fun _ -> fresh_type_var ()) old_vars in 191 | let tbl = List.map2 (fun i j -> (i, make_var j)) old_vars new_vars in 192 | let rec aux t = match observe t with 193 | | Ref _ -> assert false 194 | | Unit | Bool | Char | Int | Float -> t 195 | | Var (_, i) -> if VarSet.mem i vars then List.assoc i tbl else t 196 | | Tuple tl -> Tuple (List.map aux tl) 197 | | Tconstr (s, tl) -> Tconstr (s, List.map aux tl) 198 | | Arrow (args, ret) -> Arrow (List.map aux args, aux ret) 199 | in 200 | (VarSet.of_list new_vars, aux t0) 201 | 202 | let instantiate (vars, t) = generalize vars t |> snd 203 | 204 | let fv_in_scheme (bv, t) = VarSet.diff (fv_in_type t) bv 205 | 206 | let box_scheme (vars, t) = 207 | let (need, t') = box_type t in 208 | (need, (vars, t')) 209 | 210 | let unbox_scheme (vars, t) = 211 | let (need, t') = unbox_type t in 212 | (need, (vars, t')) 213 | 214 | let pp_scheme ppf (vars, t) = 215 | match VarSet.elements vars with 216 | | [] -> pp ppf t 217 | | l -> fprintf ppf "@[forall @[%a@].@;<1 2>@[%a@]@]" 218 | (pp_list_comma pp_var) l pp t 219 | 220 | (** {2 Type declaration} *) 221 | 222 | type constr_tag = int [@@deriving show] 223 | 224 | type decl = 225 | | Variant of string (* type name *) 226 | * type_var list (* type parameters of type constructor *) 227 | * (constr_tag * string * t list) list (* constructors *) 228 | [@@deriving show] 229 | 230 | let make_constr_tags = 231 | List.mapi (fun i (_, cargs) -> 232 | let n = List.length cargs in (* # of arguments *) 233 | let m = if n >= 2 then 2 else n in (* m = 0, 1, 2 [2 bits] *) 234 | ((i + 1) lsl 2) lor m) 235 | 236 | let constr_scheme ty_name ty_vars c_args = 237 | let ty_args = List.map (make_var ?name:None) ty_vars in 238 | let ret = Tconstr (ty_name, ty_args) in 239 | let t = Arrow (c_args, ret) in 240 | let fv = fv_in_type t in 241 | generalize fv t 242 | -------------------------------------------------------------------------------- /src/emlType.mli: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | type type_var [@@deriving show] 19 | 20 | type t = 21 | | Unit 22 | | Bool 23 | | Char 24 | | Int 25 | | Float 26 | | Arrow of t list * t 27 | | Tuple of t list 28 | | Tconstr of string * t list 29 | | Var of string option * type_var 30 | | Ref of t ref (* for destructive unification *) 31 | 32 | (** {2 Sets of type variables} *) 33 | 34 | module VarSet : Set.S with type elt = type_var 35 | 36 | (** {2 Types} *) 37 | 38 | val fresh_type_var : unit -> type_var 39 | val fresh_var : ?name:string -> unit -> t 40 | 41 | val observe : t -> t 42 | val is_basetype : t -> bool 43 | val unarrow : t -> (t list * t) option 44 | val box_type : t -> bool * t 45 | val unbox_type : t -> bool * t 46 | 47 | (** Returns a set of free type variables in a given type. *) 48 | val fv_in_type : t -> VarSet.t 49 | 50 | val unify : loc:EmlLocation.t -> t -> t -> unit 51 | 52 | val pp : Format.formatter -> t -> unit 53 | 54 | (** {2 Type schemes} *) 55 | 56 | type scheme 57 | 58 | (** [scheme t] converts type [t] into a type scheme with no generalization, 59 | i.e., no type variables are for-all bound. *) 60 | val scheme : t -> scheme 61 | 62 | (** [generalize set t] generalizes type [t] into a type scheme by substituting 63 | type variables in [set] for fresh variables. *) 64 | val generalize : VarSet.t -> t -> scheme 65 | 66 | (** [instantiate ts] instantiates for-all bound type variables in type scheme 67 | [ts]. *) 68 | val instantiate : scheme -> t 69 | 70 | (** Returns a set of free type variables in a given type scheme. *) 71 | val fv_in_scheme : scheme -> VarSet.t 72 | 73 | val box_scheme : scheme -> bool * scheme 74 | val unbox_scheme : scheme -> bool * scheme 75 | 76 | val pp_scheme : Format.formatter -> scheme -> unit 77 | 78 | (** {2 Type declaration} *) 79 | 80 | type constr_tag = int [@@deriving show] 81 | 82 | type decl = 83 | | Variant of string (* type name *) 84 | * type_var list (* type parameters of type constructor *) 85 | * (constr_tag * string * t list) list (* constructors *) 86 | [@@deriving show] 87 | 88 | val make_constr_tags : (string * t list) list -> constr_tag list 89 | 90 | val constr_scheme : string -> type_var list -> t list -> scheme 91 | -------------------------------------------------------------------------------- /src/emlTypedExpr.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open EmlUtils 19 | open Format 20 | 21 | module S = EmlSyntax 22 | 23 | (** {2 EmlTyped expressions} *) 24 | 25 | type 'a typed = 26 | { 27 | loc : EmlLocation.t; 28 | typ : EmlType.t; 29 | data : 'a; 30 | } 31 | [@@deriving show] 32 | 33 | type 'a base_expr = 'a expr_desc typed 34 | and 'a expr_desc = 35 | | Error 36 | | Const of S.const 37 | | Var of string 38 | | Constr of string * 'a base_expr list 39 | | Tuple of 'a base_expr list 40 | | If of 'a base_expr * 'a base_expr * 'a base_expr 41 | | Op of 'a base_expr EmlOp.t 42 | | App of 'a base_expr * 'a base_expr list 43 | | Abs of string option list * 'a base_expr 44 | | Let of bool * string * EmlType.scheme * 'a base_expr * 'a base_expr 45 | | Ext of 'a (* extended *) 46 | [@@deriving show] 47 | 48 | let mk_exp_error ~loc () = { loc; typ = EmlType.fresh_var (); data = Error; } 49 | let mk_exp_unit ~loc () = { loc; typ = EmlType.Unit; data = Const S.Unit; } 50 | let mk_exp_bool ~loc b = { loc; typ = EmlType.Bool; data = Const (S.Bool b); } 51 | let mk_exp_char ~loc c = { loc; typ = EmlType.Char; data = Const (S.Char c); } 52 | let mk_exp_int ~loc n = { loc; typ = EmlType.Int; data = Const (S.Int n); } 53 | let mk_exp_float ~loc x = { loc; typ = EmlType.Float; data = Const (S.Float x);} 54 | let mk_exp_var ~loc id t = { loc; typ = t; data = Var id; } 55 | let mk_exp_constr ~loc id t el = { loc; typ = t; data = Constr (id, el); } 56 | 57 | let mk_exp_var_lookup ~loc ctx id = 58 | let tysc = EmlContext.lookup_var ~loc id ctx in 59 | mk_exp_var ~loc id (EmlType.instantiate tysc) 60 | 61 | let mk_exp_tuple ~loc el = 62 | let tl = List.map (fun ei -> ei.typ) el in 63 | { loc; typ = EmlType.Tuple tl; data = Tuple el; } 64 | 65 | let mk_exp_op ~loc op = 66 | let typ = match op with 67 | (* comparison operators (polymorphic) *) 68 | | EmlOp.Eq (e1, e2) | EmlOp.Ne (e1, e2) | EmlOp.Gt (e1, e2) 69 | | EmlOp.Lt (e1, e2) | EmlOp.Ge (e1, e2) | EmlOp.Le (e1, e2) -> 70 | EmlType.unify ~loc e1.typ e2.typ; 71 | EmlType.Bool 72 | (* boolean operators *) 73 | | EmlOp.Not e1 -> 74 | EmlType.unify ~loc:e1.loc e1.typ EmlType.Bool; 75 | EmlType.Bool 76 | | EmlOp.And (e1, e2) | EmlOp.Or (e1, e2) -> 77 | EmlType.unify ~loc:e1.loc e1.typ EmlType.Bool; 78 | EmlType.unify ~loc:e2.loc e2.typ EmlType.Bool; 79 | EmlType.Bool 80 | (* integer operators *) 81 | | EmlOp.Pos e1 | EmlOp.Neg e1 | EmlOp.Lnot e1 -> 82 | EmlType.unify ~loc:e1.loc e1.typ EmlType.Int; 83 | EmlType.Int 84 | | EmlOp.Add (e1, e2) | EmlOp.Sub (e1, e2) | EmlOp.Mul (e1, e2) 85 | | EmlOp.Div (e1, e2) | EmlOp.Mod (e1, e2) | EmlOp.Land (e1, e2) 86 | | EmlOp.Lor (e1, e2) | EmlOp.Lxor (e1, e2) | EmlOp.Lsl (e1, e2) 87 | | EmlOp.Lsr (e1, e2) | EmlOp.Asr (e1, e2) -> 88 | EmlType.unify ~loc:e1.loc e1.typ EmlType.Int; 89 | EmlType.unify ~loc:e2.loc e2.typ EmlType.Int; 90 | EmlType.Int 91 | (* floating-point-value operators *) 92 | | EmlOp.FPos e1 | EmlOp.FNeg e1 -> 93 | EmlType.unify ~loc:e1.loc e1.typ EmlType.Float; 94 | EmlType.Int 95 | | EmlOp.FAdd (e1, e2) | EmlOp.FSub (e1, e2) | EmlOp.FMul (e1, e2) 96 | | EmlOp.FDiv (e1, e2) -> 97 | EmlType.unify ~loc:e1.loc e1.typ EmlType.Float; 98 | EmlType.unify ~loc:e2.loc e2.typ EmlType.Float; 99 | EmlType.Float 100 | in 101 | { loc; typ; data = Op op; } 102 | 103 | let mk_exp_if ~loc e1 e2 e3 = 104 | EmlType.unify ~loc e1.typ EmlType.Bool; 105 | EmlType.unify ~loc e2.typ e3.typ; 106 | { loc; typ = e2.typ; data = If (e1, e2, e3); } 107 | 108 | let mk_exp_app ~loc e_fun e_args = 109 | let t_args = List.map (fun ei -> ei.typ) e_args in 110 | let t_ret = EmlType.fresh_var () in 111 | let t_fun = EmlType.Arrow (t_args, t_ret) in 112 | EmlType.unify ~loc e_fun.typ t_fun; 113 | { loc; typ = t_ret; data = App (e_fun, e_args); } 114 | 115 | let mk_exp_abs ?arg_types ~loc ctx f args e_body = 116 | let t_args = match arg_types with 117 | | None -> List.map (fun _ -> EmlType.fresh_var ()) args 118 | | Some t_args -> t_args in 119 | let ctx' = EmlContext.add_args args t_args ctx in 120 | let e_body' = f ctx' e_body in 121 | let t_fun = EmlType.Arrow (t_args, e_body'.typ) in 122 | { loc; typ = t_fun; data = Abs (args, e_body'); } 123 | 124 | let mk_exp_let_rhs ~loc ctx f rf id e1 = 125 | let e1' = if not rf then f ctx e1 else begin 126 | let tx = EmlType.fresh_var () in 127 | let e1' = f (EmlContext.add_var id (EmlType.scheme tx) ctx) e1 in 128 | EmlType.unify ~loc tx e1'.typ; 129 | e1' 130 | end in 131 | let ts = EmlContext.generalize_type ctx e1'.typ in 132 | (ts, e1') 133 | 134 | let mk_exp_let ~loc ctx f rf id e1 e2 = 135 | let (ts, e1') = mk_exp_let_rhs ~loc ctx f rf id e1 in 136 | let e2' = f (EmlContext.add_var id ts ctx) e2 in 137 | { loc; typ = e2'.typ; data = Let (rf, id, ts, e1', e2'); } 138 | 139 | let mk_exp_simple_let ~loc rf id e1 e2 = 140 | { loc; typ = e2.typ; data = Let (rf, id, EmlType.scheme e1.typ, e1, e2) } 141 | 142 | (** {2 Top-level declaration} *) 143 | 144 | module L = EmlLocation 145 | 146 | type 'a base_top = 'a top_desc EmlLocation.loc 147 | and 'a top_desc = 148 | | Top_type of EmlType.decl 149 | | Top_let of bool * string * EmlType.scheme * 'a base_expr 150 | | Top_code of string 151 | [@@deriving show] 152 | 153 | let map f = 154 | let aux = function 155 | | Top_type decl -> Top_type decl 156 | | Top_let (rf, id, ts, e) -> Top_let (rf, id, ts, f e) 157 | | Top_code s -> Top_code s 158 | in 159 | List.map (L.map aux) 160 | 161 | let fold_map f_vtype f_let init = 162 | let aux acc { L.loc; L.data; } = match data with 163 | | Top_type decl -> 164 | let (acc', data) = f_vtype loc acc decl in 165 | (acc', { L.loc; L.data; }) 166 | | Top_let (rf, id, ts, e) -> 167 | let (acc', data) = f_let loc acc rf id ts e in 168 | (acc', { L.loc; L.data; }) 169 | | Top_code s -> (acc, { L.loc; L.data = Top_code s; }) 170 | in 171 | List.fold_map aux init 172 | 173 | let typeof_constrs name args cs = 174 | let t_ret = EmlType.Tconstr (name, args) in 175 | let aux (_, _, t_args) = 176 | EmlContext.generalize_type EmlContext.empty (EmlType.Arrow (t_args, t_ret)) 177 | in 178 | List.map aux cs 179 | -------------------------------------------------------------------------------- /src/emlTyping.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open EmlUtils 19 | open Format 20 | open EmlTypedExpr 21 | 22 | module L = EmlLocation 23 | module S = EmlSyntax 24 | 25 | type pattern = pattern_desc typed [@@deriving show] 26 | and pattern_desc = 27 | | Pvar of string option 28 | | Pconst of S.const_pattern 29 | | Ptuple of pattern list 30 | | Pconstr of EmlType.constr_tag * string * pattern list 31 | 32 | type expr = ext_expr base_expr 33 | and ext_expr = 34 | | Match of expr * (pattern * expr) list 35 | | Constraint of expr * EmlType.t 36 | [@@deriving show] 37 | 38 | type top = ext_expr EmlTypedExpr.base_top [@@deriving show] 39 | 40 | let check_dup ~loc l = 41 | match List.duplicated l with 42 | | [] -> () 43 | | dups -> errorf ~loc "Duplicated identifier(s): %a" 44 | (pp_list_comma pp_print_string) dups () 45 | 46 | let check_dup_args ~loc args = 47 | check_dup ~loc (List.filter_map identity args) 48 | 49 | let typing_constr ~loc mk_tuple ctx id args = 50 | let (_, u_args, u_ret) = EmlContext.lookup_constr ~loc id ctx in 51 | let unify locs t_args = 52 | let t_ret = EmlType.fresh_var () in 53 | List.iter3 (fun loc u t -> EmlType.unify ~loc u t) locs u_args t_args; 54 | EmlType.unify ~loc u_ret t_ret; 55 | t_ret 56 | in 57 | let t_args = List.map (fun x -> x.typ) args in 58 | let m = List.length t_args in 59 | let n = List.length u_args in 60 | if m = n then (unify (List.map (fun x -> x.loc) args) t_args, args) 61 | else if n = 1 && m > 1 62 | then begin 63 | let typ = EmlType.Tuple t_args in 64 | (unify [loc] [typ], [{ loc; typ; data = mk_tuple args; }]) 65 | end 66 | else errorf ~loc "Constructor %s expects %d argument(s) \ 67 | but %d argument(s) are applied" id n m () 68 | 69 | let rec typing_expr ctx { L.loc; L.data } = match data with 70 | | S.Error -> mk_exp_error ~loc () 71 | | S.Const S.Unit -> mk_exp_unit ~loc () 72 | | S.Const (S.Bool b) -> mk_exp_bool ~loc b 73 | | S.Const (S.Char c) -> mk_exp_char ~loc c 74 | | S.Const (S.Int n) -> mk_exp_int ~loc n 75 | | S.Const (S.Float x) -> mk_exp_float ~loc x 76 | | S.Var s -> mk_exp_var_lookup ~loc ctx s 77 | | S.Constr (id, el) -> 78 | let el' = List.map (typing_expr ctx) el in 79 | let (t_ret, el') = typing_constr ~loc (fun el -> Tuple el) ctx id el' in 80 | mk_exp_constr ~loc id t_ret el' 81 | | S.Tuple el -> mk_exp_tuple ~loc (List.map (typing_expr ctx) el) 82 | | S.EmlOp op -> mk_exp_op ~loc (EmlOp.map (typing_expr ctx) op) 83 | | S.If (e1, e2, e3) -> 84 | mk_exp_if ~loc (typing_expr ctx e1) 85 | (typing_expr ctx e2) (typing_expr ctx e3) 86 | | S.App (e_fun, e_args) -> 87 | mk_exp_app ~loc (typing_expr ctx e_fun) (List.map (typing_expr ctx) e_args) 88 | | S.Abs (args, e_body) -> 89 | check_dup_args ~loc args; 90 | mk_exp_abs ~loc ctx typing_expr args e_body 91 | | S.Let (rf, id, e1, e2) -> mk_exp_let ~loc ctx typing_expr rf id e1 e2 92 | | S.Constraint (e, t) -> 93 | let e' = typing_expr ctx e in 94 | EmlType.unify ~loc e'.typ t; 95 | { loc; typ = t; data = Ext (Constraint (e', t)); } 96 | | S.Match (e0, cases) -> typing_match ~loc ctx e0 cases 97 | 98 | and typing_match ~loc ctx e0 cases = 99 | let e0' = typing_expr ctx e0 in 100 | let (t_in, t_out) = (e0'.typ, EmlType.fresh_var ()) in 101 | let typing_case (pi, ei) = 102 | let (ctx', pi') = typing_pattern ctx pi in 103 | let ei' = typing_expr ctx' ei in 104 | EmlType.unify ~loc pi'.typ t_in; 105 | EmlType.unify ~loc ei'.typ t_out; 106 | (pi', ei') 107 | in 108 | let cases' = List.map typing_case cases in 109 | { loc; typ = t_out; data = Ext (Match (e0', cases')); } 110 | 111 | and typing_pattern ctx { L.loc; L.data } = match data with 112 | | S.Pconst S.Punit -> 113 | (ctx, { loc; typ = EmlType.Unit; data = Pconst S.Punit; }) 114 | | S.Pconst (S.Pbool b) -> 115 | (ctx, { loc; typ = EmlType.Unit; data = Pconst (S.Pbool b); }) 116 | | S.Pconst (S.Pchar c) -> 117 | (ctx, { loc; typ = EmlType.Char; data = Pconst (S.Pchar c); }) 118 | | S.Pconst (S.Pint n) -> 119 | (ctx, { loc; typ = EmlType.Int; data = Pconst (S.Pint n); }) 120 | | S.Pvar None -> 121 | (ctx, { loc; typ = EmlType.fresh_var (); data = Pvar None; }) 122 | | S.Pvar (Some id) -> 123 | let typ = EmlType.fresh_var () in 124 | (EmlContext.add_var id (EmlType.scheme typ) ctx, 125 | { loc; typ; data = Pvar (Some id); }) 126 | | S.Ptuple pl -> 127 | let (ctx', pl') = List.fold_map typing_pattern ctx pl in 128 | let typ = EmlType.Tuple (List.map (fun p -> p.typ) pl') in 129 | (ctx', { loc; typ; data = Ptuple pl'; }) 130 | | S.Pconstr (id, pl) -> 131 | let (ctx', pl') = List.fold_map typing_pattern ctx pl in 132 | let (t_ret, pl') = typing_constr ~loc (fun pl -> Ptuple pl) ctx id pl' in 133 | let (tag, _, _) = EmlContext.lookup_constr ~loc id ctx in 134 | (ctx', { loc; typ = t_ret; data = Pconstr (tag, id, pl'); }) 135 | 136 | (** Scope analysis for type variables in a given type *) 137 | let convert_type ~loc ctx tbl = 138 | let rec aux t = match EmlType.observe t with 139 | | EmlType.Ref _ -> assert false 140 | | EmlType.Unit | EmlType.Bool | EmlType.Char | EmlType.Int 141 | | EmlType.Float -> t 142 | | EmlType.Var (None, _) -> t 143 | | EmlType.Var (Some s, _) -> 144 | if Hashtbl.mem tbl s then EmlType.Var (Some s, Hashtbl.find tbl s) 145 | else errorf ~loc "Unbound type parameter %s" s () 146 | | EmlType.Arrow (args, ret) -> EmlType.Arrow (List.map aux args, aux ret) 147 | | EmlType.Tuple tl -> EmlType.Tuple (List.map aux tl) 148 | | EmlType.Tconstr (id, tl) -> 149 | match EmlContext.lookup_type ~loc id ctx with 150 | | EmlType.Variant (name, args, _) -> 151 | let m, n = List.length tl, List.length args in 152 | if m = n then EmlType.Tconstr (id, List.map aux tl) 153 | else errorf ~loc "The type constructor %s expects %d argument(s), \ 154 | but is here applied to %d argument(s)" name n m () 155 | in 156 | List.map aux 157 | 158 | let convert_variant_type ~loc ctx name args constrs = 159 | check_dup_args ~loc args; 160 | check_dup ~loc (List.map fst constrs); 161 | let tbl = Hashtbl.create 4 in 162 | let add_to_tbl = function 163 | | None -> EmlType.fresh_type_var () 164 | | Some s -> 165 | let i = EmlType.fresh_type_var () in 166 | Hashtbl.add tbl s i ; i 167 | in 168 | let args' = List.map add_to_tbl args in 169 | let ctx' = EmlContext.add_type (* a dummy context for checking rec types *) 170 | (EmlType.Variant (name, args', [])) ctx in 171 | let constrs' = List.map2 172 | (fun tag (name, t) -> (tag, name, convert_type ~loc ctx' tbl t)) 173 | (EmlType.make_constr_tags constrs) constrs in 174 | EmlType.Variant (name, args', constrs') 175 | 176 | let typing ctx = 177 | let aux ctx { L.loc; L.data } = match data with 178 | | S.Top_variant_type (name, args, constrs) -> 179 | let decl = convert_variant_type ~loc ctx name args constrs in 180 | let ctx' = EmlContext.add_type decl ctx in 181 | (ctx', { L.loc; L.data = Top_type decl }) 182 | | S.Top_let (rf, id, e1) -> 183 | let (ts, e1') = mk_exp_let_rhs ~loc ctx typing_expr rf id e1 in 184 | (EmlContext.add_var id ts ctx, 185 | { L.loc; L.data = Top_let (rf, id, ts, e1') }) 186 | | S.Top_code s -> (ctx, { L.loc; L.data = Top_code s; }) 187 | | S.Top_use _ -> failwith "Typing.typing: Syntax.Top_use remains" 188 | in 189 | List.fold_map aux ctx >> snd 190 | -------------------------------------------------------------------------------- /src/emlTyping.mli: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | type pattern = pattern_desc EmlTypedExpr.typed [@@deriving show] 19 | and pattern_desc = 20 | | Pvar of string option 21 | | Pconst of EmlSyntax.const_pattern 22 | | Ptuple of pattern list 23 | | Pconstr of EmlType.constr_tag * string * pattern list 24 | 25 | type expr = ext_expr EmlTypedExpr.base_expr 26 | and ext_expr = 27 | | Match of expr * (pattern * expr) list 28 | | Constraint of expr * EmlType.t 29 | [@@deriving show] 30 | 31 | type top = ext_expr EmlTypedExpr.base_top [@@deriving show] 32 | 33 | val typing : EmlContext.t -> EmlSyntax.top list -> top list 34 | -------------------------------------------------------------------------------- /src/emlUnCurrying.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open Format 19 | open EmlUtils 20 | open EmlTypedExpr 21 | open EmlRemoveMatch 22 | 23 | (* Eta conversion for uncurrying partial application *) 24 | let eta_conv ~loc e_fun e_args1 t_args2 t_ret = 25 | let ids = List.mapi (fun i _ -> "__ml_x" ^ string_of_int i) t_args2 in 26 | let e_args2 = List.map2 (mk_exp_var ~loc) ids t_args2 in 27 | let e_app = { loc; typ = t_ret; data = App (e_fun, e_args1 @ e_args2); } in 28 | { loc; typ = EmlType.Arrow (t_args2, t_ret); 29 | data = Abs (List.map (fun x -> Some x) ids, e_app); } 30 | 31 | let rec conv_app ~loc e_fun e_args = 32 | match EmlType.unarrow e_fun.typ with 33 | | None -> errorf ~loc "Arrow type is expected but an expression has type %a" 34 | EmlType.pp e_fun.typ () 35 | | Some (t_args, t_ret) -> 36 | let m = List.length e_args in (* # of actual arguments *) 37 | let n = List.length t_args in (* # of formal arguments *) 38 | if m = n 39 | then { loc; typ = t_ret; data = App (e_fun, e_args); } 40 | else if m > n (* application to returned function (e.g., id id 42) *) 41 | then begin 42 | let (e_args', rest) = List.block n e_args in 43 | conv_app ~loc ({ loc; typ = t_ret; data = App (e_fun, e_args'); }) rest 44 | end 45 | else begin (* m < n: partial application *) 46 | let (_, t_args') = List.block m t_args in 47 | eta_conv ~loc e_fun e_args t_args' t_ret 48 | end 49 | 50 | let rec conv_expr e = match e.data with 51 | | Const _ | Var _ | Error -> e 52 | | Ext (Tag e0) -> { e with data = Ext (Tag (conv_expr e0)) } 53 | | Ext (Proj (e0, n, i)) -> { e with data = Ext (Proj (conv_expr e0, n, i)) } 54 | | Constr (id, el) -> { e with data = Constr (id, List.map conv_expr el) } 55 | | Tuple el -> { e with data = Tuple (List.map conv_expr el) } 56 | | Op op -> { e with data = Op (EmlOp.map conv_expr op) } 57 | | If (e1, e2, e3) -> 58 | { e with data = If (conv_expr e1, conv_expr e2, conv_expr e3) } 59 | | Abs (args, e0) -> { e with data = Abs (args, conv_expr e0) } 60 | | Let (rf, id, ts, e1, e2) -> 61 | { e with data = Let (rf, id, ts, conv_expr e1, conv_expr e2) } 62 | | App (e0, el) -> conv_app ~loc:e.loc (conv_expr e0) (List.map conv_expr el) 63 | 64 | let convert = map conv_expr 65 | -------------------------------------------------------------------------------- /src/emlUnCurrying.mli: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | val convert : EmlRemoveMatch.top list -> EmlRemoveMatch.top list 19 | -------------------------------------------------------------------------------- /src/emlUtils.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open Format 19 | 20 | let identity x = x 21 | 22 | let ( << ) f g x = f (g x) 23 | let ( >> ) f g x = g (f x) 24 | 25 | module Option = 26 | struct 27 | let map f = function 28 | | Some x -> Some (f x) 29 | | None -> None 30 | 31 | let default x = function 32 | | Some y -> y 33 | | None -> x 34 | end 35 | 36 | module String = 37 | struct 38 | include String 39 | 40 | let has_prefix prefix s = 41 | let m = String.length prefix in 42 | let n = String.length s in 43 | if m <= n then String.sub s 0 m = prefix else false 44 | 45 | let to_list s = 46 | let rec aux i l = if i < 0 then l else aux (i-1) (s.[i] :: l) in 47 | aux (String.length s - 1) [] 48 | end 49 | 50 | module List = 51 | struct 52 | include List 53 | 54 | let is_empty xs = xs = [] 55 | 56 | let init f n = 57 | let rec aux acc i = if i < 0 then acc else aux (f i :: acc) (i - 1) in 58 | aux [] (n - 1) 59 | 60 | let rec last = function 61 | | [] -> failwith "List.last" 62 | | [x] -> x 63 | | _ :: xs -> last xs 64 | 65 | (** [block n [x(1); x(2); ...; x(n); x(n+1); ...; x(m)]] returns 66 | [[x(1); x(2); ...; x(n)]] and [[x(n+1); ...; x(m)]]. *) 67 | let block n l = 68 | let rec aux acc n l = 69 | if n = 0 then (List.rev acc, l) 70 | else match l with 71 | | [] -> failwith "List.block" 72 | | hd :: tl -> aux (hd :: acc) (n-1) tl 73 | in 74 | aux [] n l 75 | 76 | let fold_righti f x init = 77 | fold_right (fun xi (i, acc) -> (i - 1, f i xi acc)) x (length x - 1, init) 78 | |> snd 79 | 80 | let findi f x = 81 | let rec aux i = function 82 | | [] -> None 83 | | hd :: tl -> if f hd then Some (i, hd) else aux (i+1) tl 84 | in 85 | aux 0 x 86 | 87 | let iter3 f = 88 | let rec aux xs ys zs = match xs, ys, zs with 89 | | [], [], [] -> () 90 | | x :: xs, y :: ys, z :: zs -> f x y z ; aux xs ys zs 91 | | _ -> failwith "EmlUtils.List.iter3" 92 | in 93 | aux 94 | 95 | let rev_fold_map f init x = 96 | fold_left 97 | (fun (acc, rev_x) xi -> 98 | let (acc', xi') = f acc xi in 99 | (acc', xi' :: rev_x)) 100 | (init, []) x 101 | 102 | let fold_map f init x = 103 | let (acc, rev_x) = rev_fold_map f init x in 104 | (acc, rev rev_x) 105 | 106 | let filter_map f x = 107 | fold_left (fun acc xi -> 108 | match f xi with 109 | | Some yi -> yi :: acc 110 | | None -> acc) 111 | [] x 112 | |> rev 113 | 114 | let find_map f = 115 | let rec aux = function 116 | | [] -> None 117 | | xi :: x -> 118 | match f xi with 119 | | Some yi -> Some yi 120 | | None -> aux x 121 | in 122 | aux 123 | 124 | let duplicated l = 125 | let rec aux acc = function 126 | | [] -> acc 127 | | x :: l -> aux (if mem x l && not (mem x acc) then x :: acc else acc) l 128 | in 129 | rev (aux [] l) 130 | end 131 | 132 | module Format = 133 | struct 134 | include Format 135 | 136 | let rec pp_list ~pp_delim pp ppf = function 137 | | [] -> () 138 | | [x] -> pp ppf x 139 | | x :: l -> 140 | pp ppf x; 141 | pp_delim ppf; 142 | pp_list ~pp_delim pp ppf l 143 | 144 | let pp_list_comma pp = 145 | let pp_delim ppf = pp_print_char ppf ',' ; pp_print_space ppf () in 146 | pp_list ~pp_delim pp 147 | 148 | type buffer_formatter = { buffer : Buffer.t; ppf : formatter; } 149 | 150 | let create_buffer_formatter n = 151 | let buffer = Buffer.create n in 152 | let ppf = formatter_of_buffer buffer in 153 | { buffer; ppf; } 154 | 155 | let fetch_buffer_formatter bf = 156 | pp_print_flush bf.ppf (); 157 | Buffer.contents bf.buffer 158 | 159 | let skfprintf k fmt = 160 | let bf = create_buffer_formatter 16 in 161 | let aux ppf = k (fetch_buffer_formatter bf) in 162 | kfprintf aux bf.ppf fmt 163 | 164 | let sfprintf fmt = skfprintf (fun s () -> s) fmt 165 | end 166 | 167 | module StringSet = Set.Make(struct 168 | type t = string 169 | let compare = Pervasives.compare 170 | end) 171 | 172 | let gen_fresh_name prefix = 173 | let c = ref 0 in 174 | fun () -> incr c ; prefix ^ string_of_int !c 175 | 176 | let read_file fname = 177 | let open Buffer in 178 | let ic = open_in fname in 179 | let b = create 256 in 180 | try 181 | while true do 182 | add_string b (input_line ic); 183 | add_char b '\n' 184 | done; 185 | assert false 186 | with End_of_file -> 187 | close_in ic; 188 | contents b 189 | 190 | exception Compile_error of string EmlLocation.loc 191 | 192 | let errorf ?(loc = EmlLocation.dummy) fmt = 193 | Format.skfprintf 194 | (fun s -> raise (Compile_error EmlLocation.({ loc; data = s; }))) 195 | fmt 196 | -------------------------------------------------------------------------------- /src/evilml.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open EmlUtils 19 | open Format 20 | 21 | module Opts = 22 | struct 23 | let use_dirs = ref [] 24 | let header = ref (Filename.concat EmlConfig.include_dir "evilml.hpp") 25 | let input_file = ref "" 26 | let output_file = ref "" 27 | let verbose = ref false 28 | let embed = ref false 29 | 30 | let speclist = 31 | [ 32 | ("-I", Arg.String (fun s -> use_dirs := s :: !use_dirs), 33 | "\tAdd directory for #use-directive"); 34 | ("--header", Arg.Set_string header, "\tSpecify path of C++ header"); 35 | ("--output", Arg.Set_string output_file, "\tSpecify an output file"); 36 | ("--embed", Arg.Set embed, "\tEmbed header file \"evilml.hpp\""); 37 | ("--verbose", Arg.Set verbose, "\tVerbose mode"); 38 | ] 39 | 40 | let () = 41 | let usage_msg = 42 | "Evil ML is a compier from ML to C++ template language.\n\ 43 | \n\ 44 | Usage: evilml [options] filename\n" in 45 | Arg.parse speclist (fun s -> input_file := s) usage_msg; 46 | if !input_file = "" then begin (* Check input filename *) 47 | Arg.usage speclist usage_msg; 48 | exit (-1) 49 | end; 50 | if !output_file = "" 51 | then output_file := (Filename.chop_extension !input_file) ^ ".cpp" 52 | end 53 | 54 | let header = 55 | if !Opts.embed 56 | then sprintf "#line 1 %S\n%s\n#line 1 %S" 57 | !Opts.header (read_file !Opts.header) !Opts.output_file 58 | else sprintf "#include %S" !Opts.header 59 | 60 | let hook_typing = 61 | let f tops = 62 | List.iter (fun top -> match top.EmlLocation.data with 63 | | EmlTypedExpr.Top_let (_, id, ts, _) -> 64 | printf "val %s : %a@." id EmlType.pp_scheme ts 65 | | _ -> ()) tops 66 | in 67 | if !Opts.verbose then Some f else None 68 | 69 | let loader loc fname = 70 | try 71 | let path = !Opts.use_dirs @ [EmlConfig.include_dir; "."] 72 | |> List.map (fun dir -> Filename.concat dir fname) 73 | |> List.find Sys.file_exists in 74 | Lexing.from_channel (open_in path) 75 | with Not_found -> 76 | errorf ~loc "File %S is not found" fname () 77 | 78 | let main in_fname out_fname = 79 | let ic = open_in in_fname in 80 | let oc = open_out out_fname in 81 | let ppf = formatter_of_out_channel oc in 82 | begin 83 | try 84 | Lexing.from_channel ic 85 | |> EmlCompile.run ~loader ?hook_typing ~header in_fname 86 | |> List.iter (fprintf ppf "%a@\n@\n" EmlCpp.pp_decl) 87 | with 88 | | Compile_error ({ EmlLocation.loc; EmlLocation.data; }) -> 89 | eprintf "%a@\nError: %s@\n@\n[Stack Trace]@." EmlLocation.pp loc data; 90 | Printexc.print_backtrace stderr 91 | end; 92 | pp_print_flush ppf (); 93 | close_out oc; 94 | close_in ic 95 | 96 | let () = main !Opts.input_file !Opts.output_file 97 | -------------------------------------------------------------------------------- /src/evilmlJS.ml: -------------------------------------------------------------------------------- 1 | (* Evil ML --- A compiler from ML to C++ template language 2 | 3 | Copyright (C) 2015 Akinori ABE 4 | 5 | Evil ML is free software: you can redistribute it and/or modify 6 | it under the terms of the GNU General Public License as published by 7 | the Free Software Foundation, either version 3 of the License, or 8 | (at your option) any later version. 9 | 10 | Evil ML is distributed in the hope that it will be useful, 11 | but WITHOUT ANY WARRANTY; without even the implied warranty of 12 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13 | GNU General Public License for more details. 14 | 15 | You should have received a copy of the GNU General Public License 16 | along with this program. If not, see . *) 17 | 18 | open EmlUtils 19 | open Format 20 | open Js 21 | open Dom_html 22 | 23 | let input_fname = "(none)" 24 | 25 | let editor_get id = to_string (Unsafe.variable id)##getDoc##getValue 26 | let editor_set id s = (Unsafe.variable id)##getDoc##setValue (string s) 27 | 28 | let input id = 29 | match tagged (getElementById id) with 30 | | Input x -> x 31 | | _ -> failwith "Not element" 32 | 33 | let report_error loc msg = 34 | editor_set "cppEditor" (sfprintf "%a@\nError: %s" EmlLocation.pp loc msg ()); 35 | match loc with 36 | | Some loc when loc.EmlLocation.fname = input_fname -> 37 | Unsafe.fun_call (Unsafe.js_expr "reportError") 38 | [| Unsafe.inject (loc.EmlLocation.lnum_start); 39 | Unsafe.inject (loc.EmlLocation.cnum_start); 40 | Unsafe.inject (loc.EmlLocation.lnum_end); 41 | Unsafe.inject (loc.EmlLocation.cnum_end); 42 | Unsafe.inject (string msg); |] 43 | | _ -> () 44 | 45 | let make_header embed = 46 | let hpp_fname = "evilml.hpp" in 47 | if embed 48 | then sprintf "#line 1 %S\n%s\n#line 1 \"output.cpp\"" 49 | hpp_fname [%blob "../include/evilml.hpp"] 50 | else sprintf "#include %S" hpp_fname 51 | 52 | let loader loc fname = 53 | match fname with 54 | | "option.ml" -> Lexing.from_string [%blob "../include/option.ml"] 55 | | "list.ml" -> Lexing.from_string [%blob "../include/list.ml"] 56 | | _ -> errorf ~loc "File %S is not found" fname () 57 | 58 | let compile () = 59 | let embed = to_bool (input "chk_embed")##.checked in 60 | let in_code = editor_get "mlEditor" in 61 | let bf_tys = create_buffer_formatter 1024 in 62 | let bf_out = create_buffer_formatter 1024 in 63 | let hook_typing tops = 64 | List.iter (fun top -> match top.EmlLocation.data with 65 | | EmlTypedExpr.Top_let (_, id, ts, _) -> 66 | fprintf bf_tys.ppf "val %s : %a@." id EmlType.pp_scheme ts 67 | | _ -> ()) tops 68 | in 69 | begin 70 | try 71 | let lexbuf = Lexing.from_string in_code in 72 | EmlCompile.run 73 | ~loader ~hook_typing ~header:(make_header embed) input_fname lexbuf 74 | |> List.iter (fprintf bf_out.ppf "%a@\n@\n" EmlCpp.pp_decl); 75 | let tyinf = fetch_buffer_formatter bf_tys |> String.trim in 76 | let out_code = fetch_buffer_formatter bf_out |> String.trim in 77 | Unsafe.fun_call (Unsafe.js_expr "showResult") 78 | [| Unsafe.inject (string tyinf); 79 | Unsafe.inject (string out_code); |] 80 | with 81 | | Compile_error ({ EmlLocation.loc; EmlLocation.data; }) -> 82 | report_error loc data 83 | end 84 | 85 | let switch_example code () = 86 | editor_set "mlEditor" code 87 | 88 | let () = 89 | let set_onclick id f = 90 | let handler _ = f () ; bool true in 91 | let btn = getElementById id in 92 | ignore (addEventListener btn Event.click (Dom.handler handler) (bool false)) 93 | in 94 | set_onclick "btn_compile" compile; 95 | set_onclick "btn_ex_fib" 96 | (switch_example [%blob "../examples/fib/fib.ml"]); 97 | set_onclick "btn_ex_qsort" 98 | (switch_example [%blob "../examples/quicksort/qsort.ml"]); 99 | set_onclick "btn_ex_tsort" 100 | (switch_example [%blob "../examples/topological_sort/tsort.ml"]); 101 | set_onclick "btn_ex_dijkstra" 102 | (switch_example [%blob "../examples/dijkstra/dijkstra.ml"]); 103 | set_onclick "btn_ex_base64" 104 | (switch_example [%blob "../examples/base64/base64.ml"]) 105 | -------------------------------------------------------------------------------- /test/base64.ml: -------------------------------------------------------------------------------- 1 | #use "list.ml" 2 | 3 | let table = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" 4 | 5 | let base64 cs = 6 | let rec aux n1 b1 cs = match cs with 7 | | [] -> if n1 = 0 then [] else [b1 lsl (6 - n1)] 8 | | c1 :: cs -> 9 | let c2 = ((b1 lsl 8) lor c1) lsr (n1 + 2) in 10 | let b2 = c1 land (0xff lsr (6 - n1)) in 11 | if n1 = 4 then c2 :: b2 :: aux 0 0 cs else c2 :: aux (n1+2) b2 cs 12 | in 13 | list_map (list_nth table) (aux 0 0 (list_map int_of_char cs)) 14 | 15 | let str = base64 "Compile-time BASE64 encoding!" 16 | let len = list_length str 17 | 18 | (*! 19 | #include 20 | #include 21 | 22 | int main (void) { 23 | char buf[len::val + 1]; 24 | __ml_array_of_list::set(buf); 25 | assert(std::strcmp(buf, "Q29tcGlsZS10aW1lIEJBU0U2NCBlbmNvZGluZyE") == 0); 26 | return 0; 27 | } 28 | *) 29 | -------------------------------------------------------------------------------- /test/dijkstra.ml: -------------------------------------------------------------------------------- 1 | #use "list.ml" 2 | 3 | let list_insert f xs x = 4 | let y = f x in 5 | let rec aux xs = match xs with 6 | | [] -> [x] 7 | | hd :: tl -> if f hd < y then hd :: (aux tl) else x :: xs 8 | in 9 | aux xs 10 | 11 | let remove_worse_paths ps = 12 | let eq x y = match (x, y) with ((vx, _, _), (vy, _, _)) -> vx = vy in 13 | let rec aux ps = match ps with 14 | | [] -> [] 15 | | x :: ps -> match list_partition (eq x) ps with (_, ps) -> x :: aux ps 16 | in 17 | aux ps 18 | 19 | let walk graph ps = 20 | let cost p = match p with (v, path, c) -> c in 21 | let mk_path p x = match (p, x) with 22 | | ((v, path, cp), (v1, v2, ce)) -> 23 | if v = v1 then Some (v2, v1 :: path, cp + ce) else None 24 | in 25 | match ps with 26 | | [] -> error 27 | | p :: ps1 -> 28 | let ps2 = list_filter_map (mk_path p) graph in 29 | let ps = list_foldl (list_insert cost) ps1 ps2 in 30 | remove_worse_paths ps 31 | 32 | let dijkstra graph goal start = 33 | let is_goal x = match x with (v, _, _) -> v = goal in 34 | let rec aux ps = 35 | match list_find is_goal ps with 36 | | Some p -> p 37 | | None -> aux (walk graph ps) 38 | in 39 | match aux [(start, [], 0)] with (v, p, c) -> (list_rev (v :: p), c) 40 | 41 | let graph = [ (1, 2, 7); (* (vertex_begin, vertex_end, cost) *) 42 | (1, 3, 9); 43 | (1, 5, 14); 44 | (2, 3, 10); 45 | (2, 4, 15); 46 | (3, 4, 11); 47 | (3, 5, 2); 48 | (4, 6, 6); 49 | (5, 6, 9) ] 50 | 51 | let fst x = match x with (y, _) -> y 52 | let snd x = match x with (_, y) -> y 53 | 54 | (* the shortest path = 1 -> 3 -> 5 -> 6 (its cost = 20) *) 55 | let res = dijkstra graph 6 1 56 | let path = fst res 57 | let cost = snd res 58 | let v0 = list_nth path 0 59 | let v1 = list_nth path 1 60 | let v2 = list_nth path 2 61 | let v3 = list_nth path 3 62 | 63 | (*! 64 | // This is C++ code. 65 | 66 | #include 67 | 68 | int main () { 69 | assert(cost::val == 20); 70 | assert(v0::val == 1); 71 | assert(v1::val == 3); 72 | assert(v2::val == 5); 73 | assert(v3::val == 6); 74 | return 0; 75 | } 76 | *) 77 | -------------------------------------------------------------------------------- /test/fib.ml: -------------------------------------------------------------------------------- 1 | let rec fib n = match n with 2 | | 0 -> 0 3 | | 1 -> 1 4 | | n -> fib (n-1) + fib (n-2) 5 | 6 | let x1 = fib 1 7 | let x2 = fib 2 8 | let x3 = fib 3 9 | let x4 = fib 4 10 | let x5 = fib 5 11 | let x6 = fib 6 12 | let x7 = fib 7 13 | let x8 = fib 8 14 | let x9 = fib 9 15 | 16 | (*! 17 | // This is C++ code. 18 | 19 | #include 20 | 21 | int main () { // We use printf in order to output readable assembly code. 22 | // check the unsorted list 23 | assert(x1::val == 1); 24 | assert(x2::val == 1); 25 | assert(x3::val == 2); 26 | assert(x4::val == 3); 27 | assert(x5::val == 5); 28 | assert(x6::val == 8); 29 | assert(x7::val == 13); 30 | assert(x8::val == 21); 31 | assert(x9::val == 34); 32 | return 0; 33 | } 34 | *) 35 | -------------------------------------------------------------------------------- /test/qsort.ml: -------------------------------------------------------------------------------- 1 | #use "list.ml" 2 | 3 | let rec qsort xs = match xs with 4 | | [] -> [] 5 | | [x] -> [x] 6 | | pivot :: rest -> 7 | match list_partition (fun x -> x < pivot) rest with 8 | | (ys, zs) -> list_append (qsort ys) (pivot :: qsort zs) 9 | 10 | let xs = [5; 4; 8; 1; 6; 3; 7; 2] 11 | let x0 = list_nth xs 0 12 | let x1 = list_nth xs 1 13 | let x2 = list_nth xs 2 14 | let x3 = list_nth xs 3 15 | let x4 = list_nth xs 4 16 | let x5 = list_nth xs 5 17 | let x6 = list_nth xs 6 18 | let x7 = list_nth xs 7 19 | let ys = qsort xs 20 | let y0 = list_nth ys 0 21 | let y1 = list_nth ys 1 22 | let y2 = list_nth ys 2 23 | let y3 = list_nth ys 3 24 | let y4 = list_nth ys 4 25 | let y5 = list_nth ys 5 26 | let y6 = list_nth ys 6 27 | let y7 = list_nth ys 7 28 | 29 | (*! 30 | // This is C++ code. 31 | 32 | #include 33 | 34 | int main () { // We use printf in order to output readable assembly code. 35 | // check the unsorted list 36 | assert(x0::val == 5); 37 | assert(x1::val == 4); 38 | assert(x2::val == 8); 39 | assert(x3::val == 1); 40 | assert(x4::val == 6); 41 | assert(x5::val == 3); 42 | assert(x6::val == 7); 43 | assert(x7::val == 2); 44 | // check the sorted list 45 | assert(y0::val == 1); 46 | assert(y1::val == 2); 47 | assert(y2::val == 3); 48 | assert(y3::val == 4); 49 | assert(y4::val == 5); 50 | assert(y5::val == 6); 51 | assert(y6::val == 7); 52 | assert(y7::val == 8); 53 | return 0; 54 | } 55 | *) 56 | -------------------------------------------------------------------------------- /test/test.sh: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | set -eu 4 | #EVILML="../evilml.native -I ../include --header evilml.hpp --embed --verbose" 5 | EVILML="../evilml.native -I ../include --header ../include/evilml.hpp --embed --verbose" 6 | 7 | export OCAMLRUNPARAM=b 8 | 9 | echo "Checking fib.ml ..." 10 | $EVILML fib.ml 11 | g++ fib.cpp -o fib.out 12 | ./fib.out 13 | 14 | echo "Checking qsort.ml ..." 15 | $EVILML qsort.ml 16 | g++ qsort.cpp -o qsort.out 17 | ./qsort.out 18 | 19 | echo "Checking dijkstra.ml ..." 20 | $EVILML dijkstra.ml 21 | g++ dijkstra.cpp -o dijkstra.out 22 | ./dijkstra.out 23 | 24 | echo "Checking tsort.ml ..." 25 | $EVILML tsort.ml 26 | g++ tsort.cpp -o tsort.out 27 | ./tsort.out 28 | 29 | echo "Checking base64.ml ..." 30 | $EVILML base64.ml 31 | g++ base64.cpp -o base64.out 32 | ./base64.out 33 | -------------------------------------------------------------------------------- /test/tsort.ml: -------------------------------------------------------------------------------- 1 | #use "list.ml" 2 | 3 | let tsort vs es = 4 | let is_leaf es v = 5 | list_for_all (fun e -> match e with (_, v2) -> v <> v2) es 6 | in 7 | let partition_leaves vs es = 8 | list_partition (fun e -> match e with (v, _) -> list_mem v vs) es 9 | in 10 | let rec aux acc vs es = 11 | match list_partition (is_leaf es) vs with 12 | | (vs1, []) -> list_flatten (list_rev (vs1 :: acc)) 13 | | (vs1, vs2) -> 14 | match partition_leaves vs1 es with (_, es2) -> aux (vs1 :: acc) vs2 es2 15 | in 16 | aux [] vs es 17 | 18 | (* +----> [2] --> [5] <-- [7] 19 | | ^ ^ 20 | | | | 21 | [1] <-- [3] -----+ | 22 | ^ ^ | 23 | | | | 24 | +----- [4] <---------- [6] *) 25 | let vertices = [1; 2; 3; 4; 5; 6; 7] 26 | let edges = [ (1, 2); (* (vertex_begin, vertex_end) *) 27 | (2, 5); 28 | (3, 1); 29 | (3, 5); 30 | (4, 1); 31 | (4, 3); 32 | (6, 4); 33 | (6, 7); 34 | (7, 5) ] 35 | 36 | (* Result: 6, 4, 7, 3, 1, 2, 5 *) 37 | let xs = tsort vertices edges 38 | let x0 = list_nth xs 0 39 | let x1 = list_nth xs 1 40 | let x2 = list_nth xs 2 41 | let x3 = list_nth xs 3 42 | let x4 = list_nth xs 4 43 | let x5 = list_nth xs 5 44 | let x6 = list_nth xs 6 45 | 46 | (*! 47 | // This is C++ code. 48 | 49 | #include 50 | 51 | int main () { // We use printf in order to output readable assembly code. 52 | assert(x0::val == 6); 53 | assert(x1::val == 4); 54 | assert(x2::val == 7); 55 | assert(x3::val == 3); 56 | assert(x4::val == 1); 57 | assert(x5::val == 2); 58 | assert(x6::val == 5); 59 | return 0; 60 | } 61 | *) 62 | --------------------------------------------------------------------------------