initial import

This commit is contained in:
Frédéric Bour 2020-01-23 16:47:33 +01:00
commit d6feb2f2d7
11 changed files with 369 additions and 0 deletions

7
Makefile Normal file
View File

@ -0,0 +1,7 @@
all:
dune build bin/main.exe
clean:
dune clean
.PHONY: all clean

4
bin/dune Normal file
View File

@ -0,0 +1,4 @@
(executable
(public_name zml)
(name main)
(libraries zml))

1
bin/main.ml Normal file
View File

@ -0,0 +1 @@
let () = print_endline "Hello, World!"

2
dune-project Normal file
View File

@ -0,0 +1,2 @@
(lang dune 1.11)
(name zml)

34
lib/ast.ml Normal file
View File

@ -0,0 +1,34 @@
(* Abstract syntax. *)
type position = { line: int; column: int }
type location = { startp: position; endp: position }
type 'a located = { t: 'a; l: location }
(* Variable names *)
type name = string
(* Types *)
type ty =
| TInt (* Integers *)
| TBool (* Booleans *)
| TArrow of ty * ty (* Functions *)
(* Expressions *)
type expr = expr' located
and expr' =
| Var of name (* Variable *)
| Int of int (* Non-negative integer constant *)
| Bool of bool (* Boolean constant *)
| Times of expr * expr (* Product [e1 * e2] *)
| Plus of expr * expr (* Sum [e1 + e2] *)
| Minus of expr * expr (* Difference [e1 - e2] *)
| Equal of expr * expr (* Integer comparison [e1 = e2] *)
| Less of expr * expr (* Integer comparison [e1 < e2] *)
| If of expr * expr * expr (* Conditional [if e1 then e2 else e3] *)
| Fun of name * name * ty * ty * expr (* Function [fun f(x:s):t is e] *)
| Apply of expr * expr (* Application [e1 e2] *)
(* Toplevel commands *)
type command =
| Expr of expr (* Expression *)
| Def of name * expr (* Value definition [let x = e] *)

2
lib/dune Normal file
View File

@ -0,0 +1,2 @@
(library
(name zml))

134
lib/lexer.mll Normal file
View File

@ -0,0 +1,134 @@
{
open Ast
open Parser
let position pos =
let line = pos.Lexing.pos_lnum in
let column = pos.Lexing.pos_cnum - pos.Lexing.pos_bol in
{ line; column }
let lexbuf_location lexbuf =
let startp = lexbuf.Lexing.lex_start_p in
let endp = lexbuf.Lexing.lex_curr_p in
{ startp = position startp; endp = position endp }
let lexbuf_located t lexbuf =
{ t; p = lexbuf_location lexbuf }
let temp_buffer = Buffer.create 127
let flush_buffer () =
let str = Buffer.contents temp_buffer in
Buffer.reset temp_buffer;
str
let hashtable lst =
let table = Hashtbl.create (List.length lst) in
List.iter (fun (k, v) -> Hashtbl.add table k v) lst;
table
let idents = hashtable [
"type" , TYPE;
"rec" , REC;
"let" , LET;
"match" , MATCH;
"with" , WITH;
"end" , END;
"and" , AND;
"if" , IF;
"then" , THEN;
"else" , ELSE;
"fn" , FN;
"def" , DEF;
]
type error =
| Unknown_word of string
| Unterminated_string
| Invalid_escape of char
exception Error of Lexing.position * error
let error lexbuf x =
Buffer.reset temp_buffer;
raise (Error (lexbuf.Lexing.lex_curr_p, x))
let () = Printexc.register_printer (function
| Error (pos, e) ->
let msg = match e with
| Unknown_word word -> Printf.sprintf "unknown word %S" word
| Unterminated_string -> "unterminated string"
| Invalid_escape c -> Printf.sprintf "invalid escape %C" c
in
Some (
Printf.sprintf "Lexer.Error in %S, line %d column %d: %s"
pos.Lexing.pos_fname
pos.Lexing.pos_lnum
(pos.Lexing.pos_cnum - pos.Lexing.pos_bol)
msg
)
| _ -> None
)
}
let identchar = ['a'-'z' 'A'-'Z' '0'-'9' '_']
let lident = ['a'-'z' '_'] identchar*
let uident = ['A'-'Z'] identchar*
let digit = ['0'-'9']
let number = digit+
rule token = parse
| number as n { NUMBER (Number n) }
| ":<" { COLON_LANGLE }
| ">" { RANGLE }
| "(" { LPAREN }
| ")" { RPAREN }
| "|" { BAR }
| "=" { EQUAL }
| ":" { COLON }
| ";" { SEMI }
| "," { COMMA }
| "=>" { EQUAL_RANGLE }
| "_" { UNDERSCORE }
| lident as id {
try Hashtbl.find idents id
with Not_found -> error lexbuf (Unknown_word id)
}
| uident as id { UIDENT id }
| '"' { Buffer.reset temp_buffer; string lexbuf }
| "//" { Buffer.reset temp_buffer; comment lexbuf }
| ('\n' | "\r\n") { Lexing.new_line lexbuf; token lexbuf }
| [' ' '\t']+ { token lexbuf }
| eof { EOF }
and comment = parse
| [^'\n']+ as str {
Buffer.add_string temp_buffer str;
comment lexbuf
}
| '\n' { Lexing.new_line lexbuf; COMMENT (flush_buffer ()) }
| eof { COMMENT (flush_buffer ()) }
and string = parse
| ([^ '"' '\n' '\\']+) as str {
Buffer.add_string temp_buffer str;
string lexbuf
}
| '\n' { Lexing.new_line lexbuf; Buffer.add_char temp_buffer '\n'; string lexbuf }
| "\\" (_ as c) {
let c = match c with
| 'n' -> '\n'
| 'r' -> '\r'
| 't' -> '\t'
| '"' -> '"'
| c -> error lexbuf (Invalid_escape c)
in
Buffer.add_char temp_buffer c;
string lexbuf
}
| '"' { STRING (flush_buffer ()) }
| eof { error lexbuf Unterminated_string }
{
}

183
lib/parser.mly Normal file
View File

@ -0,0 +1,183 @@
%{
open Syntax
%}
%token COLON_LANGLE ":<"
(*%token LANGLE "<"*)
%token BAR "|"
%token COLON ":"
%token COMMA ","
%token EQUAL "="
%token EQUAL_RANGLE "=>"
%token LPAREN "("
%token RPAREN ")"
%token RANGLE ">"
%token SEMI ";"
%token UNDERSCORE "_"
%token AND "and"
%token DEF "def"
%token ELSE "else"
%token END "end"
%token FN "fn"
%token IF "if"
%token LET "let"
%token MATCH "match"
%token REC "rec"
%token THEN "then"
%token TYPE "type"
%token WITH "with"
%token EOF
%token<string Syntax.located> INT
%token<string Syntax.located> LIDENT UIDENT
%token<string Syntax.located> STRING
%token COMMENT
%start file
%type <Syntax.program> file
%%
(* Useful definitions *)
%inline with_loc(T):
| T { failwith "TODO" }
;
nonempty_sep_list(SEP, T):
| T { [$1] }
| T SEP sep_list(SEP, T) { $1 :: $3 }
;
sep_list(SEP, T):
| (* empty *) { [] }
| nonempty_sep_list(SEP, T) { $1 }
;
comma_list(T):
| sep_list(",", T) { $1 }
;
(* Type definition *)
type_parameters:
| (* empty *) { [] }
| ":<" comma_list(LIDENT) ">" { $2 }
;
(* Data constructors definition *)
constructor_definition:
| UIDENT
{ failwith "TODO" }
| UIDENT "(" comma_list(type_expr) ")"
{ failwith "TODO" }
;
type_body:
| "|"? nonempty_sep_list("|", constructor_definition)
{ $2 }
;
type_definition:
| LIDENT type_parameters "=" type_body
{ failwith "TODO" }
;
type_definitions:
| "type" "rec"? nonempty_sep_list("and", type_definition)
{ $2, $3 }
;
(* Let definitions *)
func_parameter:
| LIDENT ":" type_expr
{ $1, $3 }
;
func_parameters:
| "(" comma_list(func_parameter) ")"
{ $2 }
;
return_type:
| ":" type_expr
{ failwith "TODO" }
;
let_definition:
| UIDENT type_parameters func_parameters? return_type? "=" expr
{ failwith "TODO" }
;
let_definitions:
| "def" "rec"? nonempty_sep_list("and", let_definition)
{ $2, $3 }
;
(* Type expressions *)
type_arguments:
| (* empty *)
{ [] }
| ":<" comma_list(type_expr) ">"
{ $2 }
;
type_expr: with_loc(type_expr_) { $1 };
type_expr_:
| LIDENT type_arguments
| "fn" "(" comma_list(type_expr) ")" ":" type_expr
{ failwith "TODO" }
;
(* Expressions *)
constant: with_loc(constant_) { $1 };
%inline constant_:
| INT { Const_int $1 }
;
ident:
| LIDENT { $1 }
| UIDENT { $1 }
;
expr: with_loc(expr_) { $1 };
expr_:
| constant { $1 }
| "(" expr ")"
| ident type_arguments
| ident type_arguments "(" comma_list(expr) ")"
| "let" ident "=" expr ";" expr
| "if" expr "then" expr "else" expr "end"
| "match" expr "with" "|"? nonempty_sep_list("|", match_case) "end"
{ failwith "TODO" }
;
match_case:
| pattern "=>" expr { $1 }
;
pattern: with_loc(pattern_) { $1 }
pattern_:
| "_"
| LIDENT
| UIDENT
| UIDENT "(" comma_list(pattern) ")"
{ failwith "TODO" }
;
(* Program *)
definition:
| with_loc(type_definitions)
{ Def_type $1 }
| with_loc(let_definitions)
{ Def_let $1 }
;
file:
| list(definition) EOF { $1 }
;
%%

2
test/dune Normal file
View File

@ -0,0 +1,2 @@
(test
(name zml))

0
test/zml.ml Normal file
View File

0
zml.opam Normal file
View File