Move the majority of the procedure back to lib

This commit is contained in:
Michael Zhang 2022-03-08 03:20:19 -06:00
parent e66b515826
commit 713baccdd1
Signed by untrusted user who does not match committer: michael
GPG key ID: BDA47A31A3C8EE6B
9 changed files with 99 additions and 62 deletions

View file

@ -1,51 +1,7 @@
open E0 open E0
open E0.Util
module I = Parser.MenhirInterpreter
let get_parse_error env =
match I.stack env with
| lazy Nil -> "Invalid syntax"
| lazy (Cons (I.Element (state, _, _, _), _)) ->
try (E0.Parser_messages.message (I.number state)) with
| Not_found -> "invalid syntax (no specific message for this eror)"
let rec parse lexbuf (checkpoint : Ast.program I.checkpoint) =
match checkpoint with
| I.InputNeeded _env ->
let token = Lexer.f lexbuf in
let startp = lexbuf.lex_start_p
and endp = lexbuf.lex_curr_p in
let checkpoint = I.offer checkpoint (token, startp, endp) in
parse lexbuf checkpoint
| I.Shifting _
| I.AboutToReduce _ ->
let checkpoint = I.resume checkpoint in
parse lexbuf checkpoint
| I.HandlingError _env ->
let line, pos = Util.get_lexing_position lexbuf in
let err = get_parse_error _env in
raise (Syntax_error (Some (line, pos), err))
| I.Accepted v -> v
| I.Rejected ->
raise (Syntax_error (None, "invalid syntax (parser rejected the input)"))
let try_parse lexbuf =
try
let program = parse lexbuf (Parser.Incremental.program lexbuf.lex_curr_p) in
Ok program
with
| Util.Syntax_error (pos, err) ->
begin
match pos with
| Some (line, pos) ->
Error (Printf.sprintf "Syntax error on line %d, character %d: %s" line pos err)
| None -> Error (Printf.sprintf "Syntax error: %s" err)
end
let () = let () =
let p = Lexing.from_channel stdin |> try_parse in let p = Lexing.from_channel stdin |> Parse.try_parse in
match p with match p with
| Error msg -> Printf.eprintf "Could not load program: %s" msg | Error msg -> Printf.eprintf "Could not load program: %s" msg
| Ok p -> Ast.show_program p |> print_endline | Ok p -> Ast.show_program p |> print_endline

View file

@ -1,3 +1,5 @@
extern fn printf();
fn main() { fn main() {
return 42; return 42;
} }

View file

@ -47,8 +47,14 @@ type func =
} }
[@@deriving show] [@@deriving show]
type extern_func =
{ name : string
}
[@@deriving show]
type decl type decl
= DeclFunc of func = DeclFunc of func
| DeclExternFunc of extern_func
[@@deriving show] [@@deriving show]
type program = decl list type program = decl list

View file

@ -1,16 +1,21 @@
(library (library
(name e0) (name e0)
(libraries menhirLib) (libraries menhirLib)
(preprocess (pps ppx_deriving.show ppx_deriving.ord))) (preprocess
(pps ppx_deriving.show ppx_deriving.ord)))
(ocamllex lexer) (ocamllex lexer)
(menhir (menhir
(flags --table) (flags --table)
(modules parser)) (modules parser))
; https://baturin.org/blog/declarative-parse-error-reporting-with-menhir/ ; https://baturin.org/blog/declarative-parse-error-reporting-with-menhir/
(rule (rule
(targets parser_messages.ml) (targets parser_messages.ml)
(deps parser.messages parser.mly) (deps parser.messages parser.mly)
(action (with-stdout-to %{targets} (run menhir --compile-errors %{deps})))) (action
(with-stdout-to
%{targets}
(run menhir --compile-errors %{deps}))))

View file

@ -1,5 +1,5 @@
type expr type irexpr
= Expr = IExpr
type global = Global type global = Global

View file

@ -3,15 +3,19 @@
rule f = parse rule f = parse
| '\n' { Lexing.new_line lexbuf; f lexbuf } | '\n' { Lexing.new_line lexbuf; f lexbuf }
| [' ' '\t'] { f lexbuf } | [' ' '\t'] { f lexbuf }
| "extern" { KWD_EXTERN }
| "fn" { KWD_FN } | "fn" { KWD_FN }
| "return" { KWD_RETURN } | "return" { KWD_RETURN }
| "(" { PUNCT_LPAREN } | "(" { PUNCT_LPAREN }
| ")" { PUNCT_RPAREN } | ")" { PUNCT_RPAREN }
| "->" { PUNCT_RARROW } | "->" { PUNCT_RARROW }
| "{" { PUNCT_LBRACE }
| "}" { PUNCT_RBRACE }
| ":" { PUNCT_COLON } | ":" { PUNCT_COLON }
| ";" { PUNCT_SEMI } | ";" { PUNCT_SEMI }
| "{" { PUNCT_LBRACE }
| "}" { PUNCT_RBRACE }
| "-" ['0'-'9']+ as i { LIT_NEG_INT (- (int_of_string i)) } | "-" ['0'-'9']+ as i { LIT_NEG_INT (- (int_of_string i)) }
| ['0'-'9']+ as i { LIT_INT (int_of_string i) } | ['0'-'9']+ as i { LIT_INT (int_of_string i) }
| ['a'-'z' 'A'-'Z']* as i { IDENT i } | ['a'-'z' 'A'-'Z']* as i { IDENT i }

11
lib/lowering.ml Normal file
View file

@ -0,0 +1,11 @@
open Ast
open Ir
(* Processing state for this particular scope *)
type state =
{ parent : state option
}
let lower (func:func) : (irexpr list, unit) result =
let { name = _; body = _ } = func in
Error ()

43
lib/parse.ml Normal file
View file

@ -0,0 +1,43 @@
open Util
module I = Parser.MenhirInterpreter
let get_parse_error env =
match I.stack env with
| lazy Nil -> "Invalid syntax"
| lazy (Cons (I.Element (state, _, _, _), _)) ->
try (Parser_messages.message (I.number state)) with
| Not_found -> "invalid syntax (no specific message for this eror)"
let rec parse lexbuf (checkpoint : Ast.program I.checkpoint) =
match checkpoint with
| I.InputNeeded _env ->
let token = Lexer.f lexbuf in
let startp = lexbuf.lex_start_p
and endp = lexbuf.lex_curr_p in
let checkpoint = I.offer checkpoint (token, startp, endp) in
parse lexbuf checkpoint
| I.Shifting _
| I.AboutToReduce _ ->
let checkpoint = I.resume checkpoint in
parse lexbuf checkpoint
| I.HandlingError _env ->
let line, pos = Util.get_lexing_position lexbuf in
let err = get_parse_error _env in
raise (Syntax_error (Some (line, pos), err))
| I.Accepted v -> v
| I.Rejected ->
raise (Syntax_error (None, "invalid syntax (parser rejected the input)"))
let try_parse lexbuf =
try
let program = parse lexbuf (Parser.Incremental.program lexbuf.lex_curr_p) in
Ok program
with
| Util.Syntax_error (pos, err) ->
begin
match pos with
| Some (line, pos) ->
Error (Printf.sprintf "Syntax error on line %d, character %d: %s" line pos err)
| None -> Error (Printf.sprintf "Syntax error: %s" err)
end

View file

@ -3,15 +3,19 @@
%} %}
%token EOF %token EOF
%token KWD_EXTERN
%token KWD_FN %token KWD_FN
%token KWD_RETURN %token KWD_RETURN
%token PUNCT_LPAREN
%token PUNCT_RPAREN
%token PUNCT_RARROW
%token PUNCT_LBRACE
%token PUNCT_RBRACE
%token PUNCT_COLON %token PUNCT_COLON
%token PUNCT_LBRACE
%token PUNCT_LPAREN
%token PUNCT_RARROW
%token PUNCT_RBRACE
%token PUNCT_RPAREN
%token PUNCT_SEMI %token PUNCT_SEMI
%token <int> LIT_NEG_INT %token <int> LIT_NEG_INT
%token <int> LIT_INT %token <int> LIT_INT
%token <string> IDENT %token <string> IDENT
@ -25,10 +29,14 @@ program:
decl: decl:
| func=func { DeclFunc func } | func=func { DeclFunc func }
| extern=extern_func { DeclExternFunc extern }
func: func:
| KWD_FN name=IDENT PUNCT_LPAREN PUNCT_RPAREN body=body { { name; body } } | KWD_FN name=IDENT PUNCT_LPAREN PUNCT_RPAREN body=body { { name; body } }
extern_func:
| KWD_EXTERN KWD_FN name=IDENT PUNCT_LPAREN PUNCT_RPAREN PUNCT_SEMI { { name } }
body: body:
| PUNCT_LBRACE stmts=stmt* PUNCT_RBRACE { { stmts; ret=ExprUnit } } | PUNCT_LBRACE stmts=stmt* PUNCT_RBRACE { { stmts; ret=ExprUnit } }
@ -38,3 +46,5 @@ stmt:
expr: expr:
| i=LIT_NEG_INT { ExprLit (LitNegInt i) } | i=LIT_NEG_INT { ExprLit (LitNegInt i) }
| i=LIT_INT { ExprLit (LitInt i) } | i=LIT_INT { ExprLit (LitInt i) }
(* vim: set ft=ocamlyacc *)