Initial Commit
This commit is contained in:
commit
472cf4bebe
10 changed files with 277 additions and 0 deletions
1
.gitignore
vendored
Normal file
1
.gitignore
vendored
Normal file
|
@ -0,0 +1 @@
|
||||||
|
_build
|
52
ast.ml
Normal file
52
ast.ml
Normal file
|
@ -0,0 +1,52 @@
|
||||||
|
type _ typ =
|
||||||
|
| Int : int -> int typ
|
||||||
|
| Unit : unit typ
|
||||||
|
|
||||||
|
let typ_to_string : type a. a typ -> string = function
|
||||||
|
| Int n -> Printf.sprintf "%d" n
|
||||||
|
| Unit -> "()"
|
||||||
|
|
||||||
|
type (_, _) binop =
|
||||||
|
| Add : (int, int) binop
|
||||||
|
| Sub : (int, int) binop
|
||||||
|
| Mul : (int, int) binop
|
||||||
|
| Div : (int, int) binop
|
||||||
|
|
||||||
|
let binop_to_string : type a b. (a, b) binop -> string = function
|
||||||
|
| Add -> "+"
|
||||||
|
| Sub -> "-"
|
||||||
|
| Mul -> "*"
|
||||||
|
| Div -> "/"
|
||||||
|
|
||||||
|
type _ t =
|
||||||
|
| Value : 'a typ -> 'a t
|
||||||
|
| Binop : 'a t * ('a, 'b) binop * 'a t -> 'b t
|
||||||
|
| Set_binop_pre : ('a, 'b) binop * int t -> unit t
|
||||||
|
|
||||||
|
let value v = Value v
|
||||||
|
|
||||||
|
let binop left op right =
|
||||||
|
Binop (left, op, right)
|
||||||
|
|
||||||
|
let set_binop_pre op pre =
|
||||||
|
Set_binop_pre (op, pre)
|
||||||
|
|
||||||
|
(* print ast LISP style. *)
|
||||||
|
let print ast =
|
||||||
|
let pr = Printf.printf in
|
||||||
|
let pv v = pr "%s" @@ typ_to_string v in
|
||||||
|
let rec aux : type a. a t -> unit = function
|
||||||
|
| Value n -> pv n
|
||||||
|
| Binop (left, op, right) -> begin
|
||||||
|
pr "(%s " @@ binop_to_string op;
|
||||||
|
aux left;
|
||||||
|
pr " ";
|
||||||
|
aux right;
|
||||||
|
pr ")";
|
||||||
|
end
|
||||||
|
| Set_binop_pre (op, pre) ->
|
||||||
|
pr "(set_pre %s " (binop_to_string op);
|
||||||
|
aux pre;
|
||||||
|
pr ")"
|
||||||
|
in
|
||||||
|
aux ast; pr "\n"
|
2
dune
Normal file
2
dune
Normal file
|
@ -0,0 +1,2 @@
|
||||||
|
(executable
|
||||||
|
(name main))
|
1
dune-project
Normal file
1
dune-project
Normal file
|
@ -0,0 +1 @@
|
||||||
|
(lang dune 2.9)
|
18
eval.ml
Normal file
18
eval.ml
Normal file
|
@ -0,0 +1,18 @@
|
||||||
|
open Ast
|
||||||
|
|
||||||
|
let binop_to_func : type a b. (a, b) Ast.binop -> (a -> a -> b) = function
|
||||||
|
| Add -> Int.add
|
||||||
|
| Sub -> Int.sub
|
||||||
|
| Mul -> Int.mul
|
||||||
|
| Div -> Int.div
|
||||||
|
| Eq -> (=)
|
||||||
|
|
||||||
|
let rec eval : type a. a Ast.t -> a = function
|
||||||
|
| Value (Int t) -> t
|
||||||
|
| Value Unit -> ()
|
||||||
|
| Binop (l, op, r) ->
|
||||||
|
let f = binop_to_func op in
|
||||||
|
f (eval l) (eval r)
|
||||||
|
| Set_binop_pre (op, l) ->
|
||||||
|
Hashtbl.replace Parser.precedence
|
||||||
|
(Ast.binop_to_string op) (eval l)
|
57
lex.ml
Normal file
57
lex.ml
Normal file
|
@ -0,0 +1,57 @@
|
||||||
|
type tokens = Token.t Seq.t
|
||||||
|
|
||||||
|
let either f g c =
|
||||||
|
f c || g c
|
||||||
|
|
||||||
|
let is_digit c =
|
||||||
|
'0' <= c && c <= '9'
|
||||||
|
|
||||||
|
let is_num = function
|
||||||
|
| 'x' -> true
|
||||||
|
| c -> is_digit c
|
||||||
|
|
||||||
|
let is_whitespace = function
|
||||||
|
| ' ' | '\t' | '\n' -> true
|
||||||
|
| _ -> false
|
||||||
|
|
||||||
|
let is_alpha c =
|
||||||
|
'A' <= c && c <= 'Z' && 'a' <= c && c <= 'z'
|
||||||
|
|
||||||
|
let is_ident_start =
|
||||||
|
either is_alpha ((=) '_')
|
||||||
|
|
||||||
|
let is_ident =
|
||||||
|
either is_ident_start is_digit
|
||||||
|
|
||||||
|
(* same as take_while f seq, drop_while f seq *)
|
||||||
|
let rec partition_while f seq : 'a Seq.t * 'a Seq.t =
|
||||||
|
match seq () with
|
||||||
|
| Seq.Nil -> Seq.empty, seq
|
||||||
|
| Seq.Cons (x, seq) ->
|
||||||
|
if f x then
|
||||||
|
let n, s = partition_while f seq in
|
||||||
|
Seq.cons x n, s
|
||||||
|
else
|
||||||
|
Seq.(empty, cons x seq)
|
||||||
|
|
||||||
|
let tokenize (str : string) : tokens =
|
||||||
|
let seq = String.to_seq str in
|
||||||
|
let rec aux seq =
|
||||||
|
let open Token in
|
||||||
|
match seq () with
|
||||||
|
| Seq.Nil -> Seq.empty
|
||||||
|
| Seq.Cons (x, s) ->
|
||||||
|
if is_whitespace x then
|
||||||
|
aux s
|
||||||
|
else if is_digit x then
|
||||||
|
let n, s = partition_while is_num s in
|
||||||
|
let n = String.of_seq @@ Seq.cons x n in
|
||||||
|
Seq.cons (of_string n) (aux s)
|
||||||
|
else if is_ident_start x then
|
||||||
|
let id, s = partition_while is_ident s in
|
||||||
|
let id = String.of_seq @@ Seq.cons x id in
|
||||||
|
Seq.cons (Ident id) (aux s)
|
||||||
|
else
|
||||||
|
Seq.cons (of_char x) (aux s)
|
||||||
|
in
|
||||||
|
aux seq
|
14
main.ml
Normal file
14
main.ml
Normal file
|
@ -0,0 +1,14 @@
|
||||||
|
(* simple REPL *)
|
||||||
|
let rec repl () : unit =
|
||||||
|
Printf.printf "> ";
|
||||||
|
let line = read_line () in
|
||||||
|
if line <> "quit" then begin
|
||||||
|
line
|
||||||
|
|> Lex.tokenize
|
||||||
|
|> Parser.parse
|
||||||
|
|> Eval.eval
|
||||||
|
|> Printf.printf "%d\n";
|
||||||
|
repl ()
|
||||||
|
end
|
||||||
|
|
||||||
|
let () = repl ()
|
90
parser.ml
Normal file
90
parser.ml
Normal file
|
@ -0,0 +1,90 @@
|
||||||
|
open Ast
|
||||||
|
|
||||||
|
exception Expected of string
|
||||||
|
exception Unexpected_token of string
|
||||||
|
|
||||||
|
let expected t =
|
||||||
|
raise (Expected t)
|
||||||
|
|
||||||
|
let unexpected_token t =
|
||||||
|
raise @@ Unexpected_token (Token.to_string t)
|
||||||
|
|
||||||
|
let precedence = [
|
||||||
|
"+", 10;
|
||||||
|
"-", 10;
|
||||||
|
"*", 20;
|
||||||
|
"/", 20;
|
||||||
|
] |> List.to_seq |> Hashtbl.of_seq
|
||||||
|
|
||||||
|
let precedence_of op =
|
||||||
|
Hashtbl.find precedence (Ast.binop_to_string op)
|
||||||
|
|
||||||
|
let token_to_op = function
|
||||||
|
| Token.Plus -> Add
|
||||||
|
| Minus -> Sub
|
||||||
|
| Asterisk -> Mul
|
||||||
|
| Slash -> Div
|
||||||
|
| _ -> failwith "Parser.token_to_op"
|
||||||
|
|
||||||
|
let parse : type a. Token.t Seq.t -> a Ast.t = fun ts ->
|
||||||
|
(* value := int | ( expr ) *)
|
||||||
|
let rec value seq =
|
||||||
|
match seq () with
|
||||||
|
| Seq.Nil -> assert false
|
||||||
|
| Seq.Cons (x, seq) -> begin match x with
|
||||||
|
| Token.Int n -> Value (Int n), seq
|
||||||
|
| LParen -> expr seq
|
||||||
|
| _ -> unexpected_token x
|
||||||
|
end
|
||||||
|
|
||||||
|
(* binop := binop op binop *)
|
||||||
|
and binop pre left seq =
|
||||||
|
match seq () with
|
||||||
|
| Seq.Nil -> left, Seq.empty
|
||||||
|
| Seq.Cons (x, seq) -> begin match x with
|
||||||
|
| Token.Plus | Minus | Asterisk | Slash as op ->
|
||||||
|
let op = token_to_op op in
|
||||||
|
let o = precedence_of op in
|
||||||
|
if o > pre then
|
||||||
|
let v, seq = value seq in
|
||||||
|
let right, seq = binop o v seq in
|
||||||
|
binop pre (Ast.binop left op right) seq
|
||||||
|
else
|
||||||
|
left, Seq.cons x seq
|
||||||
|
| RParen -> left, seq
|
||||||
|
| _ -> unexpected_token x
|
||||||
|
end
|
||||||
|
|
||||||
|
and operator seq =
|
||||||
|
match seq () with
|
||||||
|
| Seq.Nil -> expected "operator"
|
||||||
|
| Seq.Cons (x, seq) ->
|
||||||
|
try token_to_op x, seq with
|
||||||
|
| _ -> expected "operator"
|
||||||
|
|
||||||
|
and set_conf seq =
|
||||||
|
match seq () with
|
||||||
|
| Seq.Nil -> expected "ident"
|
||||||
|
| Seq.Cons (x, seq) -> begin match x with
|
||||||
|
| Token.Ident "level" ->
|
||||||
|
let op, seq = operator seq in
|
||||||
|
let v, seq = value seq in
|
||||||
|
Set_binop_pre (op, v), seq
|
||||||
|
| _ -> expected "argument"
|
||||||
|
end
|
||||||
|
|
||||||
|
and expr seq =
|
||||||
|
match seq () with
|
||||||
|
| Seq.Nil -> Value Unit (* nop *)
|
||||||
|
| Seq.Cons (x, s) -> begin match x with
|
||||||
|
| Ident "set" -> set_conf s
|
||||||
|
| _ ->
|
||||||
|
let left, seq = value seq in
|
||||||
|
binop ~-1 left seq
|
||||||
|
end
|
||||||
|
in
|
||||||
|
let ast, _ = expr ts in
|
||||||
|
(*
|
||||||
|
if rest () <> Seq.Nil then failwith "Parser.parse";
|
||||||
|
*)
|
||||||
|
ast
|
5
test.ml
Normal file
5
test.ml
Normal file
|
@ -0,0 +1,5 @@
|
||||||
|
|
||||||
|
let test_lex =
|
||||||
|
let open Token in
|
||||||
|
let t = Lex.tokenize "10 + 20 30/40" |> List.of_seq in
|
||||||
|
assert (t = [Int 10; Plus; Int 20; Int 30; Slash; Int 40])
|
37
token.ml
Normal file
37
token.ml
Normal file
|
@ -0,0 +1,37 @@
|
||||||
|
type t =
|
||||||
|
| Int of int
|
||||||
|
| Ident of string
|
||||||
|
| Plus
|
||||||
|
| Minus
|
||||||
|
| Asterisk
|
||||||
|
| Slash
|
||||||
|
| LParen
|
||||||
|
| RParen
|
||||||
|
|
||||||
|
let of_char = function
|
||||||
|
| '+' -> Plus
|
||||||
|
| '-' -> Minus
|
||||||
|
| '*' -> Asterisk
|
||||||
|
| '/' -> Slash
|
||||||
|
| '(' -> LParen
|
||||||
|
| ')' -> RParen
|
||||||
|
| _ -> invalid_arg "Token.of_char"
|
||||||
|
|
||||||
|
let of_string str =
|
||||||
|
let fc = Char.code str.[0] in
|
||||||
|
if Char.(code '0' <= fc && fc <= code '9') then
|
||||||
|
Int (int_of_string str)
|
||||||
|
else
|
||||||
|
match str with
|
||||||
|
| _ when String.length str = 1 -> of_char str.[0]
|
||||||
|
| _ -> failwith "Token.of_string"
|
||||||
|
|
||||||
|
let to_string = function
|
||||||
|
| Int n -> string_of_int n
|
||||||
|
| Ident s -> s
|
||||||
|
| Plus -> "+"
|
||||||
|
| Minus -> "-"
|
||||||
|
| Asterisk -> "*"
|
||||||
|
| Slash -> "/"
|
||||||
|
| LParen -> "("
|
||||||
|
| RParen -> ")"
|
Loading…
Add table
Reference in a new issue