├── final.opam ├── .ocamlformat ├── dune-project ├── libs ├── c │ ├── dune │ └── ast.ml └── javascript │ ├── dune │ ├── lexer.mll │ ├── parser.mly │ └── ast.ml ├── bin ├── dune ├── main.ml ├── js_typecheck.ml └── js_compile.ml ├── test ├── object.js ├── polymorphic_types.js ├── object_nested.js ├── function_fibonacci.js ├── decl.js ├── control_flow.js ├── print.js ├── closure_adder.js ├── polymorphic_closure_adder.js ├── function_square.js ├── binop_comparison.js └── binop_precedence.js ├── .gitattributes ├── README.md ├── .gitignore ├── LICENSE └── test.py /final.opam: -------------------------------------------------------------------------------- 1 | -------------------------------------------------------------------------------- /.ocamlformat: -------------------------------------------------------------------------------- 1 | profile = default 2 | version = 0.26.1 3 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 3.13) 2 | (using menhir 3.0) 3 | -------------------------------------------------------------------------------- /libs/c/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name c) 3 | (modules ast)) 4 | -------------------------------------------------------------------------------- /bin/dune: -------------------------------------------------------------------------------- 1 | (executable 2 | (name main) 3 | (libraries c javascript)) 4 | -------------------------------------------------------------------------------- /test/object.js: -------------------------------------------------------------------------------- 1 | const x = { a: 1, b: 2 }; 2 | console.log(x.a + x.b); 3 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | # Auto detect text files and perform LF normalization 2 | * text=auto 3 | -------------------------------------------------------------------------------- /libs/javascript/dune: -------------------------------------------------------------------------------- 1 | (ocamllex lexer) 2 | (menhir (modules parser)) 3 | 4 | (library 5 | (name javascript) 6 | (modules lexer parser ast)) 7 | -------------------------------------------------------------------------------- /test/polymorphic_types.js: -------------------------------------------------------------------------------- 1 | const id = function id(x) { 2 | return x; 3 | }; 4 | 5 | const a = id(1); 6 | console.log(a); 7 | 8 | const b = id(1 === 1); 9 | console.log(b); 10 | -------------------------------------------------------------------------------- /test/object_nested.js: -------------------------------------------------------------------------------- 1 | const x = { a: 1, b: { c: 2 } }; 2 | console.log(x.a + x.b.c); 3 | 4 | const sum = function sum(x) { 5 | return x.a + x.b.c; 6 | }; 7 | 8 | console.log(sum(x)); 9 | -------------------------------------------------------------------------------- /test/function_fibonacci.js: -------------------------------------------------------------------------------- 1 | const fibonacci = function fibonacci(n) { 2 | if (n < 2) { 3 | return n; 4 | } 5 | return fibonacci(n - 1) + fibonacci(n - 2); 6 | }; 7 | 8 | const num = 36; 9 | console.log(fibonacci(num)); 10 | -------------------------------------------------------------------------------- /test/decl.js: -------------------------------------------------------------------------------- 1 | let a = 1; 2 | console.log(a); 3 | a = 2; 4 | console.log(a); 5 | 6 | let b = function b(x) { 7 | return x * 1; 8 | }; 9 | console.log(b(a)); 10 | b = function b(x) { 11 | return x * 2; 12 | }; 13 | console.log(b(a)); 14 | -------------------------------------------------------------------------------- /test/control_flow.js: -------------------------------------------------------------------------------- 1 | const a = 1; 2 | if (a === 1) { 3 | const b = 2; 4 | console.log(b); 5 | } else { 6 | const c = 3; 7 | console.log(c); 8 | } 9 | 10 | let i = 1; 11 | while (i <= 1024) { 12 | console.log(i); 13 | i = i * 2; 14 | } 15 | -------------------------------------------------------------------------------- /test/print.js: -------------------------------------------------------------------------------- 1 | const a = console.log(0); 2 | console.log(a); 3 | 4 | const b = 1; 5 | console.log(b); 6 | 7 | const c = 1 / 2; 8 | console.log(c); 9 | 10 | const d = 1 / 3; 11 | console.log(d); 12 | 13 | const e = 1 === 1; 14 | console.log(e); 15 | -------------------------------------------------------------------------------- /test/closure_adder.js: -------------------------------------------------------------------------------- 1 | const counter = function counter(initial) { 2 | let count = initial; 3 | return function increment(x) { 4 | count = count + x; 5 | return count; 6 | }; 7 | }; 8 | 9 | const increment = counter(0); 10 | console.log(increment(5)); 11 | console.log(increment(15)); 12 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Komodo 2 | 3 | Komodo is a baby JavaScript type-checker and compiler that supports a small subset of the language. 4 | 5 | ## Get started 6 | 7 | To run the Komodo compiler on a JavaScript file, run `dune exec bin/main.exe `. For example, to compile `test/test.js`, run `dune exec bin/main.exe test/test.js`. 8 | -------------------------------------------------------------------------------- /test/polymorphic_closure_adder.js: -------------------------------------------------------------------------------- 1 | const counter = function (initial) { 2 | let count = initial; 3 | return function (x) { 4 | count = count + x; 5 | return count; 6 | }; 7 | }; 8 | 9 | const increment = counter(0); 10 | const test = function (increment) { 11 | console.log(increment(5)); 12 | console.log(increment(10)); 13 | }; 14 | 15 | test(increment); 16 | -------------------------------------------------------------------------------- /test/function_square.js: -------------------------------------------------------------------------------- 1 | /* a + b */ 2 | const sum = function sum(a, b) { 3 | return a + b; 4 | }; 5 | 6 | /* a * b */ 7 | const product = function product(a, b) { 8 | return a * b; 9 | }; 10 | 11 | /* (a + b)^2 */ 12 | const sumSquare = function sumSquare(a, b) { 13 | const square = function square(x) { 14 | return product(x, x); 15 | }; 16 | return square(a) + product(2, product(a, b)) + square(b); 17 | }; 18 | 19 | console.log(sum(1, 2)); 20 | console.log(product(1, 2)); 21 | console.log(sumSquare(1, 2)); 22 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # SOURCE: https://raw.githubusercontent.com/github/gitignore/main/OCaml.gitignore 2 | 3 | *.annot 4 | *.cmo 5 | *.cma 6 | *.cmi 7 | *.a 8 | *.o 9 | *.cmx 10 | *.cmxs 11 | *.cmxa 12 | 13 | # ocamlbuild working directory 14 | _build/ 15 | 16 | # ocamlbuild targets 17 | *.byte 18 | *.native 19 | 20 | # oasis generated files 21 | setup.data 22 | setup.log 23 | 24 | # Merlin configuring file for Vim and Emacs 25 | .merlin 26 | 27 | # Dune generated files 28 | *.install 29 | 30 | # Local OPAM switch 31 | _opam/ 32 | 33 | # MAC 34 | ._* 35 | .DS_Store 36 | Thumbs.db 37 | 38 | # output folder 39 | out/ 40 | -------------------------------------------------------------------------------- /test/binop_comparison.js: -------------------------------------------------------------------------------- 1 | const a = 1; 2 | const b = 2; 3 | 4 | console.log(a === b); 5 | console.log(a !== b); 6 | console.log(a < b); 7 | console.log(a <= b); 8 | console.log(a > b); 9 | console.log(a >= b); 10 | console.log(a && b); 11 | console.log(a || b); 12 | 13 | const c = 1; 14 | const d = 1; 15 | 16 | console.log(c === d); 17 | console.log(c !== d); 18 | console.log(c < d); 19 | console.log(c <= d); 20 | console.log(c > d); 21 | console.log(c >= d); 22 | console.log(c && d); 23 | console.log(c || d); 24 | 25 | const e = 2; 26 | const f = 1; 27 | 28 | console.log(e === f); 29 | console.log(e !== f); 30 | console.log(e < f); 31 | console.log(e <= f); 32 | console.log(e > f); 33 | console.log(e >= f); 34 | console.log(e && f); 35 | console.log(e || f); 36 | -------------------------------------------------------------------------------- /test/binop_precedence.js: -------------------------------------------------------------------------------- 1 | const a = 16; 2 | const b = 8; 3 | const c = 4; 4 | const d = 2; 5 | const e = 1; 6 | 7 | console.log(a + b - c * d / e); 8 | console.log(a + b - c / d * e); 9 | console.log(a + b * c - d / e); 10 | console.log(a + b * c / d - e); 11 | console.log(a + b / c - d * e); 12 | console.log(a + b / c * d - e); 13 | console.log(a - b + c * d / e); 14 | console.log(a - b + c / d * e); 15 | console.log(a - b * c + d / e); 16 | console.log(a - b * c / d + e); 17 | console.log(a - b / c + d * e); 18 | console.log(a - b / c * d + e); 19 | console.log(a * b + c - d / e); 20 | console.log(a * b + c / d - e); 21 | console.log(a * b - c + d / e); 22 | console.log(a * b - c / d + e); 23 | console.log(a * b / c + d - e); 24 | console.log(a * b / c - d + e); 25 | console.log(a / b + c - d * e); 26 | console.log(a / b + c * d - e); 27 | console.log(a / b - c + d * e); 28 | console.log(a / b - c * d + e); 29 | console.log(a / b * c + d - e); 30 | console.log(a / b * c - d + e); 31 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2024 David Mo 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /bin/main.ml: -------------------------------------------------------------------------------- 1 | type mode = Typecheck | Compile 2 | 3 | let mode_of_string str = if str = "typecheck" then Typecheck else Compile 4 | 5 | let parse_file () : mode * Javascript.Ast.program = 6 | let argv = Sys.argv in 7 | let _ = 8 | if 9 | Array.length argv != 3 10 | || not (argv.(1) = "typecheck" || argv.(1) = "compile") 11 | then ( 12 | prerr_string 13 | ("usage: " ^ argv.(0) ^ " [typecheck | compile] [file-to-parse]\n"); 14 | exit 1) 15 | in 16 | let ch = open_in argv.(2) in 17 | let mode = mode_of_string argv.(1) in 18 | let program = 19 | Javascript.Parser.program Javascript.Lexer.lexer (Lexing.from_channel ch) 20 | in 21 | (mode, program) 22 | 23 | let type_check_prog (p : Javascript.Ast.program) : Javascript.Ast.tipe = 24 | Js_typecheck.type_check_program p 25 | 26 | let compile_prog (p : Javascript.Ast.program) : Js_compile.program = 27 | let _ = type_check_prog p in 28 | Js_compile.compile_program p 29 | 30 | let dump_program (p : Js_compile.program) = 31 | let prog_str = Js_compile.string_of_program p in 32 | print_string prog_str 33 | 34 | let () = 35 | let mode, program = parse_file () in 36 | match mode with 37 | | Typecheck -> ( 38 | try 39 | let _ = type_check_prog program in 40 | print_string (Javascript.Ast.string_of_program program) 41 | with Js_typecheck.TypeError e -> 42 | print_string e; 43 | print_newline ()) 44 | | Compile -> 45 | let c_program = compile_prog program in 46 | dump_program c_program 47 | -------------------------------------------------------------------------------- /libs/javascript/lexer.mll: -------------------------------------------------------------------------------- 1 | { 2 | open Parser 3 | open Lexing 4 | 5 | exception Syntax_error of string 6 | 7 | let incr_lineno lexbuf = 8 | let pos = lexbuf.lex_curr_p in 9 | lexbuf.lex_curr_p <- 10 | { pos with pos_lnum = pos.pos_lnum + 1; pos_bol = pos.pos_cnum } 11 | } 12 | 13 | (* definition section *) 14 | let digit = ['0'-'9'] 15 | let alpha = ['a'-'z' 'A'-'Z'] 16 | 17 | let cr='\013' 18 | let nl='\010' 19 | let eol=(cr nl|nl|cr) 20 | let ws=('\012'|'\t'|' ')* 21 | let int = ('+'|'-')? digit+ 22 | let id = alpha (alpha|digit|'_')* 23 | 24 | (* rules section *) 25 | rule lexer = parse 26 | | "number" { NUMBER_T } 27 | | "boolean" { BOOL_T } 28 | | ';' { SEMI } 29 | | '(' { LPAREN } 30 | | ')' { RPAREN } 31 | | '{' { LBRACE } 32 | | '}' { RBRACE } 33 | | '<' { LANGLE } 34 | | '>' { RANGLE } 35 | | ',' { COMMA } 36 | | '=' { EQUAL } 37 | | ':' { COLON } 38 | | '.' { DOT } 39 | | '+' { PLUS } 40 | | '-' { MINUS } 41 | | '*' { TIMES } 42 | | '/' { DIV } 43 | | '&' { AND } 44 | | '|' { OR } 45 | | '!' { BANG } 46 | | "return" { RETURN } 47 | | "if" { IF } 48 | | "else" { ELSE } 49 | | "while" { WHILE } 50 | | "for" { FOR } 51 | | "let" { LET } 52 | | "const" { CONST } 53 | | "function" { FUNCTION } 54 | | "console.log" { PRINT } 55 | | eol { incr_lineno lexbuf; lexer lexbuf } 56 | | ws+ { lexer lexbuf } 57 | | int { INT (int_of_string(Lexing.lexeme lexbuf)) } 58 | | id { ID (Lexing.lexeme lexbuf) } 59 | | "/*" { comment lexbuf } 60 | | eof { EOF } 61 | | _ { raise (Syntax_error ("Invalid character: " ^ Lexing.lexeme lexbuf)) } 62 | 63 | and comment = parse 64 | | eol { incr_lineno lexbuf; comment lexbuf } 65 | | eof { raise (Syntax_error "Unterminated comment") } 66 | | "*/" { lexer lexbuf } 67 | | _ { comment lexbuf } 68 | -------------------------------------------------------------------------------- /libs/javascript/parser.mly: -------------------------------------------------------------------------------- 1 | %{ 2 | open Ast 3 | 4 | let guess () = ref (Guess_t (ref None)) 5 | %} 6 | 7 | %start program 8 | 9 | /* nonterminals */ 10 | %type program 11 | 12 | /* terminals */ 13 | %token INT 14 | %token ID 15 | %token NUMBER_T BOOL_T 16 | %token SEMI LPAREN RPAREN LBRACE RBRACE LANGLE RANGLE COMMA EQUAL COLON DOT 17 | %token PLUS MINUS TIMES DIV AND OR 18 | %token BANG 19 | %token RETURN IF ELSE WHILE FOR 20 | %token LET CONST 21 | %token FUNCTION 22 | %token PRINT 23 | %token EOF 24 | 25 | %left PLUS MINUS 26 | %left TIMES DIV 27 | %left UNOP 28 | 29 | %% 30 | 31 | program: 32 | stmts EOF { $1 } 33 | 34 | stmt: 35 | exp SEMI { Exp $1 } 36 | | RETURN exp SEMI { Return $2 } 37 | | LBRACE stmts RBRACE { $2 } 38 | | LET ID EQUAL exp SEMI stmts { Decl (Let, $2, $4, $6) } 39 | | IF LPAREN exp RPAREN stmt ELSE stmt { If ($3, $5, $7) } 40 | | IF LPAREN exp RPAREN stmt { If ($3, $5, skip) } 41 | | WHILE LPAREN exp RPAREN stmt { While ($3, $5) } 42 | // | FOR LPAREN exp SEMI exp SEMI exp RPAREN stmt { For ($3, $5, $7, $9) } 43 | | CONST ID EQUAL exp SEMI stmts { Decl (Const, $2, $4, $6) } 44 | 45 | stmts: 46 | stmt { $1 } 47 | | stmt stmts { Seq ($1, $2) } 48 | 49 | param: 50 | ID { $1 } 51 | 52 | params: 53 | param { [$1] } 54 | | param COMMA params { $1::$3 } 55 | 56 | exp: 57 | ID { (Var $1, guess (), $startpos) } 58 | | INT { (Number (float_of_int $1), guess (), $startpos) } 59 | | obj { $1 } 60 | // | exp COMMA exp { ExpSeq($1, $3) } 61 | | unop exp %prec UNOP { (Unop ($1, $2), guess (), $startpos) } 62 | | exp DOT ID { (Unop (ObjProp $3, $1), guess (), $startpos) } 63 | | exp binop exp { (Binop ($2, $1, $3), guess (), $startpos) } 64 | | exp EQUAL exp { (Assign ($1, $3), guess (), $startpos) } 65 | | LPAREN exp RPAREN { $2 } 66 | | FUNCTION ID LPAREN RPAREN LBRACE stmts RBRACE { (Fn { name = $2; args = []; body = $6 }, guess (), $startpos) } 67 | | FUNCTION ID LPAREN params RPAREN LBRACE stmts RBRACE { (Fn { name = $2; args = $4; body = $7 }, guess (), $startpos) } 68 | | exp LPAREN RPAREN { (Call($1, []), guess (), $startpos) } 69 | | exp LPAREN exps RPAREN { (Call($1, $3), guess (), $startpos) } 70 | | print { ($1, guess (), $startpos) } 71 | 72 | obj: 73 | LBRACE RBRACE { (Object [], guess (), $startpos) } 74 | | LBRACE props RBRACE { (Object $2, guess (), $startpos) } 75 | 76 | prop: 77 | ID COLON exp { ($1, $3) } 78 | 79 | props: 80 | prop { [$1] } 81 | | prop COMMA props { $1::$3 } 82 | 83 | exps: 84 | exp { [$1] } 85 | | exp COMMA exps { $1::$3 } 86 | 87 | print: 88 | PRINT LPAREN exp RPAREN { Print $3 } 89 | 90 | %inline unop: 91 | MINUS { UMinus } 92 | | BANG { Not } 93 | 94 | %inline binop: 95 | PLUS { Plus } 96 | | MINUS { Minus } 97 | | TIMES { Times } 98 | | DIV { Div } 99 | | EQUAL EQUAL EQUAL { Eq } 100 | | BANG EQUAL EQUAL { Neq } 101 | | LANGLE { Lt } 102 | | LANGLE EQUAL { Lte } 103 | | RANGLE { Gt } 104 | | RANGLE EQUAL { Gte } 105 | | AND AND { And } 106 | | OR OR { Or } 107 | -------------------------------------------------------------------------------- /test.py: -------------------------------------------------------------------------------- 1 | import os 2 | from pathlib import Path 3 | import sys 4 | import subprocess 5 | import time 6 | 7 | # config 8 | verbose = True 9 | optimizations = True 10 | 11 | 12 | def compile_js(input_file_path, output_file_path): 13 | compile_res = subprocess.run( 14 | ["dune", "exec", "bin/main.exe", "compile", input_file_path], 15 | capture_output=True, 16 | ) 17 | 18 | if compile_res.returncode != 0: 19 | raise Exception("Compiler failed") 20 | 21 | output = compile_res.stdout.decode() 22 | 23 | with open(output_file_path, "w") as f: 24 | f.write(output) 25 | 26 | 27 | def compile_c(input_file_path, output_file_path): 28 | args = ["gcc"] 29 | 30 | if optimizations: 31 | args.append("-O3") 32 | 33 | args.extend([input_file_path, "-o", output_file_path]) 34 | 35 | run_res = subprocess.run(args, capture_output=True) 36 | 37 | if run_res.returncode != 0: 38 | raise Exception(f"GCC failed") 39 | 40 | 41 | def run_compiled(output_file_path): 42 | time_start = time.perf_counter() 43 | run_res = subprocess.run([output_file_path], capture_output=True) 44 | time_end = time.perf_counter() 45 | 46 | if run_res.returncode != 0: 47 | raise Exception("Program failed") 48 | 49 | output = run_res.stdout.decode() 50 | duration = time_end - time_start 51 | return (output, duration) 52 | 53 | 54 | def run_node(js_file_path): 55 | time_start = time.perf_counter() 56 | run_res = subprocess.run(["node", js_file_path], capture_output=True) 57 | time_end = time.perf_counter() 58 | 59 | if run_res.returncode != 0: 60 | raise Exception("Node failed") 61 | 62 | output = run_res.stdout.decode() 63 | duration = time_end - time_start 64 | return (output, duration) 65 | 66 | 67 | def test_js(js_file_path): 68 | print(f"Testing {js_file_path}") 69 | 70 | c_file_path = Path("out/test.c") 71 | c_file_path.parent.mkdir(exist_ok=True, parents=True) 72 | 73 | output_file_path = Path("out/test.out") 74 | output_file_path.parent.mkdir(exist_ok=True, parents=True) 75 | 76 | compile_js(js_file_path, c_file_path) 77 | compile_c(c_file_path, output_file_path) 78 | result = run_compiled(output_file_path) 79 | 80 | expected_result = run_node(js_file_path) 81 | 82 | return (result, expected_result) 83 | 84 | 85 | def main(): 86 | if len(sys.argv) != 2: 87 | print("Usage: python test.py ") 88 | exit(1) 89 | 90 | js_test_file = sys.argv[1] 91 | if not os.path.exists(js_test_file): 92 | print(f"Could not find test file: {js_test_file}") 93 | exit(1) 94 | 95 | (result, expected_result) = test_js(js_test_file) 96 | (output, komodo_duration) = result 97 | (expected_output, node_duration) = expected_result 98 | 99 | if output == expected_output: 100 | print(f"[✓] Test passed: {js_test_file}") 101 | if verbose: 102 | print(f"Time (Komodo): {komodo_duration * 1000:.1f}ms") 103 | print(f"Time (Node): {node_duration * 1000:.1f}ms") 104 | print(f"Output:\n{output}") 105 | else: 106 | print(f"[✗] Test failed: {js_test_file}") 107 | print(f"Output:\n{output}") 108 | print(f"Expected output:\n{expected_output}") 109 | 110 | 111 | if __name__ == "__main__": 112 | main() 113 | -------------------------------------------------------------------------------- /libs/c/ast.ml: -------------------------------------------------------------------------------- 1 | type typ = string 2 | type var = string 3 | type def = typ * var 4 | 5 | type binop = 6 | | Plus 7 | | Minus 8 | | Times 9 | | Div 10 | | Eq 11 | | Neq 12 | | Lt 13 | | Lte 14 | | Gt 15 | | Gte 16 | | And 17 | | Or 18 | | Arrow 19 | | Dot 20 | 21 | type unop = Not | Deref | AddrOf | Cast of typ 22 | 23 | type exp = 24 | | Int of int 25 | | Double of float 26 | | String of string 27 | | Var of var 28 | | ExpSeq of exp * exp 29 | | Binop of binop * exp * exp 30 | | Unop of unop * exp 31 | | If of exp * exp * exp 32 | | Assign of exp * exp 33 | | Call of exp * exp list 34 | 35 | type stmt = 36 | | Exp of exp 37 | | Seq of stmt * stmt 38 | | If of exp * stmt * stmt 39 | | While of exp * stmt 40 | | For of exp * exp * exp * stmt 41 | | Return of exp option 42 | | Decl of def * exp option * stmt 43 | 44 | type funcsig = { def : def; args : def list; body : stmt } 45 | type func = Fn of funcsig 46 | 47 | let skip : stmt = Exp (Int 0) (* simulate a skip statement *) 48 | 49 | type program = func list 50 | 51 | let string_of_def ((t, x) : def) : string = t ^ " " ^ x 52 | 53 | let string_of_binop (b : binop) : string = 54 | match b with 55 | | Plus -> " + " 56 | | Minus -> " - " 57 | | Times -> " * " 58 | | Div -> " / " 59 | | Eq -> " == " 60 | | Neq -> " != " 61 | | Lt -> " < " 62 | | Lte -> " <= " 63 | | Gt -> " > " 64 | | Gte -> " >= " 65 | | And -> " && " 66 | | Or -> " || " 67 | | Arrow -> "->" 68 | | Dot -> "." 69 | 70 | let string_of_unop (u : unop) : string = 71 | match u with 72 | | Not -> "!" 73 | | Deref -> "*" 74 | | AddrOf -> "&" 75 | | Cast t -> "(" ^ t ^ ") " 76 | 77 | let rec string_of_exp (e : exp) : string = 78 | match e with 79 | | Int i -> string_of_int i 80 | | Double f -> string_of_float f 81 | | String s -> "\"" ^ s ^ "\"" 82 | | Var x -> x 83 | | ExpSeq (e1, e2) -> string_of_exp e1 ^ ", " ^ string_of_exp e2 84 | | Binop (op, e1, e2) -> 85 | "(" ^ string_of_exp e1 ^ string_of_binop op ^ string_of_exp e2 ^ ")" 86 | | Unop (op, e) -> "(" ^ string_of_unop op ^ string_of_exp e ^ ")" 87 | | If (e1, e2, e3) -> 88 | "(" ^ string_of_exp e1 ^ " ? " ^ string_of_exp e2 ^ " : " 89 | ^ string_of_exp e3 ^ ")" 90 | | Assign (x, e) -> string_of_exp x ^ " = " ^ string_of_exp e 91 | | Call (e, es) -> string_of_exp e ^ "(" ^ string_of_exps es ^ ")" 92 | 93 | and string_of_exps (es : exp list) = 94 | String.concat ", " (List.map string_of_exp es) 95 | 96 | let rec string_of_stmt (s : stmt) (level : int) : string = 97 | let tabs = String.make (level * 4) ' ' in 98 | match s with 99 | | Exp e -> tabs ^ string_of_exp e ^ ";\n" 100 | | Seq (e1, e2) -> string_of_stmt e1 level ^ string_of_stmt e2 level 101 | | If (e, s1, s2) -> 102 | tabs ^ "if (" ^ string_of_exp e ^ ") {\n" 103 | ^ string_of_stmt s1 (level + 1) 104 | ^ tabs ^ "}\n" ^ tabs ^ "else {\n" 105 | ^ string_of_stmt s2 (level + 1) 106 | ^ tabs ^ "}\n" 107 | | While (e, s) -> 108 | tabs ^ "while (" ^ string_of_exp e ^ ") {\n" 109 | ^ string_of_stmt s (level + 1) 110 | ^ tabs ^ "}\n" 111 | | For (e1, e2, e3, s) -> 112 | tabs ^ "for (" ^ string_of_exp e1 ^ "; " ^ string_of_exp e2 ^ "; " 113 | ^ string_of_exp e3 ^ ") {\n" 114 | ^ string_of_stmt s (level + 1) 115 | ^ tabs ^ "}\n" 116 | | Return e -> ( 117 | match e with 118 | | Some e -> tabs ^ "return " ^ string_of_exp e ^ ";\n" 119 | | None -> tabs ^ "return;\n") 120 | | Decl (d, e, s) -> 121 | let v = match e with Some e -> " = " ^ string_of_exp e | None -> "" in 122 | tabs ^ string_of_def d ^ v ^ ";\n" ^ string_of_stmt s level 123 | 124 | let string_of_func (fn : func) : string = 125 | let (Fn f) = fn in 126 | string_of_def f.def ^ "(" 127 | ^ String.concat ", " (List.map (fun d -> string_of_def d) f.args) 128 | ^ ") {\n" ^ string_of_stmt f.body 1 ^ "}\n" 129 | 130 | let string_of_program (p : program) : string = 131 | String.concat "\n" (List.map string_of_func p) 132 | -------------------------------------------------------------------------------- /libs/javascript/ast.ml: -------------------------------------------------------------------------------- 1 | type var = string 2 | type tvar = string 3 | type mut = Let | Const 4 | type pos = Lexing.position 5 | 6 | type tipe = 7 | | Number_t 8 | | Object_t of (var * tipe) list 9 | | Bool_t 10 | | Unit_t 11 | | Tvar_t of tvar 12 | | Fn_t of tipe list * tipe 13 | | Guess_t of tipe option ref 14 | 15 | type tipe_scheme = Forall of tvar list * tipe 16 | 17 | type binop = 18 | | Plus 19 | | Minus 20 | | Times 21 | | Div 22 | | Eq 23 | | Neq 24 | | Lt 25 | | Lte 26 | | Gt 27 | | Gte 28 | | And 29 | | Or 30 | 31 | type unop = UMinus | Not | ObjProp of var 32 | 33 | type funcsig = { name : var; args : var list; body : stmt } 34 | 35 | and rexp = 36 | | Number of float 37 | | Object of (var * exp) list 38 | | Var of var 39 | | ExpSeq of exp * exp 40 | | Binop of binop * exp * exp 41 | | Unop of unop * exp 42 | | Assign of exp * exp 43 | | Fn of funcsig 44 | | Call of exp * exp list 45 | | Print of exp 46 | 47 | and exp = rexp * tipe ref * pos 48 | 49 | and stmt = 50 | | Exp of exp 51 | | Seq of stmt * stmt 52 | | If of exp * stmt * stmt 53 | | While of exp * stmt 54 | | For of exp * exp * exp * stmt 55 | | Return of exp 56 | | Decl of mut * var * exp * stmt 57 | 58 | (* simulate a skip statement *) 59 | let skip : stmt = Exp (Number 0., ref Number_t, Lexing.dummy_pos) 60 | 61 | type program = stmt 62 | 63 | let tvar_counter = ref 0 64 | 65 | let fresh_tvar () : string = 66 | let curr_counter = !tvar_counter in 67 | tvar_counter := curr_counter + 1; 68 | "ptvar" ^ string_of_int curr_counter 69 | 70 | type env = (tipe option ref * tipe) list 71 | 72 | let env : env ref = ref [] 73 | 74 | let lookup (tr : tipe option ref) : tipe = 75 | let rec helper (env' : env) (r : tipe option ref) : tipe = 76 | match env' with 77 | | [] -> 78 | let v = Tvar_t (fresh_tvar ()) in 79 | env := (r, v) :: !env; 80 | v 81 | | (r', t) :: tl -> if r' == r then t else helper tl r 82 | in 83 | helper !env tr 84 | 85 | let string_of_pos (pos : pos) = 86 | "Line " ^ string_of_int pos.pos_lnum ^ ", character " 87 | ^ string_of_int (pos.pos_cnum - pos.pos_bol + 1) 88 | 89 | let rec string_of_tipe (t : tipe) : string = 90 | match t with 91 | | Number_t -> "number" 92 | | Object_t ps -> 93 | let ps_str = 94 | String.concat " " 95 | (List.map (fun (x, t) -> x ^ ": " ^ string_of_tipe t ^ ";") ps) 96 | in 97 | "{ " ^ ps_str ^ " }" 98 | | Bool_t -> "boolean" 99 | | Unit_t -> "void" 100 | | Tvar_t tvar -> "'" ^ tvar 101 | | Fn_t (ts, tret) -> 102 | "(" 103 | ^ String.concat ", " (List.map string_of_tipe ts) 104 | ^ ") => (" ^ string_of_tipe tret ^ ")" 105 | | Guess_t tr -> ( 106 | match !tr with 107 | | Some t -> string_of_tipe t 108 | | None -> string_of_tipe (lookup tr)) 109 | 110 | let string_of_binop (op : binop) : string = 111 | match op with 112 | | Plus -> "+" 113 | | Minus -> "-" 114 | | Times -> "*" 115 | | Div -> "/" 116 | | Eq -> "===" 117 | | Neq -> "!==" 118 | | Lt -> "<" 119 | | Lte -> "<=" 120 | | Gt -> ">" 121 | | Gte -> ">=" 122 | | And -> "&&" 123 | | Or -> "||" 124 | 125 | let string_of_unop (op : unop) : string = 126 | match op with UMinus -> "-" | Not -> "!" | ObjProp prop -> "." ^ prop 127 | 128 | let string_of_mut (m : mut) : string = 129 | match m with Let -> "let" | Const -> "const" 130 | 131 | let rec string_of_exp ((e, _, _) : exp) (level : int) : string = 132 | match e with 133 | | Number n -> string_of_float n 134 | | Object ps -> 135 | let tabs = String.make (level * 2) ' ' in 136 | let p_tabs = String.make ((level + 1) * 2) ' ' in 137 | let ps_str = 138 | String.concat "\n" 139 | (List.map 140 | (fun (x, e) -> 141 | p_tabs ^ x ^ ": " ^ string_of_exp e (level + 1) ^ ";") 142 | ps) 143 | in 144 | "{\n" ^ ps_str ^ "\n" ^ tabs ^ "}" 145 | | Var x -> x 146 | | ExpSeq (e1, e2) -> string_of_exp e1 level ^ ", " ^ string_of_exp e2 level 147 | | Binop (op, e1, e2) -> 148 | "(" ^ string_of_exp e1 level ^ " " ^ string_of_binop op ^ " " 149 | ^ string_of_exp e2 level ^ ")" 150 | | Unop (op, e) -> ( 151 | match op with 152 | | ObjProp _ -> string_of_exp e level ^ string_of_unop op 153 | | _ -> string_of_unop op ^ string_of_exp e level) 154 | | Assign (x, e) -> string_of_exp x level ^ " = " ^ string_of_exp e level 155 | | Fn f -> 156 | let tabs = String.make (level * 2) ' ' in 157 | let args = String.concat ", " f.args in 158 | "function" ^ f.name ^ "(" ^ args ^ ") {\n" 159 | ^ string_of_stmt f.body (level + 1) 160 | ^ tabs ^ "}" 161 | | Call (e, es) -> 162 | let args = 163 | String.concat ", " (List.map (fun e' -> string_of_exp e' level) es) 164 | in 165 | string_of_exp e level ^ "(" ^ args ^ ")" 166 | | Print e -> "console.log(" ^ string_of_exp e level ^ ")" 167 | 168 | and string_of_stmt (s : stmt) (level : int) : string = 169 | let tabs = String.make (level * 2) ' ' in 170 | match s with 171 | | Exp e -> tabs ^ string_of_exp e level ^ ";\n" 172 | | Seq (s1, s2) -> string_of_stmt s1 level ^ string_of_stmt s2 level 173 | | If (e, s1, s2) -> 174 | tabs ^ "if (" ^ string_of_exp e level ^ ") {\n" 175 | ^ string_of_stmt s1 (level + 1) 176 | ^ tabs ^ "}\n" ^ tabs ^ "else {\n" 177 | ^ string_of_stmt s2 (level + 1) 178 | ^ tabs ^ "}\n" 179 | | While (e, s) -> 180 | tabs ^ "while (" ^ string_of_exp e level ^ ") {\n" 181 | ^ string_of_stmt s (level + 1) 182 | ^ tabs ^ "}\n" 183 | | For (e1, e2, e3, s) -> 184 | tabs ^ "for (" ^ string_of_exp e1 level ^ "; " ^ string_of_exp e2 level 185 | ^ "; " ^ string_of_exp e3 level ^ ") {\n" 186 | ^ string_of_stmt s (level + 1) 187 | ^ tabs ^ "}\n" 188 | | Return e -> tabs ^ "return " ^ string_of_exp e level ^ ";\n" 189 | | Decl (m, x, e, s) -> 190 | let _, tr, _ = e in 191 | let tx = ": " ^ string_of_tipe !tr in 192 | tabs ^ string_of_mut m ^ " " ^ x ^ tx ^ " = " ^ string_of_exp e level 193 | ^ ";\n" ^ string_of_stmt s level 194 | 195 | let string_of_program (p : program) : string = string_of_stmt p 0 196 | -------------------------------------------------------------------------------- /bin/js_typecheck.ml: -------------------------------------------------------------------------------- 1 | open Javascript.Ast 2 | 3 | exception TypeError of string 4 | 5 | let type_error (s : string) ((_, _, pos) : exp) = 6 | raise (TypeError (string_of_pos pos ^ ":\nError: " ^ s)) 7 | 8 | let minus (lst1 : 'a list) (lst2 : 'a list) : 'a list = 9 | List.filter (fun x -> not (List.memq x lst2)) lst1 10 | 11 | let union (lst1 : 'a list) (lst2 : 'a list) : 'a list = lst1 @ minus lst2 lst1 12 | let guess () = Guess_t (ref None) 13 | 14 | type env = (var * tipe_scheme) list 15 | 16 | let extend (env : env) (x : var) (s : tipe_scheme) : env = (x, s) :: env 17 | 18 | let rec lookup (env : env) (x : var) : tipe_scheme option = 19 | match env with 20 | | [] -> None 21 | | (x', s) :: tl -> if x = x' then Some s else lookup tl x 22 | 23 | let var_counter = ref 0 24 | 25 | let fresh_var () : var = 26 | let curr_counter = !var_counter in 27 | var_counter := curr_counter + 1; 28 | "v" ^ string_of_int curr_counter 29 | 30 | (* returns whether the reference `tr` already occurs in type `t` *) 31 | let rec occurs (tr : tipe option ref) (t : tipe) : bool = 32 | match t with 33 | | Number_t | Bool_t | Unit_t | Tvar_t _ -> false 34 | | Object_t ps -> List.exists (fun (_, t') -> occurs tr t') ps 35 | | Fn_t (ts, tret) -> List.exists (occurs tr) ts || occurs tr tret 36 | | Guess_t tr' -> ( 37 | if tr == tr' then true 38 | else match !tr' with Some t' -> occurs tr t' | None -> false) 39 | 40 | (* returns whether `t1` and `t2` are equal *) 41 | let rec tipes_equal (t1 : tipe) (t2 : tipe) : bool = 42 | match (t1, t2) with 43 | | Number_t, Number_t | Bool_t, Bool_t | Unit_t, Unit_t | Tvar_t _, Tvar_t _ -> 44 | t1 = t2 45 | | Fn_t (ts1, tret1), Fn_t (ts2, tret2) -> 46 | List.length ts1 = List.length ts2 47 | && List.for_all2 tipes_equal ts1 ts2 48 | && tipes_equal tret1 tret2 49 | | Guess_t tr1, Guess_t tr2 -> ( 50 | match (!tr1, !tr2) with 51 | | Some t1', Some t2' -> tipes_equal t1' t2' 52 | | Some t1', None -> occurs tr1 t1' 53 | | None, Some t2' -> occurs tr2 t2' 54 | | None, None -> tr1 == tr2) 55 | | Guess_t tr1, t2 -> ( 56 | match !tr1 with Some t1' -> tipes_equal t1' t2 | None -> false) 57 | | t1, Guess_t _ -> tipes_equal t2 t1 58 | | _ -> false 59 | 60 | (* tries to unify `t1` can be unified with `t2` and returns whether it succeeded *) 61 | let rec unify (t1 : tipe) (t2 : tipe) : bool = 62 | if tipes_equal t1 t2 then true 63 | else 64 | match (t1, t2) with 65 | | Fn_t (ts1, tret1), Fn_t (ts2, tret2) -> 66 | List.length ts1 = List.length ts2 67 | && List.for_all2 unify ts1 ts2 68 | && unify tret1 tret2 69 | | Guess_t tr1, t2 -> ( 70 | match !tr1 with 71 | | Some t1' -> unify t1' t2 72 | | None -> 73 | if occurs tr1 t2 then 74 | raise 75 | (TypeError 76 | ("The type variable " ^ string_of_tipe t1 ^ " occurs inside " 77 | ^ string_of_tipe t2)) 78 | else ( 79 | tr1 := Some t2; 80 | true)) 81 | | t1, Guess_t _ -> unify t2 t1 82 | | _ -> false 83 | 84 | (* substitutes all type variables in `t` with corresponding type variables in `vs` *) 85 | let rec substitute (vs : (tvar * tipe) list) (t : tipe) : tipe = 86 | match t with 87 | | Number_t | Bool_t | Unit_t -> t 88 | | Object_t ps -> Object_t (List.map (fun (x, t') -> (x, substitute vs t')) ps) 89 | | Tvar_t tvar -> 90 | let _, t' = List.find (fun (tvar', _) -> tvar == tvar') vs in 91 | t' 92 | | Fn_t (ts, tret) -> Fn_t (List.map (substitute vs) ts, substitute vs tret) 93 | | Guess_t tr -> ( 94 | match !tr with 95 | | Some t' -> 96 | let t'' = substitute vs t' in 97 | Guess_t (ref (Some t'')) 98 | | None -> t) 99 | 100 | (* takes a type scheme `s` and returns its type representation *) 101 | let instantiate (s : tipe_scheme) : tipe = 102 | match s with 103 | | Forall (vs, t) -> 104 | let b = List.map (fun a -> (a, guess ())) vs in 105 | substitute b t 106 | 107 | (* returns all the guesses in a type *) 108 | let rec guesses_of_tipe (t : tipe) : tipe list = 109 | match t with 110 | | Number_t | Bool_t | Unit_t | Tvar_t _ -> [] 111 | | Object_t ps -> 112 | List.fold_left union [] (List.map (fun (_, t') -> guesses_of_tipe t') ps) 113 | | Fn_t (ts, tret) -> 114 | let ts_guesses = List.fold_left union [] (List.map guesses_of_tipe ts) in 115 | let tret_guesses = guesses_of_tipe tret in 116 | union ts_guesses tret_guesses 117 | | Guess_t tr -> ( 118 | match !tr with Some t' -> guesses_of_tipe t' | None -> [ t ]) 119 | 120 | (* returns all the guesses in a type scheme *) 121 | let guesses_of (s : tipe_scheme) : tipe list = 122 | match s with Forall (_, t) -> guesses_of_tipe t 123 | 124 | (* substitutes all guesses in `t` with their corresponding type variables *) 125 | let rec subst_guesses (gs_vs : (tipe * tvar) list) (t : tipe) : tipe = 126 | match t with 127 | | Number_t | Bool_t | Unit_t | Tvar_t _ -> t 128 | | Object_t ps -> 129 | Object_t (List.map (fun (x, t') -> (x, subst_guesses gs_vs t')) ps) 130 | | Fn_t (ts, tret) -> 131 | Fn_t (List.map (subst_guesses gs_vs) ts, subst_guesses gs_vs tret) 132 | | Guess_t tr -> ( 133 | match List.find_opt (fun (t', _) -> t == t') gs_vs with 134 | | Some (_, tvar) -> Tvar_t tvar 135 | | None -> ( 136 | match !tr with 137 | | Some t' -> 138 | let t'' = subst_guesses gs_vs t' in 139 | tr := Some t''; 140 | t 141 | | None -> t)) 142 | 143 | (* takes an environment `env` and a type `t` and returns a type scheme *) 144 | let generalize (env : env) (t : tipe) : tipe_scheme = 145 | let t_gs = guesses_of_tipe t in 146 | let env_list_gs = List.map (fun (_, s) -> guesses_of s) env in 147 | let env_gs = List.fold_left union [] env_list_gs in 148 | let diff = minus t_gs env_gs in 149 | let gs_vs = List.map (fun g -> (g, fresh_var ())) diff in 150 | let tc = subst_guesses gs_vs t in 151 | Forall (List.map snd gs_vs, tc) 152 | 153 | let type_error_string (t1 : tipe) (t2 : tipe) : string = 154 | "This expression has type " ^ string_of_tipe t1 155 | ^ " but an expression was expected of type " ^ string_of_tipe t2 156 | 157 | let rec type_check_exp (env : env) (e : exp) : tipe = 158 | let e', tr, _ = e in 159 | let t = 160 | match e' with 161 | | Number _ -> Number_t 162 | | Object ps -> 163 | let ps_t = List.map (fun (x, e'') -> (x, type_check_exp env e'')) ps in 164 | Object_t ps_t 165 | | Var x -> ( 166 | match lookup env x with 167 | | Some s -> instantiate s 168 | | None -> type_error ("Unbound value " ^ x) e) 169 | | ExpSeq (_, _) -> type_error "TODO" e 170 | | Binop (op, e1, e2) -> ( 171 | let t1 = type_check_exp env e1 in 172 | let t2 = type_check_exp env e2 in 173 | match op with 174 | | Plus | Minus | Times | Div -> 175 | if unify t1 Number_t then 176 | if unify t2 Number_t then Number_t 177 | else type_error (type_error_string t2 Number_t) e2 178 | else type_error (type_error_string t1 Number_t) e1 179 | | Eq | Neq -> 180 | if unify t1 t2 then Bool_t 181 | else type_error (type_error_string t2 t1) e2 182 | | Lt | Lte | Gt | Gte -> 183 | if unify t1 Number_t then 184 | if unify t2 Number_t then Bool_t 185 | else type_error (type_error_string t2 Number_t) e2 186 | else type_error (type_error_string t1 Number_t) e1 187 | | And | Or -> 188 | (* TODO: the resulting type should be `t1 | t2` *) 189 | if unify t1 t2 then t1 else type_error (type_error_string t2 t1) e2) 190 | | Unop (op, e') -> ( 191 | let t = type_check_exp env e' in 192 | match op with 193 | | UMinus -> 194 | if unify t Number_t then Number_t 195 | else type_error (type_error_string t Number_t) e 196 | | Not -> Bool_t 197 | | ObjProp prop -> ( 198 | (* TODO: unify the type instead of matching on it *) 199 | match t with 200 | | Object_t ps -> ( 201 | match List.assoc_opt prop ps with 202 | | Some t -> t 203 | | None -> type_error ("Unknown property " ^ prop) e) 204 | | _ -> type_error "Not an object" e)) 205 | | Assign (e1, e2) -> 206 | let t1 = type_check_exp env e1 in 207 | let t2 = type_check_exp env e2 in 208 | if unify t1 t2 then t1 else type_error (type_error_string t2 t1) e2 209 | | Fn f -> 210 | let ts = List.map (fun _ -> guess ()) f.args in 211 | let env' = 212 | List.fold_left2 213 | (fun env' x t -> extend env' x (Forall ([], t))) 214 | env f.args ts 215 | in 216 | (* TODO: `tb` should be a union of all the returns *) 217 | let g = guess () in 218 | let env' = extend env' f.name (Forall ([], Fn_t (ts, g))) in 219 | let tb = type_check_stmt env' f.body in 220 | if unify g tb then Fn_t (ts, tb) 221 | else type_error (type_error_string g tb) e 222 | | Call (e', es) -> 223 | let t = type_check_exp env e' in 224 | let ts = List.map (type_check_exp env) es in 225 | let g = guess () in 226 | if unify t (Fn_t (ts, g)) then g 227 | else type_error (type_error_string t (Fn_t (ts, g))) e 228 | | Print e' -> 229 | let _ = type_check_exp env e' in 230 | Unit_t 231 | in 232 | tr := t; 233 | !tr 234 | 235 | and type_check_stmt (env : env) (s : stmt) : tipe = 236 | match s with 237 | | Exp e -> type_check_exp env e 238 | | Seq (s1, s2) -> 239 | let _ = type_check_stmt env s1 in 240 | let t2 = type_check_stmt env s2 in 241 | t2 242 | | If (e, s1, s2) -> 243 | let _ = type_check_exp env e in 244 | let t1 = type_check_stmt env s1 in 245 | let t2 = type_check_stmt env s2 in 246 | (* TODO: the resulting type should be `t1 | t2` *) 247 | if unify t1 t2 then t1 else raise (TypeError (type_error_string t2 t1)) 248 | | While (e, s) -> 249 | let _ = type_check_exp env e in 250 | let _ = type_check_stmt env s in 251 | Unit_t 252 | | For (e1, e2, e3, s) -> 253 | let _ = type_check_exp env e1 in 254 | let _ = type_check_exp env e2 in 255 | let _ = type_check_exp env e3 in 256 | let _ = type_check_stmt env s in 257 | Unit_t 258 | | Return e -> type_check_exp env e 259 | | Decl (_, x, e, s) -> 260 | let ts = generalize env (type_check_exp env e) in 261 | type_check_stmt (extend env x ts) s 262 | 263 | let type_check_program (p : program) = type_check_stmt [] p 264 | -------------------------------------------------------------------------------- /bin/js_compile.ml: -------------------------------------------------------------------------------- 1 | module C = C.Ast 2 | module Js = Javascript.Ast 3 | 4 | exception Compile_error of string 5 | 6 | type c_struct = { name : C.var; fields : C.var list } 7 | type program = { structs : (Js.tipe * c_struct) list; body : C.program } 8 | 9 | let program : program ref = ref { structs = []; body = [] } 10 | 11 | (* generate fresh labels *) 12 | let label_counter = ref 0 13 | 14 | let new_int () = 15 | label_counter := !label_counter + 1; 16 | !label_counter 17 | 18 | (* generate a fresh temporary variable *) 19 | let new_temp () = "T" ^ string_of_int (new_int ()) 20 | 21 | (* environment of a closure *) 22 | type env = C.var list 23 | 24 | (* returns the DeBruijn index of a variable *) 25 | let lookup_arg (env : env) (x : C.var) : int = 26 | let rec lookup env' index = 27 | match env' with 28 | | [] -> raise (Compile_error ("Unbound value " ^ x)) 29 | | hd :: tl -> if hd = x then index else lookup tl (index + 1) 30 | in 31 | lookup env 0 32 | 33 | (* returns an expression from a DeBruijn index *) 34 | let get_arg (index : int) : C.exp = 35 | let rec helper index' acc : C.exp = 36 | match index' with 37 | | 0 -> Binop (Dot, Binop (Arrow, acc, Var "value"), Var "var") 38 | | _ -> helper (index' - 1) (Binop (Arrow, acc, Var "next")) 39 | in 40 | helper index (Var "env") 41 | 42 | let malloc (typ : C.typ) : C.exp = 43 | Call (Var "malloc", [ Call (Var "sizeof", [ Var typ ]) ]) 44 | 45 | let free (e : C.exp) : C.stmt = Exp (Call (Var "free", [ e ])) 46 | 47 | (* commonly used expressions *) 48 | let result : C.exp = Var "result" 49 | let result_num : C.exp = Binop (Dot, result, Var "num") 50 | let result_closure_ptr : C.exp = Binop (Dot, result, Var "closurePtr") 51 | let result_var : C.exp = Binop (Dot, result, Var "var") 52 | let result_obj : C.exp = Binop (Dot, result, Var "obj") 53 | let null : C.exp = Var "NULL" 54 | 55 | (* sequence statements together to a single statement *) 56 | let seq_stmts (stmts : C.stmt list) : C.stmt = 57 | match stmts with 58 | | [] -> raise (Compile_error "Empty statements list") 59 | | hd :: tl -> List.fold_left (fun acc stmt -> C.Seq (acc, stmt)) hd tl 60 | 61 | let binop2binop (b : Js.binop) : C.binop = 62 | match b with 63 | | Plus -> Plus 64 | | Minus -> Minus 65 | | Times -> Times 66 | | Div -> Div 67 | | Eq -> Eq 68 | | Neq -> Neq 69 | | Lt -> Lt 70 | | Lte -> Lte 71 | | Gt -> Gt 72 | | Gte -> Gte 73 | | And | Or -> 74 | raise 75 | (Compile_error 76 | "JavaScript && and || have different semantics than C && and ||") 77 | 78 | let unop2unop (u : Js.unop) : C.unop = 79 | match u with 80 | | UMinus -> raise (Compile_error "UMinus is unsupported") 81 | | Not -> Not 82 | | ObjProp _ -> raise (Compile_error "Implemented elsewhere") 83 | 84 | (* replaces all guesses in `t` with their guessed types if they exist *) 85 | let rec flatten_guesses (t : Js.tipe) : Js.tipe = 86 | match t with 87 | | Number_t | Bool_t | Unit_t | Tvar_t _ -> t 88 | | Object_t ps -> Object_t (List.map (fun (x, p) -> (x, flatten_guesses p)) ps) 89 | | Fn_t (ts, tret) -> Fn_t (List.map flatten_guesses ts, flatten_guesses tret) 90 | | Guess_t tr -> ( match !tr with Some t' -> flatten_guesses t' | None -> t) 91 | 92 | let tipe_of ((_, tr, _) : Js.exp) : Js.tipe = flatten_guesses !tr 93 | 94 | let rec exp2stmt (e : Js.exp) (env : env) (left : bool) : C.stmt = 95 | let e', tr, _ = e in 96 | match e' with 97 | | Number n -> Exp (Assign (result_num, Double n)) 98 | | Object ps -> 99 | let c_struct = 100 | match List.assoc_opt !tr !program.structs with 101 | | Some c -> c 102 | | None -> 103 | let c_struct = { name = new_temp (); fields = List.map fst ps } in 104 | program := 105 | { !program with structs = (!tr, c_struct) :: !program.structs }; 106 | c_struct 107 | in 108 | 109 | let t1 = new_temp () in 110 | let malloc_obj : C.stmt = 111 | Exp (Assign (Var t1, malloc ("struct " ^ c_struct.name))) 112 | in 113 | 114 | let assign_props : C.stmt = 115 | List.fold_left 116 | (fun acc (x, e) -> 117 | let v = exp2stmt e env left in 118 | let assign_var : C.stmt = 119 | Exp (Assign (Binop (Arrow, Var t1, Var x), result)) 120 | in 121 | seq_stmts [ acc; v; assign_var ]) 122 | C.skip ps 123 | in 124 | 125 | let store_result : C.stmt = Exp (Assign (result_obj, Var t1)) in 126 | 127 | Decl 128 | ( ("struct " ^ c_struct.name ^ "*", t1), 129 | None, 130 | seq_stmts [ malloc_obj; assign_props; store_result ] ) 131 | | Var x -> 132 | let index = lookup_arg env x in 133 | let var = get_arg index in 134 | if left then Exp (Assign (result_var, var)) 135 | else Exp (Assign (result, Unop (Deref, var))) 136 | | ExpSeq (e1, e2) -> 137 | let s1 = exp2stmt e1 env left in 138 | let s2 = exp2stmt e2 env left in 139 | seq_stmts [ s1; s2 ] 140 | | Binop (op, e1, e2) -> 141 | (* TODO: check types of `e1` and `e2` *) 142 | let t = new_temp () in 143 | let v1 = exp2stmt e1 env left in 144 | let store_v1 : C.stmt = Exp (Assign (Var t, result_num)) in 145 | let v2 = exp2stmt e2 env left in 146 | let store_result : C.stmt = 147 | match op with 148 | | And -> If (Var t, C.skip, Exp (Assign (result_num, Var t))) 149 | | Or -> If (Var t, Exp (Assign (result_num, Var t)), C.skip) 150 | | op -> 151 | Exp (Assign (result_num, Binop (binop2binop op, Var t, result_num))) 152 | in 153 | Decl (("double", t), None, seq_stmts [ v1; store_v1; v2; store_result ]) 154 | | Unop (op, e) -> 155 | let v = exp2stmt e env left in 156 | let store_result : C.stmt = 157 | match op with 158 | | UMinus | Not -> 159 | Exp (Assign (result_num, Unop (unop2unop op, result_num))) 160 | | ObjProp prop -> ( 161 | let _, tr', _ = e in 162 | match List.assoc_opt !tr' !program.structs with 163 | | Some c_struct -> 164 | Exp 165 | (Assign 166 | ( result, 167 | Binop 168 | ( Arrow, 169 | Unop 170 | (Cast ("struct " ^ c_struct.name ^ "*"), result_obj), 171 | Var prop ) )) 172 | | None -> raise (Compile_error "Unknown property")) 173 | in 174 | seq_stmts [ v; store_result ] 175 | | Assign (x, e) -> 176 | let t = new_temp () in 177 | let vx = exp2stmt x env true in 178 | let store_vx : C.stmt = Exp (Assign (Var t, result_var)) in 179 | let ve = exp2stmt e env false in 180 | let assign_var : C.stmt = Exp (Assign (Unop (Deref, Var t), result)) in 181 | Decl 182 | ( ("union Value*", t), 183 | Some null, 184 | seq_stmts [ vx; store_vx; ve; assign_var ] ) 185 | | Fn f -> 186 | let t1 = new_temp () in 187 | let t2 = new_temp () in 188 | let env' = List.fold_right (fun arg env -> arg :: env) f.args env in 189 | let _ = stmt2fun f.body t1 (f.name :: env') in 190 | let malloc_closure : C.stmt = 191 | Exp (Assign (Var t2, malloc "struct Closure")) 192 | in 193 | let store_func : C.stmt = 194 | Exp (Assign (Binop (Arrow, Var t2, Var "func"), Var t1)) 195 | in 196 | let store_env : C.stmt = 197 | Exp (Assign (Binop (Arrow, Var t2, Var "env"), Var "env")) 198 | in 199 | let store_result : C.stmt = Exp (Assign (result_closure_ptr, Var t2)) in 200 | Decl 201 | ( ("struct Closure*", t2), 202 | Some null, 203 | seq_stmts [ malloc_closure; store_func; store_env; store_result ] ) 204 | | Call (e, es) -> 205 | let t1 = new_temp () in 206 | let t2 = new_temp () in 207 | let rec compile_call (args : Js.exp list) (s : C.stmt) : C.stmt = 208 | match args with 209 | | [] -> s 210 | | e' :: tl -> 211 | let t3 = new_temp () in 212 | let t4 = new_temp () in 213 | 214 | let v = exp2stmt e' env left in 215 | let malloc_value : C.stmt = 216 | Exp (Assign (Var t4, malloc "union Value")) 217 | in 218 | let store_result : C.stmt = 219 | Exp (Assign (Unop (Deref, Var t4), result)) 220 | in 221 | 222 | let malloc_var : C.stmt = 223 | Exp (Assign (Var t3, malloc "struct Variable")) 224 | in 225 | let assign_var : C.stmt = 226 | Exp 227 | (Assign 228 | ( Binop (Dot, Binop (Arrow, Var t3, Var "value"), Var "var"), 229 | Var t4 )) 230 | in 231 | let store_next : C.stmt = 232 | Exp (Assign (Binop (Arrow, Var t3, Var "next"), Var t2)) 233 | in 234 | let store_head : C.stmt = Exp (Assign (Var t2, Var t3)) in 235 | 236 | let rest : C.stmt = compile_call tl s in 237 | 238 | Decl 239 | ( ("struct Variable*", t3), 240 | Some null, 241 | Decl 242 | ( ("union Value*", t4), 243 | Some null, 244 | seq_stmts 245 | [ 246 | v; 247 | malloc_value; 248 | store_result; 249 | malloc_var; 250 | assign_var; 251 | store_next; 252 | store_head; 253 | rest; 254 | ] ) ) 255 | in 256 | let v = exp2stmt e env left in 257 | let store_closure : C.stmt = Exp (Assign (Var t1, result_closure_ptr)) in 258 | let save_env : C.stmt = 259 | Exp (Assign (Var t2, Binop (Arrow, Var t1, Var "env"))) 260 | in 261 | let call_exp : C.exp = 262 | Call (Binop (Arrow, Var t1, Var "func"), [ Var t2 ]) 263 | in 264 | let store_result : C.stmt = Exp (Assign (result, call_exp)) in 265 | let call_with_args = compile_call (List.rev (e :: es)) store_result in 266 | 267 | Decl 268 | ( ("struct Closure*", t1), 269 | Some null, 270 | Decl 271 | ( ("struct Variable*", t2), 272 | Some null, 273 | seq_stmts [ v; store_closure; save_env; call_with_args ] ) ) 274 | | Print e -> 275 | let v = exp2stmt e env left in 276 | let print : C.stmt = 277 | match tipe_of e with 278 | | Number_t -> 279 | Exp (Call (Var "printf", [ String "%.16g\\n"; result_num ])) 280 | | Bool_t -> 281 | Exp 282 | (Call 283 | ( Var "printf", 284 | [ 285 | String "%s\\n"; 286 | If (result_num, String "true", String "false"); 287 | ] )) 288 | | Unit_t -> Exp (Call (Var "printf", [ String "undefined\\n" ])) 289 | | t -> raise (Compile_error ("Unsupported type " ^ Js.string_of_tipe t)) 290 | in 291 | seq_stmts [ v; print ] 292 | 293 | and stmt2stmt (s : Js.stmt) (env : env) : C.stmt = 294 | match s with 295 | | Exp e -> exp2stmt e env false 296 | | Seq (s1, s2) -> 297 | let s1' = stmt2stmt s1 env in 298 | let s2' = stmt2stmt s2 env in 299 | seq_stmts [ s1'; s2' ] 300 | | If (e, s1, s2) -> 301 | let t = new_temp () in 302 | let save_env : C.stmt = Exp (Assign (Var t, Var "env")) in 303 | let v = exp2stmt e env false in 304 | let s1' = stmt2stmt s1 env in 305 | let s2' = stmt2stmt s2 env in 306 | (* TODO: free all new declared variables from env *) 307 | let restore_env : C.stmt = Exp (Assign (Var "env", Var t)) in 308 | Decl 309 | ( ("struct Variable*", t), 310 | Some null, 311 | seq_stmts [ save_env; v; If (result_num, s1', s2'); restore_env ] ) 312 | | While (e, s) -> 313 | let t1 = new_temp () in 314 | let t2 = new_temp () in 315 | let _ = stmt2fun (Js.Return e) t1 env in 316 | let save_env : C.stmt = Exp (Assign (Var t2, Var "env")) in 317 | let e' : C.exp = Binop (Dot, Call (Var t1, [ Var t2 ]), Var "num") in 318 | let s' = stmt2stmt s env in 319 | (* TODO: free all new declared variables from env *) 320 | let restore_env : C.stmt = Exp (Assign (Var "env", Var t2)) in 321 | Decl 322 | ( ("struct Variable*", t2), 323 | Some null, 324 | seq_stmts [ save_env; While (e', seq_stmts [ s'; restore_env ]) ] ) 325 | | For (e1, e2, e3, s) -> 326 | stmt2stmt (Seq (Exp e1, While (e2, Seq (s, Exp e3)))) env 327 | | Return e -> 328 | let v = exp2stmt e env false in 329 | let return : C.stmt = Return (Some result) in 330 | seq_stmts [ v; return ] 331 | | Decl (_, x, e, s) -> 332 | let t1 = new_temp () in 333 | let t2 = new_temp () in 334 | 335 | let v = exp2stmt e env false in 336 | let malloc_value : C.stmt = Exp (Assign (Var t2, malloc "union Value")) in 337 | let store_result : C.stmt = Exp (Assign (Unop (Deref, Var t2), result)) in 338 | 339 | let malloc_var : C.stmt = 340 | Exp (Assign (Var t1, malloc "struct Variable")) 341 | in 342 | let assign_var : C.stmt = 343 | Exp 344 | (Assign 345 | (Binop (Dot, Binop (Arrow, Var t1, Var "value"), Var "var"), Var t2)) 346 | in 347 | let store_next : C.stmt = 348 | Exp (Assign (Binop (Arrow, Var t1, Var "next"), Var "env")) 349 | in 350 | let store_head : C.stmt = Exp (Assign (Var "env", Var t1)) in 351 | 352 | let s' = stmt2stmt s (x :: env) in 353 | 354 | Decl 355 | ( ("struct Variable*", t1), 356 | Some null, 357 | Decl 358 | ( ("union Value*", t2), 359 | Some null, 360 | seq_stmts 361 | [ 362 | v; 363 | malloc_value; 364 | store_result; 365 | malloc_var; 366 | assign_var; 367 | store_next; 368 | store_head; 369 | s'; 370 | ] ) ) 371 | 372 | and stmt2fun (s : Js.stmt) (name : C.var) (env : env) : unit = 373 | let compile_body (s : C.stmt) : C.stmt = 374 | if name = "main" then 375 | Decl 376 | ( ("struct Variable*", "env"), 377 | Some null, 378 | Decl (("union Value", "result"), None, s) ) 379 | else Decl (("union Value", "result"), None, s) 380 | in 381 | 382 | let def = if name = "main" then ("int", "main") else ("union Value", name) in 383 | let args = if name = "main" then [] else [ ("struct Variable*", "env") ] in 384 | 385 | let s' = stmt2stmt s env in 386 | let return : C.stmt = 387 | if name = "main" then Return (Some (Int 0)) else Return (Some result) 388 | in 389 | let body = compile_body (seq_stmts [ s'; return ]) in 390 | 391 | let f : C.func = Fn { def; args; body } in 392 | program := { !program with body = f :: !program.body } 393 | 394 | let compile_program (p : Js.program) : program = 395 | let env = [] in 396 | let _ = stmt2fun p "main" env in 397 | { !program with body = List.rev !program.body } 398 | 399 | let string_of_c_struct (c_struct : c_struct) : string = 400 | let fields = 401 | String.concat "\n" 402 | (List.map (fun x -> " union Value " ^ x ^ ";") c_struct.fields) 403 | in 404 | "struct " ^ c_struct.name ^ " {\n" ^ fields ^ "\n};" 405 | 406 | let string_of_program (p : program) : string = 407 | let prog_str = 408 | "#include \n\ 409 | #include \n\n\ 410 | union Value {\n\ 411 | \ double num;\n\ 412 | \ struct Closure* closurePtr;\n\ 413 | \ union Value* var;\n\ 414 | \ void* obj;\n\ 415 | };\n\n\ 416 | struct Variable {\n\ 417 | \ union Value value;\n\ 418 | \ struct Variable* next;\n\ 419 | };\n\n\ 420 | struct Closure {\n\ 421 | \ union Value (*func)(struct Variable* env);\n\ 422 | \ struct Variable* env;\n\ 423 | };\n\n" 424 | ^ String.concat "\n\n" 425 | (p.structs |> List.map snd |> List.map string_of_c_struct) 426 | ^ "\n\n" ^ C.string_of_program p.body 427 | in 428 | prog_str 429 | --------------------------------------------------------------------------------