From e8a637de82ebf76100d85c5aeb258376d9ee6cf1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Miko=C5=82aj=20Swoboda?= <331319@uwr.edu.pl> Date: Sun, 2 Jun 2024 20:02:59 +0200 Subject: [PATCH 1/8] Adapt cpspg to generate output in Fram The calculator example has been adapted as well. The program `TestLexer.fram` executes a test of a parser named `CalcParser.fram`. Other tests are not adapted yet. --- bin/main.ml | 2 +- framtools/Parsing.fram | 22 ++++ framtools/README.md | 15 +++ framtools/Utils.fram | 43 +++++++ lib/CodeGen.ml | 237 +++++++++++++++++++++++---------------- test/calc/Lexer.mll | 17 --- test/calc/ParserBase.mly | 31 ++--- test/calc/ParserPrec.mly | 35 +++--- test/calc/Parsing.fram | 22 ++++ test/calc/TestLexer.fram | 42 +++++++ test/calc/Utils.fram | 43 +++++++ test/calc/calc.ml | 13 --- 12 files changed, 365 insertions(+), 157 deletions(-) create mode 100644 framtools/Parsing.fram create mode 100644 framtools/README.md create mode 100644 framtools/Utils.fram delete mode 100644 test/calc/Lexer.mll create mode 100644 test/calc/Parsing.fram create mode 100644 test/calc/TestLexer.fram create mode 100644 test/calc/Utils.fram delete mode 100644 test/calc/calc.ml diff --git a/bin/main.ml b/bin/main.ml index 2f60924..c1cbb4c 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -3,7 +3,7 @@ let source_name = ref None let output_name = ref None let output_automaton = ref None let grammar_kind = ref Cpspg.Types.LALR -let codegen_line_directives = ref true +let codegen_line_directives = ref false (* Disabled for now *) let codegen_comments = ref false let codegen_readable_ids = ref false let codegen_locations = ref true diff --git a/framtools/Parsing.fram b/framtools/Parsing.fram new file mode 100644 index 0000000..6ebff24 --- /dev/null +++ b/framtools/Parsing.fram @@ -0,0 +1,22 @@ +pub data Pos = Pos of + { fname : String + , lnum : Int + , bol : Int + , cnum : Int } + +pub let dummyPos = Pos {fname = "", lnum = 0, bol = 0, cnum = 0-1} + +pub data Lex R Tok = Lex of + { token : Unit ->[|R] Tok + , startPos : Unit ->[|R] Pos + , curPos : Unit -> [|R] Pos } + +pub method token {R, Tok, self = Lex {token} : Lex R Tok} = token +pub method startPos {R, Tok, self = Lex {startPos} : Lex R Tok} = startPos +pub method curPos {R, Tok, self = Lex {curPos} : Lex R Tok} = curPos + +pub data Error (effect E) = Error of ({type X} -> String ->[E] X) +pub method parseError {E, self = Error f : Error E} = f + +pub let error {E, `error : Error E} s = `error.parseError s + diff --git a/framtools/README.md b/framtools/README.md new file mode 100644 index 0000000..f2bcb5d --- /dev/null +++ b/framtools/README.md @@ -0,0 +1,15 @@ +# Fram tools for cpspg +The files `Parsing.fram` and `Utils.fram` should be placed in the same +directory as the generated parser. + +## Utils +This module contains functions and types that should be part of Fram's +standard library, but which were not ready when the Fram adaptation +of cpspg was created. It should eventually fall out of use. + +## Parsing +This module contains the definition of position type and of the `Lex` +effect, used by the generated parser and handled by the written +lexer. It also defines the `Error` effect and the function `error` +that the user should use for reporting errors within semantic actions. + diff --git a/framtools/Utils.fram b/framtools/Utils.fram new file mode 100644 index 0000000..ba777b5 --- /dev/null +++ b/framtools/Utils.fram @@ -0,0 +1,43 @@ +pub data Either X Y = + | Left of X + | Right of Y + +pub let optionGet {`re : {type X} -> Unit ->[|_] X} opt = + match opt with + | None => `re () + | Some x => x + end + +pub let nth_opt xs (n : Int) = + let rec aux xs (n : Int) = + match xs with + | [] => None + | x :: xs => + if n == 0 then + Some x + else aux xs (n - 1) + end + in if n < 0 then None else aux xs n + +pub let hd {`re : {type X} -> Unit ->[|_] X} xs = + match xs with + | [] => `re () + | x :: _ => x + end + +pub let tl {`re : {type X} -> Unit ->[|_] X} xs = + match xs with + | [] => `re () + | _ :: xs => xs + end + +pub let nth {`re : {type X} -> Unit ->[|_] X} xs (n : Int) = + let rec aux xs (n : Int) = + match xs with + | [] => `re () + | x :: xs => + if n == 0 then x + else aux xs (n - 1) + end + in if n < 0 then `re () else aux xs n + diff --git a/lib/CodeGen.ml b/lib/CodeGen.ml index a47bc0b..6c5bf75 100644 --- a/lib/CodeGen.ml +++ b/lib/CodeGen.ml @@ -2,58 +2,88 @@ module IntMap = Map.Make (Int) module SymbolMap = Map.Make (Automaton.Symbol) let action_lib = - " let _kw_endpos ~loc _ =\n\ - \ match loc with\n\ - \ | l :: _ -> snd l\n\ - \ | [] -> Lexing.dummy_pos\n\ - \ ;;\n\n\ - \ let _kw_startpos ~loc n =\n\ - \ match List.nth_opt loc (n - 1) with\n\ - \ | Some l -> fst l\n\ - \ | None -> _kw_endpos ~loc n\n\ - \ ;;\n\n\ - \ let _kw_symbolstartpos ~loc:_ _ = failwith \"unimplemented: $symbolstartpos\"\n\ - \ let _kw_startofs ~loc:_ _ = failwith \"unimplemented: $startofs\"\n\ - \ let _kw_endofs ~loc:_ _ = failwith \"unimplemented: $endofs\"\n\ - \ let _kw_symbolstartofs ~loc:_ _ = failwith \"unimplemented: $symbolstartofs\"\n\ - \ let _kw_loc ~loc n = _kw_startpos ~loc n, _kw_endpos ~loc n\n\ - \ let _kw_sloc ~loc:_ _ = failwith \"unimplemented: $sloc\"\n" + " implicit `loc\n\ + \ implicit `error {E_err} : Parsing.Error E_err\n\n\ + \ pub let _kw_endpos _ =\n\ + \ match `loc with\n\ + \ | l :: _ => snd l\n\ + \ | [] => Parsing.dummyPos\n\ + \ end\n\n\ + \ pub let _kw_startpos (n : Int) =\n\ + \ match Utils.nth_opt `loc (n - 1) with\n\ + \ | Some l => fst l\n\ + \ | None => _kw_endpos n\n\ + \ end\n\n\ + \ pub let _kw_symbolstartpos _ = Parsing.error \"unimplemented: $symbolstartpos\"\n\ + \ pub let _kw_startofs _ = Parsing.error \"unimplemented: $startofs\"\n\ + \ pub let _kw_endofs _ = Parsing.error \"unimplemented: $endofs\"\n\ + \ pub let _kw_symbolstartofs _ = Parsing.error \"unimplemented: $symbolstartofs\"\n\ + \ pub let _kw_loc n = _kw_startpos n, _kw_endpos n\n\ + \ pub let _kw_sloc _ = Parsing.error \"unimplemented: $sloc\" + \n" ;; let state_lib = - " let lexfun = ref (fun _ -> assert false)\n\ - \ let lexbuf = ref (Lexing.from_string String.empty)\n\ - \ let peeked = ref None\n\ - \ let lexbuf_fallback_p = ref Lexing.dummy_pos\n\n\ - \ let setup lf lb =\n\ - \ lexfun := lf;\n\ - \ lexbuf := lb;\n\ - \ peeked := None;\n\ - \ lexbuf_fallback_p := !lexbuf.lex_curr_p\n\ - \ ;;\n\n\ - \ let shift () =\n\ - \ let sym = Option.get !peeked in\n\ - \ peeked := None;\n\ - \ lexbuf_fallback_p := !lexbuf.lex_curr_p;\n\ - \ sym\n\ - \ ;;\n\n\ - \ let lookahead () =\n\ - \ match !peeked with\n\ - \ | Some (tok, _) -> tok\n\ - \ | None ->\n\ - \ let tok = !lexfun !lexbuf\n\ - \ and loc = !lexbuf.lex_start_p, !lexbuf.lex_curr_p in\n\ - \ peeked := Some (tok, loc);\n\ - \ tok\n\ - \ ;;\n\n\ - \ let loc_shift ~loc l = l :: loc\n\n\ - \ let loc_reduce ~loc = function\n\ - \ | 0 -> (!lexbuf_fallback_p, !lexbuf_fallback_p) :: loc\n\ - \ | n ->\n\ - \ let rec skip n xs = if n = 0 then xs else skip (n - 1) (List.tl xs) in\n\ - \ let l = fst (List.nth loc (n - 1)), snd (List.hd loc) in\n\ - \ l :: skip n loc\n\ - \ ;;\n\n" + " let lexfun {E_err, E_st, R_lex,\n\ + \ `error : Parsing.Error E_err,\n\ + \ `st : State2 E_st,\n\ + \ `lex : Parsing.Lex R_lex Tok} () = \n\ + \ let (aux : Unit ->[E_err, E_st|R_lex] Tok) = \n\ + \ fn () => `lex.token ()\n\ + \ in aux ()\n\n\ + \ let shift {E_err, E_st, R_lex,\n\ + \ `error : Parsing.Error E_err,\n\ + \ `st : State2 E_st,\n\ + \ `lex : Parsing.Lex R_lex Tok} () = \n\ + \ let (aux : Unit ->[E_err, E_st|R_lex] Pair Tok (Pair Parsing.Pos Parsing.Pos)) = \n\ + \ (fn () => \n\ + \ let sym = Utils.optionGet {`re = (fn () => Parsing.error \"option\")}\n\ + \ (getPeeked ()) in\n\ + \ let () = setPeeked None in\n\ + \ let () = setFallback (`lex.curPos ()) in\n\ + \ sym)\n\ + \ in aux ()\n\n\ + \ let lookahead {E_err, E_st, R_lex,\n\ + \ `error : Parsing.Error E_err,\n\ + \ `st : State2 E_st,\n\ + \ `lex : Parsing.Lex R_lex Tok} () = \n\ + \ let (aux : Unit ->[E_err, E_st|R_lex] Tok) = \n\ + \ (fn () => \n\ + \ match getPeeked () with\n\ + \ | Some (tok, _) => tok\n\ + \ | None =>\n\ + \ let tok = lexfun () in\n\ + \ let loc = `lex.startPos (), `lex.curPos () in\n\ + \ let () = setPeeked (Some (tok, loc)) in\n\ + \ tok\n\ + \ end)\n\ + \ in aux ()\n\n\ + \ implicit `loc\n\ + \ let loc_shift l = l :: `loc\n\n\ + \ let loc_reduce {E_err, E_st, R_lex,\n\ + \ `error : Parsing.Error E_err,\n\ + \ `st : State2 E_st,\n\ + \ `lex : Parsing.Lex R_lex Tok} n =\n\ + \ let (aux : Int ->[E_err, E_st|R_lex] List (Pair Parsing.Pos Parsing.Pos)) = \n\ + \ (fn (n : Int) =>\n\ + \ if n == 0 then (getFallback (), getFallback ()) :: `loc\n\ + \ else\n\ + \ (let rec skip (n : Int) xs =\n\ + \ if n == 0 then xs\n\ + \ else skip (n - 1)\n\ + \ (Utils.tl {`re = (fn () => Parsing.error \"tl\")}\n\ + \ xs) in\n\ + \ let l = (fst (Utils.nth {`re = (fn () => Parsing.error \"nth\")}\n\ + \ `loc\n\ + \ (n - 1)),\n\ + \ snd (Utils.hd {`re = (fn () => Parsing.error \"hd\")}\n\ + \ `loc)) in\n\ + \ l :: skip n `loc))\n\ + \ in aux n\n\n\ + \ implicit `lex {R_lex} : Parsing.Lex R_lex Tok\n\ + \ implicit `st {E_st} : State2 E_st\n\ + \ implicit `error {E_err} : Parsing.Error E_err\n\ + \n" ;; let iteri2 f xs ys = @@ -89,7 +119,7 @@ struct |> String.concat ("\n" ^ i) ;; - let letrec ?(pre = "let rec") ?(pre' = "and") ?(post = "") ?(post' = " in") f xs = + let letrec ?(pre = "rec let") ?(pre' = "let") ?(post = "") ?(post' = " end in") f xs = let rec loop i = function | [] -> () | x :: xs -> @@ -158,7 +188,8 @@ struct else Format.fprintf f "%s" (term_name t) ;; - let write_term_patterns f ts = + (* This function is now obsolete because DBL has no disjunctions of patterns. *) + let _write_term_patterns f ts = let f sym = Format.fprintf f "| %t " (fun f -> write_term_pattern f false sym) in TermSet.iter f ts ;; @@ -166,7 +197,6 @@ struct let write_goto_call f state sym = let closure = state.s_kernel @ state.s_closure in write_state_id f (SymbolMap.find sym state.s_goto); - if S.locations then Format.fprintf f " ~loc"; if symbol_has_value sym then Format.fprintf f " x"; write_arg_ids f (List.find (shifts_group sym) closure).g_prefix; write_cont_ids f (shifts_group sym) (state.s_kernel @ state.s_closure) @@ -178,7 +208,7 @@ struct f "%t%s x = %t" (fun f -> write_cont_id f group idx) - (if S.locations then " ~loc" else "") + (if S.locations then " {`loc}" else "") (fun f -> write_goto_call f state sym) ;; @@ -190,18 +220,17 @@ struct let action = IntMap.find i_action A.automaton.a_actions in Format.fprintf f - " Actions.%t%s%t ()" + " Actions.%t%t ()" (fun f -> write_semantic_action_id f action i_action) - (if S.locations then " ~loc" else "") (fun f -> write_arg_ids f group.g_prefix) ;; let write_action_shift f state sym = - let write_loc_update f = Format.fprintf f " in\n let loc = loc_shift ~loc _l" in + let write_loc_update f = Format.fprintf f " in\n let `loc = loc_shift _l" in if S.comments then Format.fprintf f " (* Shift *)\n"; Format.fprintf f - " | %t ->\n let _, _l = shift ()%t in\n %t\n" + " | %t =>\n let (_, _l) = shift ()%t in\n %t\n" (fun f -> write_term_pattern f true sym) (fun f -> if S.locations then write_loc_update f) (fun f -> write_goto_call f state (Term sym)) @@ -209,20 +238,21 @@ struct let write_action_reduce f state lookahead i j = let write_loc_update f n = - Format.fprintf f "\n and loc = loc_reduce ~loc %d" n + Format.fprintf f "\n in let `loc = loc_reduce %d" n in if S.comments then Format.fprintf f " (* Reduce *)\n"; let group = List.nth (state.s_kernel @ state.s_closure) i in let n = List.length group.g_prefix and item = List.nth group.g_items j in - Format.fprintf - f - " %t->\n let x =%t%t in\n %t%s x\n" - (fun f -> write_term_patterns f lookahead) - (fun f -> write_semantic_action_call f group item) - (fun f -> if S.locations then write_loc_update f n) - (fun f -> write_cont_id f group i) - (if S.locations then " ~loc" else "") + TermSet.iter (fun sym -> + Format.fprintf + f + " | %t =>\n let x =%t%t in\n %t x\n" + (fun f -> write_term_pattern f false sym) + (fun f -> write_semantic_action_call f group item) + (fun f -> if S.locations then write_loc_update f n) + (fun f -> write_cont_id f group i)) + lookahead ;; let write_action f state lookahead = function @@ -233,7 +263,7 @@ struct let write_actions f state = Format.fprintf f " match lookahead () with\n"; List.iter (fun (l, m) -> write_action f state l m) state.s_action; - Format.fprintf f " | _ -> raise Error\n" + Format.fprintf f " | _ => Parsing.error \"\"\n end\n" ;; let write_actions_starting f state = @@ -265,7 +295,7 @@ struct and cmp a b = String.compare b.ti_name.data a.ti_name.data in let infos = List.filter_map get_info symbols in let infos = List.fast_sort cmp infos in - Format.fprintf f "type token =\n"; + Format.fprintf f "pub data Tok =\n"; List.iter (write_term_cons f) infos; Format.fprintf f "\n" ;; @@ -283,14 +313,14 @@ struct | Some (Some a) -> a | Some None -> Printf.sprintf "_arg%d" i | None -> "()") - | Ast.KwStartpos -> Printf.sprintf "_kw_startpos ~loc:_loc %d" n - | Ast.KwEndpos -> Printf.sprintf "_kw_endpos ~loc:_loc %d" n - | Ast.KwSymbolstartpos -> Printf.sprintf "_kw_symbolstartpos ~loc:_loc %d" n - | Ast.KwStartofs -> Printf.sprintf "_kw_startofs ~loc:_loc %d" n - | Ast.KwEndofs -> Printf.sprintf "_kw_endofs ~loc:_loc %d" n - | Ast.KwSymbolstartofs -> Printf.sprintf "_kw_symbolstartofs ~loc:_loc %d" n - | Ast.KwLoc -> Printf.sprintf "_kw_loc ~loc:_loc %d" n - | Ast.KwSloc -> Printf.sprintf "_kw_sloc ~loc:_loc %d" n + | Ast.KwStartpos -> Printf.sprintf "_kw_startpos %d" n + | Ast.KwEndpos -> Printf.sprintf "_kw_endpos %d" n + | Ast.KwSymbolstartpos -> Printf.sprintf "_kw_symbolstartpos %d" n + | Ast.KwStartofs -> Printf.sprintf "_kw_startofs %d" n + | Ast.KwEndofs -> Printf.sprintf "_kw_endofs %d" n + | Ast.KwSymbolstartofs -> Printf.sprintf "_kw_symbolstartofs %d" n + | Ast.KwLoc -> Printf.sprintf "_kw_loc %d" n + | Ast.KwSloc -> Printf.sprintf "_kw_sloc %d" n in let rec loop pos = function | [] -> write_part f pos (snd code.loc) @@ -311,7 +341,6 @@ struct | None -> Format.fprintf f " _arg%d" (List.length action.sa_args - i) in write_semantic_action_id f action id; - if S.locations then Format.fprintf f " ~loc:_loc"; iteri2 iter (List.rev item.i_suffix) (List.rev action.sa_args); Format.fprintf f " () = %t" (fun f -> write_semantic_action_code f action) ;; @@ -333,7 +362,7 @@ struct f "%t%s%t%t =\n" (fun f -> write_state_id f id) - (if S.locations then " ~loc" else "") + (if S.locations then " {`loc}" else "") (fun f -> write_arg_ids f (List.hd state.s_kernel).g_prefix) (fun f -> write_cont_ids f (fun _ -> true) state.s_kernel) ;; @@ -359,44 +388,64 @@ struct let write_entry f symbol id = Format.fprintf f - "let %s lexfun lexbuf =\n\ - \ States.setup lexfun lexbuf;\n\ - \ States.%t%s (fun x -> x)\n\ - ;;\n" + "pub let %s {`lex} () =\n\ + \ handle `error = Parsing.Error (effect x / _ => Utils.Left x)\n\ + \ return x => Utils.Right x in\n\ + \ handle `st = State2\n\ + \ { setPeeked = effect p / r => fn _ f => r () p f\n\ + \ , getPeeked = effect () / r => fn p f => r p p f\n\ + \ , setFallback = effect f / r => fn p _ => r () p f\n\ + \ , getFallback = effect () / r => fn p f => r f p f }\n\ + \ return x => fn _ _ => x\n\ + \ finally f => f None Parsing.dummyPos in\n\ + \ States.%t%s (fn x => x)\n\ + \n" (nterm_name symbol) (fun f -> write_state_id f id) - (if S.locations then " ~loc:[]" else "") + (if S.locations then " {`loc = []}" else "") ;; let write f = let write_semantic_action f id a = - Format.fprintf f " let %t\n" (fun f -> write_semantic_action f id a) + Format.fprintf f " pub let %t\n" (fun f -> write_semantic_action f id a) and write_state f _ (id, s) pre post = if S.comments then write_state_comment f s; Format.fprintf f " %s %t%s" pre (fun f -> write_state f id s) post and write_entry f (nt, s) = write_entry f nt s - and state_letrec = letrec ~post:"\n" ~post':" ;;\n" in + and state_letrec = letrec ~pre:"pub rec let" ~post:"\n" ~post':"end \n" in (* -unused-rec-flag due continuations always being mutually recursive, while often they don't need to *) (* FIXME: should we include -redunant-{case, subpat}? They trigger warnings in grammars with unresolved conflicts, but maybe it's a good thing? *) Format.fprintf f - "[@@@@@@warning \"-unused-rec-flag\"]\n\ - [@@@@@@warning \"-redundant-case\"]\n\ - [@@@@@@warning \"-redundant-subpat\"]\n\n\ + "import Parsing\n\ + import Utils\n\ + implicit `error {E_err} : Parsing.Error E_err\n\ %t\n\n\ - exception Error\n\n\ - %tmodule Actions = struct\n\ + %tdata State2 (effect E) = State2 of\n\ + \ { setPeeked : Option (Pair Tok (Pair Parsing.Pos Parsing.Pos)) ->[E] Unit\n\ + \ , setFallback : Parsing.Pos ->[E] Unit\n\ + \ , getPeeked : Unit ->[E] Option (Pair Tok (Pair Parsing.Pos Parsing.Pos))\n\ + \ , getFallback : Unit ->[E] Parsing.Pos }\n\n\ + method setPeeked {E, self = State2 {setPeeked} : State2 E} = setPeeked\n\ + method getPeeked {E, self = State2 {getPeeked} : State2 E} = getPeeked\n\ + method setFallback {E, self = State2 {setFallback} : State2 E} = setFallback\n\ + method getFallback {E, self = State2 {getFallback} : State2 E} = getFallback\n\n\ + let setPeeked {E, `st : State2 E} p = `st.setPeeked p\n\ + let getPeeked {E, `st : State2 E} () = `st.getPeeked ()\n\ + let setFallback {E, `st : State2 E} f = `st.setFallback f\n\ + let getFallback {E, `st : State2 E} () = `st.getFallback ()\n\n\ + module Actions\n\ %s%tend\n\n\ - module States = struct\n\ + module States\n\ %s%tend\n\n\ - %t" + %t" (fun f -> write_string f A.automaton.a_header) (fun f -> write_term_type f G.symbols) action_lib - (fun f -> IntMap.iter (write_semantic_action f) A.automaton.a_actions) + (fun f -> IntMap.iter (write_semantic_action f) A.automaton.a_actions) (* FIXME: rec blocks are not indented *) state_lib - (fun f -> IntMap.bindings A.automaton.a_states |> state_letrec (write_state f)) + (fun f -> IntMap.bindings A.automaton.a_states |> state_letrec (write_state f)) (* FIXME: rec blocks are not indented *) (fun f -> List.iter (write_entry f) A.automaton.a_starting) ;; end diff --git a/test/calc/Lexer.mll b/test/calc/Lexer.mll deleted file mode 100644 index 1895897..0000000 --- a/test/calc/Lexer.mll +++ /dev/null @@ -1,17 +0,0 @@ -{ - open Parser -} - -rule token = parse - | [' ' '\t' '\n' '\r'] { token lexbuf } - | ['0'-'9']+ as i { INT (int_of_string i) } - | '+' { PLUS } - | '-' { MINUS} - | '*' { STAR } - | '/' { SLASH } - | '%' { PERCENT } - | '^' { CARET } - | '(' { LPAREN } - | ')' { RPAREN } - | eof { EOF } - | _ { failwith "error" } diff --git a/test/calc/ParserBase.mly b/test/calc/ParserBase.mly index 7cdcc9c..62d3db6 100644 --- a/test/calc/ParserBase.mly +++ b/test/calc/ParserBase.mly @@ -1,38 +1,39 @@ %{ +let fail () = Parsing.error "arithmetic error" -let rec pow a = function - | 0 -> 1 - | 1 -> a - | n -> - let b = pow a (n / 2) in - b * b * (if n mod 2 = 0 then 1 else a) -;; +let pow {`re : {type X} -> Unit ->[|_] X} = + let rec aux a (n : Int) = + if n == 0 then 1 + else if n == 1 then a + else (let (b : Int) = aux a (n / 2) in + b * b * (if n % 2 == 0 then 1 else a)) + in aux %} -%token INT +%token INT %token PLUS MINUS SLASH STAR PERCENT CARET LPAREN RPAREN EOF -%start main +%start main %% main: x=expr EOF { x }; expr: - | l=expr PLUS r=term { l + r } - | l=expr MINUS r=term { l - r } + | l=expr PLUS r=term { let (l : Int) = l in l + r } + | l=expr MINUS r=term { let (l : Int) = l in l - r } | x=term { x } ; term: - | l=term STAR r=factor { l * r } - | l=term SLASH r=factor { l / r } - | l=term PERCENT r=factor { l mod r } + | l=term STAR r=factor { let (l : Int) = l in l * r } + | l=term SLASH r=factor { let (l : Int) = l in let `re = fail in l / r } + | l=term PERCENT r=factor { let (l : Int) = l in let `re = fail in l % r } | x=factor { x } ; factor: - | l=base CARET r=factor { pow l r } + | l=base CARET r=factor { let `re = fail in pow l r } | x=base { x } ; diff --git a/test/calc/ParserPrec.mly b/test/calc/ParserPrec.mly index 7a0fe79..85d0193 100644 --- a/test/calc/ParserPrec.mly +++ b/test/calc/ParserPrec.mly @@ -1,18 +1,19 @@ %{ +let fail () = Parsing.error "arithmetic error" -let rec pow a = function - | 0 -> 1 - | 1 -> a - | n -> - let b = pow a (n / 2) in - b * b * (if n mod 2 = 0 then 1 else a) -;; +let pow {`re : {type X} -> Unit ->[|_] X} = + let rec aux a (n : Int) = + if n == 0 then 1 + else if n == 1 then a + else (let (b : Int) = aux a (n / 2) in + b * b * (if n % 2 == 0 then 1 else a)) + in aux %} -%token INT +%token INT %token PLUS MINUS SLASH STAR PERCENT CARET LPAREN RPAREN EOF -%start main +%start main %left PLUS MINUS %left SLASH STAR PERCENT @@ -24,14 +25,14 @@ let rec pow a = function main: x=expr EOF { x }; expr: - | l=expr PLUS r=expr { l + r } - | l=expr MINUS r=expr { l - r } - | l=expr STAR r=expr { l * r } - | l=expr SLASH r=expr { l / r } - | l=expr PERCENT r=expr { l mod r } - | l=expr CARET r=expr { pow l r } - - | MINUS x=expr %prec UMINUS { -x } + | l=expr PLUS r=expr { let (l : Int) = l in l + r } + | l=expr MINUS r=expr { let (l : Int) = l in l - r } + | l=expr STAR r=expr { let (l : Int) = l in l * r } + | l=expr SLASH r=expr { let (l : Int) = l in let `re = fail in l / r } + | l=expr PERCENT r=expr { let (l : Int) = l in let `re = fail in l % r } + | l=expr CARET r=expr { let `re = fail in pow l r } + + | MINUS x=expr %prec UMINUS { 0 - x } | LPAREN x=expr RPAREN { x } | x=INT { x } diff --git a/test/calc/Parsing.fram b/test/calc/Parsing.fram new file mode 100644 index 0000000..6ebff24 --- /dev/null +++ b/test/calc/Parsing.fram @@ -0,0 +1,22 @@ +pub data Pos = Pos of + { fname : String + , lnum : Int + , bol : Int + , cnum : Int } + +pub let dummyPos = Pos {fname = "", lnum = 0, bol = 0, cnum = 0-1} + +pub data Lex R Tok = Lex of + { token : Unit ->[|R] Tok + , startPos : Unit ->[|R] Pos + , curPos : Unit -> [|R] Pos } + +pub method token {R, Tok, self = Lex {token} : Lex R Tok} = token +pub method startPos {R, Tok, self = Lex {startPos} : Lex R Tok} = startPos +pub method curPos {R, Tok, self = Lex {curPos} : Lex R Tok} = curPos + +pub data Error (effect E) = Error of ({type X} -> String ->[E] X) +pub method parseError {E, self = Error f : Error E} = f + +pub let error {E, `error : Error E} s = `error.parseError s + diff --git a/test/calc/TestLexer.fram b/test/calc/TestLexer.fram new file mode 100644 index 0000000..343dc9d --- /dev/null +++ b/test/calc/TestLexer.fram @@ -0,0 +1,42 @@ +import List +import open CalcParser +import Parsing + +module Feeder + pub let withFeeder {Tok} + (xs : List Tok) + (eof : Tok) + (f : {R} -> Parsing.Lex R Tok -> [|R] _) = + handle lex = Parsing.Lex + { token = effect () / r => + fn ys => + match ys with + | [] => r eof ys + | y :: ys => r y ys + end + , curPos = effect () / r => fn ys => r Parsing.dummyPos ys + , startPos = effect () / r => fn ys => r Parsing.dummyPos ys } + return x => fn _ => x + finally f => f xs + in f lex +end + +let tests = + [[INT 2, PLUS, INT 3], + [INT 8, STAR, INT 3, STAR, INT 89, PLUS, INT 1], + [LPAREN, INT 9, PLUS, INT 1, RPAREN, SLASH, INT 5], + [INT 4, SLASH, INT 0], + [INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, PERCENT, INT 5], + [LPAREN, INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, RPAREN, PERCENT, INT 5]] + +let execTest xs = + let res = Feeder.withFeeder xs + EOF + (fn lex => main {`lex = lex} ()) in + match res with + | Left s => printStrLn s + | Right n => printInt n ; printStrLn "" + end + +let _ = List.iter execTest tests + diff --git a/test/calc/Utils.fram b/test/calc/Utils.fram new file mode 100644 index 0000000..ba777b5 --- /dev/null +++ b/test/calc/Utils.fram @@ -0,0 +1,43 @@ +pub data Either X Y = + | Left of X + | Right of Y + +pub let optionGet {`re : {type X} -> Unit ->[|_] X} opt = + match opt with + | None => `re () + | Some x => x + end + +pub let nth_opt xs (n : Int) = + let rec aux xs (n : Int) = + match xs with + | [] => None + | x :: xs => + if n == 0 then + Some x + else aux xs (n - 1) + end + in if n < 0 then None else aux xs n + +pub let hd {`re : {type X} -> Unit ->[|_] X} xs = + match xs with + | [] => `re () + | x :: _ => x + end + +pub let tl {`re : {type X} -> Unit ->[|_] X} xs = + match xs with + | [] => `re () + | _ :: xs => xs + end + +pub let nth {`re : {type X} -> Unit ->[|_] X} xs (n : Int) = + let rec aux xs (n : Int) = + match xs with + | [] => `re () + | x :: xs => + if n == 0 then x + else aux xs (n - 1) + end + in if n < 0 then `re () else aux xs n + diff --git a/test/calc/calc.ml b/test/calc/calc.ml deleted file mode 100644 index 89d2c8f..0000000 --- a/test/calc/calc.ml +++ /dev/null @@ -1,13 +0,0 @@ -let _ = - let rec loop () = - Printf.printf "> %!"; - match In_channel.input_line stdin with - | None -> () - | Some line when String.trim line = "" -> loop () - | Some line -> - let lexbuf = Lexing.from_string line in - Printf.printf "= %d\n%!" (Parser.main Lexer.token lexbuf); - loop () - in - loop () -;; From fb72a2f36287d31e7555db391958bc26c9c77809 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Miko=C5=82aj=20Swoboda?= <331319@uwr.edu.pl> Date: Tue, 11 Jun 2024 00:07:19 +0200 Subject: [PATCH 2/8] Correct indentation and remove most of Utils - Fix indentation in the States module of a generated parser. - Remove most of Utils. A generated parser now uses standard library functions where possible. - Move documentation of Parsing and Utils from the strange README file to comments. --- framtools/Parsing.fram | 7 +++ framtools/README.md | 15 ----- framtools/Utils.fram | 42 ++------------ lib/CodeGen.ml | 123 +++++++++++++++++++++-------------------- test/calc/Parsing.fram | 7 +++ test/calc/Utils.fram | 42 ++------------ 6 files changed, 88 insertions(+), 148 deletions(-) delete mode 100644 framtools/README.md diff --git a/framtools/Parsing.fram b/framtools/Parsing.fram index 6ebff24..5704de1 100644 --- a/framtools/Parsing.fram +++ b/framtools/Parsing.fram @@ -1,3 +1,6 @@ +(* This file should be placed in the same directory as the generated + * parser *) + pub data Pos = Pos of { fname : String , lnum : Int @@ -18,5 +21,9 @@ pub method curPos {R, Tok, self = Lex {curPos} : Lex R Tok} = curPos pub data Error (effect E) = Error of ({type X} -> String ->[E] X) pub method parseError {E, self = Error f : Error E} = f +(** Error-reporting function. Use this function to report errors + in semantic actions. If an error is reported, the result + returned by the parser will be the passed string wrapped in + a `Left` constructor. *) pub let error {E, `error : Error E} s = `error.parseError s diff --git a/framtools/README.md b/framtools/README.md deleted file mode 100644 index f2bcb5d..0000000 --- a/framtools/README.md +++ /dev/null @@ -1,15 +0,0 @@ -# Fram tools for cpspg -The files `Parsing.fram` and `Utils.fram` should be placed in the same -directory as the generated parser. - -## Utils -This module contains functions and types that should be part of Fram's -standard library, but which were not ready when the Fram adaptation -of cpspg was created. It should eventually fall out of use. - -## Parsing -This module contains the definition of position type and of the `Lex` -effect, used by the generated parser and handled by the written -lexer. It also defines the `Error` effect and the function `error` -that the user should use for reporting errors within semantic actions. - diff --git a/framtools/Utils.fram b/framtools/Utils.fram index ba777b5..1aa93cf 100644 --- a/framtools/Utils.fram +++ b/framtools/Utils.fram @@ -1,6 +1,9 @@ -pub data Either X Y = - | Left of X - | Right of Y +(* This file contains useful functions that arguably (i.e., in comparison + * with OCaml) belong in the standard library but have not been included + * in it yet. It should eventually fall out of use. + * + * Nonetheless, as long as it hasn't, it should be placed in the same directory + * as the generated parser. *) pub let optionGet {`re : {type X} -> Unit ->[|_] X} opt = match opt with @@ -8,36 +11,3 @@ pub let optionGet {`re : {type X} -> Unit ->[|_] X} opt = | Some x => x end -pub let nth_opt xs (n : Int) = - let rec aux xs (n : Int) = - match xs with - | [] => None - | x :: xs => - if n == 0 then - Some x - else aux xs (n - 1) - end - in if n < 0 then None else aux xs n - -pub let hd {`re : {type X} -> Unit ->[|_] X} xs = - match xs with - | [] => `re () - | x :: _ => x - end - -pub let tl {`re : {type X} -> Unit ->[|_] X} xs = - match xs with - | [] => `re () - | _ :: xs => xs - end - -pub let nth {`re : {type X} -> Unit ->[|_] X} xs (n : Int) = - let rec aux xs (n : Int) = - match xs with - | [] => `re () - | x :: xs => - if n == 0 then x - else aux xs (n - 1) - end - in if n < 0 then `re () else aux xs n - diff --git a/lib/CodeGen.ml b/lib/CodeGen.ml index 6c5bf75..db7f68b 100644 --- a/lib/CodeGen.ml +++ b/lib/CodeGen.ml @@ -10,7 +10,7 @@ let action_lib = \ | [] => Parsing.dummyPos\n\ \ end\n\n\ \ pub let _kw_startpos (n : Int) =\n\ - \ match Utils.nth_opt `loc (n - 1) with\n\ + \ match List.nth `loc (n - 1) with\n\ \ | Some l => fst l\n\ \ | None => _kw_endpos n\n\ \ end\n\n\ @@ -25,64 +25,64 @@ let action_lib = let state_lib = " let lexfun {E_err, E_st, R_lex,\n\ - \ `error : Parsing.Error E_err,\n\ - \ `st : State2 E_st,\n\ - \ `lex : Parsing.Lex R_lex Tok} () = \n\ - \ let (aux : Unit ->[E_err, E_st|R_lex] Tok) = \n\ - \ fn () => `lex.token ()\n\ - \ in aux ()\n\n\ - \ let shift {E_err, E_st, R_lex,\n\ - \ `error : Parsing.Error E_err,\n\ - \ `st : State2 E_st,\n\ - \ `lex : Parsing.Lex R_lex Tok} () = \n\ - \ let (aux : Unit ->[E_err, E_st|R_lex] Pair Tok (Pair Parsing.Pos Parsing.Pos)) = \n\ - \ (fn () => \n\ - \ let sym = Utils.optionGet {`re = (fn () => Parsing.error \"option\")}\n\ - \ (getPeeked ()) in\n\ - \ let () = setPeeked None in\n\ - \ let () = setFallback (`lex.curPos ()) in\n\ - \ sym)\n\ - \ in aux ()\n\n\ - \ let lookahead {E_err, E_st, R_lex,\n\ - \ `error : Parsing.Error E_err,\n\ - \ `st : State2 E_st,\n\ - \ `lex : Parsing.Lex R_lex Tok} () = \n\ - \ let (aux : Unit ->[E_err, E_st|R_lex] Tok) = \n\ - \ (fn () => \n\ - \ match getPeeked () with\n\ - \ | Some (tok, _) => tok\n\ - \ | None =>\n\ - \ let tok = lexfun () in\n\ - \ let loc = `lex.startPos (), `lex.curPos () in\n\ - \ let () = setPeeked (Some (tok, loc)) in\n\ - \ tok\n\ - \ end)\n\ - \ in aux ()\n\n\ - \ implicit `loc\n\ - \ let loc_shift l = l :: `loc\n\n\ - \ let loc_reduce {E_err, E_st, R_lex,\n\ - \ `error : Parsing.Error E_err,\n\ - \ `st : State2 E_st,\n\ - \ `lex : Parsing.Lex R_lex Tok} n =\n\ - \ let (aux : Int ->[E_err, E_st|R_lex] List (Pair Parsing.Pos Parsing.Pos)) = \n\ - \ (fn (n : Int) =>\n\ - \ if n == 0 then (getFallback (), getFallback ()) :: `loc\n\ - \ else\n\ - \ (let rec skip (n : Int) xs =\n\ - \ if n == 0 then xs\n\ - \ else skip (n - 1)\n\ - \ (Utils.tl {`re = (fn () => Parsing.error \"tl\")}\n\ - \ xs) in\n\ - \ let l = (fst (Utils.nth {`re = (fn () => Parsing.error \"nth\")}\n\ - \ `loc\n\ - \ (n - 1)),\n\ - \ snd (Utils.hd {`re = (fn () => Parsing.error \"hd\")}\n\ - \ `loc)) in\n\ - \ l :: skip n `loc))\n\ - \ in aux n\n\n\ - \ implicit `lex {R_lex} : Parsing.Lex R_lex Tok\n\ - \ implicit `st {E_st} : State2 E_st\n\ - \ implicit `error {E_err} : Parsing.Error E_err\n\ + \ `error : Parsing.Error E_err,\n\ + \ `st : State2 E_st,\n\ + \ `lex : Parsing.Lex R_lex Tok} () = \n\ + \ let (aux : Unit ->[E_err, E_st|R_lex] Tok) = \n\ + \ fn () => `lex.token ()\n\ + \ in aux ()\n\n\ + \ let shift {E_err, E_st, R_lex,\n\ + \ `error : Parsing.Error E_err,\n\ + \ `st : State2 E_st,\n\ + \ `lex : Parsing.Lex R_lex Tok} () = \n\ + \ let (aux : Unit ->[E_err, E_st|R_lex] Pair Tok (Pair Parsing.Pos Parsing.Pos)) = \n\ + \ (fn () => \n\ + \ let sym = Utils.optionGet {`re = (fn () => Parsing.error \"option\")}\n\ + \ (getPeeked ()) in\n\ + \ let () = setPeeked None in\n\ + \ let () = setFallback (`lex.curPos ()) in\n\ + \ sym)\n\ + \ in aux ()\n\n\ + \ let lookahead {E_err, E_st, R_lex,\n\ + \ `error : Parsing.Error E_err,\n\ + \ `st : State2 E_st,\n\ + \ `lex : Parsing.Lex R_lex Tok} () = \n\ + \ let (aux : Unit ->[E_err, E_st|R_lex] Tok) = \n\ + \ (fn () => \n\ + \ match getPeeked () with\n\ + \ | Some (tok, _) => tok\n\ + \ | None =>\n\ + \ let tok = lexfun () in\n\ + \ let loc = `lex.startPos (), `lex.curPos () in\n\ + \ let () = setPeeked (Some (tok, loc)) in\n\ + \ tok\n\ + \ end)\n\ + \ in aux ()\n\n\ + \ implicit `loc\n\ + \ let loc_shift l = l :: `loc\n\n\ + \ let loc_reduce {E_err, E_st, R_lex,\n\ + \ `error : Parsing.Error E_err,\n\ + \ `st : State2 E_st,\n\ + \ `lex : Parsing.Lex R_lex Tok} n =\n\ + \ let (aux : Int ->[E_err, E_st|R_lex] List (Pair Parsing.Pos Parsing.Pos)) = \n\ + \ (fn (n : Int) =>\n\ + \ if n == 0 then (getFallback (), getFallback ()) :: `loc\n\ + \ else\n\ + \ (let rec skip (n : Int) xs =\n\ + \ if n == 0 then xs\n\ + \ else skip (n - 1)\n\ + \ (List.tlErr {`onError = (fn () => Parsing.error \"tl\")}\n\ + \ xs) in\n\ + \ let l = (fst (List.nthErr {`onError = (fn () => Parsing.error \"nth\")}\n\ + \ `loc\n\ + \ (n - 1)),\n\ + \ snd (List.hdErr {`onError = (fn () => Parsing.error \"hd\")}\n\ + \ `loc)) in\n\ + \ l :: skip n `loc))\n\ + \ in aux n\n\n\ + \ implicit `lex {R_lex} : Parsing.Lex R_lex Tok\n\ + \ implicit `st {E_st} : State2 E_st\n\ + \ implicit `error {E_err} : Parsing.Error E_err\n\ \n" ;; @@ -389,8 +389,8 @@ struct Format.fprintf f "pub let %s {`lex} () =\n\ - \ handle `error = Parsing.Error (effect x / _ => Utils.Left x)\n\ - \ return x => Utils.Right x in\n\ + \ handle `error = Parsing.Error (effect x / _ => Left x)\n\ + \ return x => Right x in\n\ \ handle `st = State2\n\ \ { setPeeked = effect p / r => fn _ f => r () p f\n\ \ , getPeeked = effect () / r => fn p f => r p p f\n\ @@ -420,6 +420,7 @@ struct f "import Parsing\n\ import Utils\n\ + import List\n\ implicit `error {E_err} : Parsing.Error E_err\n\ %t\n\n\ %tdata State2 (effect E) = State2 of\n\ diff --git a/test/calc/Parsing.fram b/test/calc/Parsing.fram index 6ebff24..5704de1 100644 --- a/test/calc/Parsing.fram +++ b/test/calc/Parsing.fram @@ -1,3 +1,6 @@ +(* This file should be placed in the same directory as the generated + * parser *) + pub data Pos = Pos of { fname : String , lnum : Int @@ -18,5 +21,9 @@ pub method curPos {R, Tok, self = Lex {curPos} : Lex R Tok} = curPos pub data Error (effect E) = Error of ({type X} -> String ->[E] X) pub method parseError {E, self = Error f : Error E} = f +(** Error-reporting function. Use this function to report errors + in semantic actions. If an error is reported, the result + returned by the parser will be the passed string wrapped in + a `Left` constructor. *) pub let error {E, `error : Error E} s = `error.parseError s diff --git a/test/calc/Utils.fram b/test/calc/Utils.fram index ba777b5..1aa93cf 100644 --- a/test/calc/Utils.fram +++ b/test/calc/Utils.fram @@ -1,6 +1,9 @@ -pub data Either X Y = - | Left of X - | Right of Y +(* This file contains useful functions that arguably (i.e., in comparison + * with OCaml) belong in the standard library but have not been included + * in it yet. It should eventually fall out of use. + * + * Nonetheless, as long as it hasn't, it should be placed in the same directory + * as the generated parser. *) pub let optionGet {`re : {type X} -> Unit ->[|_] X} opt = match opt with @@ -8,36 +11,3 @@ pub let optionGet {`re : {type X} -> Unit ->[|_] X} opt = | Some x => x end -pub let nth_opt xs (n : Int) = - let rec aux xs (n : Int) = - match xs with - | [] => None - | x :: xs => - if n == 0 then - Some x - else aux xs (n - 1) - end - in if n < 0 then None else aux xs n - -pub let hd {`re : {type X} -> Unit ->[|_] X} xs = - match xs with - | [] => `re () - | x :: _ => x - end - -pub let tl {`re : {type X} -> Unit ->[|_] X} xs = - match xs with - | [] => `re () - | _ :: xs => xs - end - -pub let nth {`re : {type X} -> Unit ->[|_] X} xs (n : Int) = - let rec aux xs (n : Int) = - match xs with - | [] => `re () - | x :: xs => - if n == 0 then x - else aux xs (n - 1) - end - in if n < 0 then `re () else aux xs n - From b7c4f16f83332acf1536c7b4cf456e092994878d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Miko=C5=82aj=20Swoboda?= <331319@uwr.edu.pl> Date: Tue, 11 Jun 2024 13:23:00 +0200 Subject: [PATCH 3/8] Remove duplicates of Parsing and Utils from test/calc --- test/calc/Parsing.fram | 29 ----------------------------- test/calc/Utils.fram | 13 ------------- 2 files changed, 42 deletions(-) delete mode 100644 test/calc/Parsing.fram delete mode 100644 test/calc/Utils.fram diff --git a/test/calc/Parsing.fram b/test/calc/Parsing.fram deleted file mode 100644 index 5704de1..0000000 --- a/test/calc/Parsing.fram +++ /dev/null @@ -1,29 +0,0 @@ -(* This file should be placed in the same directory as the generated - * parser *) - -pub data Pos = Pos of - { fname : String - , lnum : Int - , bol : Int - , cnum : Int } - -pub let dummyPos = Pos {fname = "", lnum = 0, bol = 0, cnum = 0-1} - -pub data Lex R Tok = Lex of - { token : Unit ->[|R] Tok - , startPos : Unit ->[|R] Pos - , curPos : Unit -> [|R] Pos } - -pub method token {R, Tok, self = Lex {token} : Lex R Tok} = token -pub method startPos {R, Tok, self = Lex {startPos} : Lex R Tok} = startPos -pub method curPos {R, Tok, self = Lex {curPos} : Lex R Tok} = curPos - -pub data Error (effect E) = Error of ({type X} -> String ->[E] X) -pub method parseError {E, self = Error f : Error E} = f - -(** Error-reporting function. Use this function to report errors - in semantic actions. If an error is reported, the result - returned by the parser will be the passed string wrapped in - a `Left` constructor. *) -pub let error {E, `error : Error E} s = `error.parseError s - diff --git a/test/calc/Utils.fram b/test/calc/Utils.fram deleted file mode 100644 index 1aa93cf..0000000 --- a/test/calc/Utils.fram +++ /dev/null @@ -1,13 +0,0 @@ -(* This file contains useful functions that arguably (i.e., in comparison - * with OCaml) belong in the standard library but have not been included - * in it yet. It should eventually fall out of use. - * - * Nonetheless, as long as it hasn't, it should be placed in the same directory - * as the generated parser. *) - -pub let optionGet {`re : {type X} -> Unit ->[|_] X} opt = - match opt with - | None => `re () - | Some x => x - end - From 8d6d8d20bbf7e57bb123bfbfb74ca2dfcbdce4b7 Mon Sep 17 00:00:00 2001 From: Adam Szeruda <32493319+adampsz@users.noreply.github.com> Date: Tue, 3 Dec 2024 15:39:17 +0100 Subject: [PATCH 4/8] Replace backtick with tilde in implicit parameters --- framtools/Parsing.fram | 9 +- framtools/Utils.fram | 7 +- lib/CodeGen.ml | 197 ++++++++++++++++++++--------------------- 3 files changed, 105 insertions(+), 108 deletions(-) diff --git a/framtools/Parsing.fram b/framtools/Parsing.fram index 5704de1..d9dc2b8 100644 --- a/framtools/Parsing.fram +++ b/framtools/Parsing.fram @@ -14,9 +14,9 @@ pub data Lex R Tok = Lex of , startPos : Unit ->[|R] Pos , curPos : Unit -> [|R] Pos } -pub method token {R, Tok, self = Lex {token} : Lex R Tok} = token -pub method startPos {R, Tok, self = Lex {startPos} : Lex R Tok} = startPos -pub method curPos {R, Tok, self = Lex {curPos} : Lex R Tok} = curPos +pub method token {R, Tok, self = Lex {token} : Lex R Tok} = token +pub method startPos {R, Tok, self = Lex {startPos} : Lex R Tok} = startPos +pub method curPos {R, Tok, self = Lex {curPos} : Lex R Tok} = curPos pub data Error (effect E) = Error of ({type X} -> String ->[E] X) pub method parseError {E, self = Error f : Error E} = f @@ -25,5 +25,4 @@ pub method parseError {E, self = Error f : Error E} = f in semantic actions. If an error is reported, the result returned by the parser will be the passed string wrapped in a `Left` constructor. *) -pub let error {E, `error : Error E} s = `error.parseError s - +pub let error {E, ~error : Error E} s = ~error.parseError s diff --git a/framtools/Utils.fram b/framtools/Utils.fram index 1aa93cf..6fd97b0 100644 --- a/framtools/Utils.fram +++ b/framtools/Utils.fram @@ -1,13 +1,12 @@ (* This file contains useful functions that arguably (i.e., in comparison * with OCaml) belong in the standard library but have not been included * in it yet. It should eventually fall out of use. - * + * * Nonetheless, as long as it hasn't, it should be placed in the same directory * as the generated parser. *) -pub let optionGet {`re : {type X} -> Unit ->[|_] X} opt = +pub let optionGet {~re : {type X} -> Unit ->[|_] X} opt = match opt with - | None => `re () + | None => ~re () | Some x => x end - diff --git a/lib/CodeGen.ml b/lib/CodeGen.ml index db7f68b..75845e9 100644 --- a/lib/CodeGen.ml +++ b/lib/CodeGen.ml @@ -2,15 +2,15 @@ module IntMap = Map.Make (Int) module SymbolMap = Map.Make (Automaton.Symbol) let action_lib = - " implicit `loc\n\ - \ implicit `error {E_err} : Parsing.Error E_err\n\n\ + " implicit ~loc\n\ + \ implicit ~error {E_err} : Parsing.Error E_err\n\n\ \ pub let _kw_endpos _ =\n\ - \ match `loc with\n\ + \ match ~loc with\n\ \ | l :: _ => snd l\n\ \ | [] => Parsing.dummyPos\n\ \ end\n\n\ \ pub let _kw_startpos (n : Int) =\n\ - \ match List.nth `loc (n - 1) with\n\ + \ match List.nth ~loc (n - 1) with\n\ \ | Some l => fst l\n\ \ | None => _kw_endpos n\n\ \ end\n\n\ @@ -19,71 +19,70 @@ let action_lib = \ pub let _kw_endofs _ = Parsing.error \"unimplemented: $endofs\"\n\ \ pub let _kw_symbolstartofs _ = Parsing.error \"unimplemented: $symbolstartofs\"\n\ \ pub let _kw_loc n = _kw_startpos n, _kw_endpos n\n\ - \ pub let _kw_sloc _ = Parsing.error \"unimplemented: $sloc\" - \n" + \ pub let _kw_sloc _ = Parsing.error \"unimplemented: $sloc\"\n\ + \ \n" ;; let state_lib = - " let lexfun {E_err, E_st, R_lex,\n\ - \ `error : Parsing.Error E_err,\n\ - \ `st : State2 E_st,\n\ - \ `lex : Parsing.Lex R_lex Tok} () = \n\ - \ let (aux : Unit ->[E_err, E_st|R_lex] Tok) = \n\ - \ fn () => `lex.token ()\n\ - \ in aux ()\n\n\ - \ let shift {E_err, E_st, R_lex,\n\ - \ `error : Parsing.Error E_err,\n\ - \ `st : State2 E_st,\n\ - \ `lex : Parsing.Lex R_lex Tok} () = \n\ - \ let (aux : Unit ->[E_err, E_st|R_lex] Pair Tok (Pair Parsing.Pos Parsing.Pos)) = \n\ - \ (fn () => \n\ - \ let sym = Utils.optionGet {`re = (fn () => Parsing.error \"option\")}\n\ - \ (getPeeked ()) in\n\ - \ let () = setPeeked None in\n\ - \ let () = setFallback (`lex.curPos ()) in\n\ - \ sym)\n\ - \ in aux ()\n\n\ - \ let lookahead {E_err, E_st, R_lex,\n\ - \ `error : Parsing.Error E_err,\n\ - \ `st : State2 E_st,\n\ - \ `lex : Parsing.Lex R_lex Tok} () = \n\ - \ let (aux : Unit ->[E_err, E_st|R_lex] Tok) = \n\ - \ (fn () => \n\ - \ match getPeeked () with\n\ - \ | Some (tok, _) => tok\n\ - \ | None =>\n\ - \ let tok = lexfun () in\n\ - \ let loc = `lex.startPos (), `lex.curPos () in\n\ - \ let () = setPeeked (Some (tok, loc)) in\n\ - \ tok\n\ - \ end)\n\ - \ in aux ()\n\n\ - \ implicit `loc\n\ - \ let loc_shift l = l :: `loc\n\n\ - \ let loc_reduce {E_err, E_st, R_lex,\n\ - \ `error : Parsing.Error E_err,\n\ - \ `st : State2 E_st,\n\ - \ `lex : Parsing.Lex R_lex Tok} n =\n\ - \ let (aux : Int ->[E_err, E_st|R_lex] List (Pair Parsing.Pos Parsing.Pos)) = \n\ - \ (fn (n : Int) =>\n\ - \ if n == 0 then (getFallback (), getFallback ()) :: `loc\n\ - \ else\n\ - \ (let rec skip (n : Int) xs =\n\ - \ if n == 0 then xs\n\ - \ else skip (n - 1)\n\ - \ (List.tlErr {`onError = (fn () => Parsing.error \"tl\")}\n\ - \ xs) in\n\ - \ let l = (fst (List.nthErr {`onError = (fn () => Parsing.error \"nth\")}\n\ - \ `loc\n\ - \ (n - 1)),\n\ - \ snd (List.hdErr {`onError = (fn () => Parsing.error \"hd\")}\n\ - \ `loc)) in\n\ - \ l :: skip n `loc))\n\ - \ in aux n\n\n\ - \ implicit `lex {R_lex} : Parsing.Lex R_lex Tok\n\ - \ implicit `st {E_st} : State2 E_st\n\ - \ implicit `error {E_err} : Parsing.Error E_err\n\ - \n" + " let lexfun {E_err, E_st, R_lex,\n\ + \ ~error : Parsing.Error E_err,\n\ + \ ~st : State2 E_st,\n\ + \ ~lex : Parsing.Lex R_lex Tok} () = \n\ + \ let (aux : Unit ->[E_err, E_st|R_lex] Tok) = \n\ + \ fn () => ~lex.token ()\n\ + \ in aux ()\n\n\ + \ let shift {E_err, E_st, R_lex,\n\ + \ ~error : Parsing.Error E_err,\n\ + \ ~st : State2 E_st,\n\ + \ ~lex : Parsing.Lex R_lex Tok} () = \n\ + \ let (aux : Unit ->[E_err, E_st|R_lex] Pair Tok (Pair Parsing.Pos Parsing.Pos)) = \n\ + \ (fn () => \n\ + \ let sym = Utils.optionGet {~re = (fn () => Parsing.error \"option\")}\n\ + \ (getPeeked ()) in\n\ + \ let () = setPeeked None in\n\ + \ let () = setFallback (~lex.curPos ()) in\n\ + \ sym)\n\ + \ in aux ()\n\n\ + \ let lookahead {E_err, E_st, R_lex,\n\ + \ ~error : Parsing.Error E_err,\n\ + \ ~st : State2 E_st,\n\ + \ ~lex : Parsing.Lex R_lex Tok} () = \n\ + \ let (aux : Unit ->[E_err, E_st|R_lex] Tok) = \n\ + \ (fn () => \n\ + \ match getPeeked () with\n\ + \ | Some (tok, _) => tok\n\ + \ | None =>\n\ + \ let tok = lexfun () in\n\ + \ let loc = ~lex.startPos (), ~lex.curPos () in\n\ + \ let () = setPeeked (Some (tok, loc)) in\n\ + \ tok\n\ + \ end)\n\ + \ in aux ()\n\n\ + \ implicit ~loc\n\ + \ let loc_shift l = l :: ~loc\n\n\ + \ let loc_reduce {E_err, E_st, R_lex,\n\ + \ ~error : Parsing.Error E_err,\n\ + \ ~st : State2 E_st,\n\ + \ ~lex : Parsing.Lex R_lex Tok} n =\n\ + \ let (aux : Int ->[E_err, E_st|R_lex] List (Pair Parsing.Pos Parsing.Pos)) = \n\ + \ (fn (n : Int) =>\n\ + \ if n == 0 then (getFallback (), getFallback ()) :: ~loc\n\ + \ else\n\ + \ (let rec skip (n : Int) xs =\n\ + \ if n == 0 then xs\n\ + \ else skip (n - 1)\n\ + \ (List.tlErr {~onError = (fn () => Parsing.error \"tl\")}\n\ + \ xs) in\n\ + \ let l = (fst (List.nthErr {~onError = (fn () => Parsing.error \"nth\")}\n\ + \ ~loc\n\ + \ (n - 1)),\n\ + \ snd (List.hdErr {~onError = (fn () => Parsing.error \"hd\")}\n\ + \ ~loc)) in\n\ + \ l :: skip n ~loc))\n\ + \ in aux n\n\n\ + \ implicit ~lex {R_lex} : Parsing.Lex R_lex Tok\n\ + \ implicit ~st {E_st} : State2 E_st\n\ + \ implicit ~error {E_err} : Parsing.Error E_err\n\n" ;; let iteri2 f xs ys = @@ -208,7 +207,7 @@ struct f "%t%s x = %t" (fun f -> write_cont_id f group idx) - (if S.locations then " {`loc}" else "") + (if S.locations then " {~loc}" else "") (fun f -> write_goto_call f state sym) ;; @@ -226,7 +225,7 @@ struct ;; let write_action_shift f state sym = - let write_loc_update f = Format.fprintf f " in\n let `loc = loc_shift _l" in + let write_loc_update f = Format.fprintf f " in\n let ~loc = loc_shift _l" in if S.comments then Format.fprintf f " (* Shift *)\n"; Format.fprintf f @@ -237,22 +236,21 @@ struct ;; let write_action_reduce f state lookahead i j = - let write_loc_update f n = - Format.fprintf f "\n in let `loc = loc_reduce %d" n - in + let write_loc_update f n = Format.fprintf f "\n in let ~loc = loc_reduce %d" n in if S.comments then Format.fprintf f " (* Reduce *)\n"; let group = List.nth (state.s_kernel @ state.s_closure) i in let n = List.length group.g_prefix and item = List.nth group.g_items j in - TermSet.iter (fun sym -> - Format.fprintf - f - " | %t =>\n let x =%t%t in\n %t x\n" - (fun f -> write_term_pattern f false sym) - (fun f -> write_semantic_action_call f group item) - (fun f -> if S.locations then write_loc_update f n) - (fun f -> write_cont_id f group i)) - lookahead + TermSet.iter + (fun sym -> + Format.fprintf + f + " | %t =>\n let x =%t%t in\n %t x\n" + (fun f -> write_term_pattern f false sym) + (fun f -> write_semantic_action_call f group item) + (fun f -> if S.locations then write_loc_update f n) + (fun f -> write_cont_id f group i)) + lookahead ;; let write_action f state lookahead = function @@ -362,7 +360,7 @@ struct f "%t%s%t%t =\n" (fun f -> write_state_id f id) - (if S.locations then " {`loc}" else "") + (if S.locations then " {~loc}" else "") (fun f -> write_arg_ids f (List.hd state.s_kernel).g_prefix) (fun f -> write_cont_ids f (fun _ -> true) state.s_kernel) ;; @@ -388,21 +386,20 @@ struct let write_entry f symbol id = Format.fprintf f - "pub let %s {`lex} () =\n\ - \ handle `error = Parsing.Error (effect x / _ => Left x)\n\ + "pub let %s {~lex} () =\n\ + \ handle ~error = Parsing.Error (effect x / _ => Left x)\n\ \ return x => Right x in\n\ - \ handle `st = State2\n\ + \ handle ~st = State2\n\ \ { setPeeked = effect p / r => fn _ f => r () p f\n\ \ , getPeeked = effect () / r => fn p f => r p p f\n\ \ , setFallback = effect f / r => fn p _ => r () p f\n\ \ , getFallback = effect () / r => fn p f => r f p f }\n\ \ return x => fn _ _ => x\n\ \ finally f => f None Parsing.dummyPos in\n\ - \ States.%t%s (fn x => x)\n\ - \n" + \ States.%t%s (fn x => x)\n\n" (nterm_name symbol) (fun f -> write_state_id f id) - (if S.locations then " {`loc = []}" else "") + (if S.locations then " {~loc = []}" else "") ;; let write f = @@ -421,32 +418,34 @@ struct "import Parsing\n\ import Utils\n\ import List\n\ - implicit `error {E_err} : Parsing.Error E_err\n\ + implicit ~error {E_err} : Parsing.Error E_err\n\ %t\n\n\ %tdata State2 (effect E) = State2 of\n\ - \ { setPeeked : Option (Pair Tok (Pair Parsing.Pos Parsing.Pos)) ->[E] Unit\n\ - \ , setFallback : Parsing.Pos ->[E] Unit\n\ - \ , getPeeked : Unit ->[E] Option (Pair Tok (Pair Parsing.Pos Parsing.Pos))\n\ - \ , getFallback : Unit ->[E] Parsing.Pos }\n\n\ + \ { setPeeked : Option (Pair Tok (Pair Parsing.Pos Parsing.Pos)) ->[E] Unit\n\ + \ , setFallback : Parsing.Pos ->[E] Unit\n\ + \ , getPeeked : Unit ->[E] Option (Pair Tok (Pair Parsing.Pos Parsing.Pos))\n\ + \ , getFallback : Unit ->[E] Parsing.Pos }\n\n\ method setPeeked {E, self = State2 {setPeeked} : State2 E} = setPeeked\n\ method getPeeked {E, self = State2 {getPeeked} : State2 E} = getPeeked\n\ method setFallback {E, self = State2 {setFallback} : State2 E} = setFallback\n\ method getFallback {E, self = State2 {getFallback} : State2 E} = getFallback\n\n\ - let setPeeked {E, `st : State2 E} p = `st.setPeeked p\n\ - let getPeeked {E, `st : State2 E} () = `st.getPeeked ()\n\ - let setFallback {E, `st : State2 E} f = `st.setFallback f\n\ - let getFallback {E, `st : State2 E} () = `st.getFallback ()\n\n\ + let setPeeked {E, ~st : State2 E} p = ~st.setPeeked p\n\ + let getPeeked {E, ~st : State2 E} () = ~st.getPeeked ()\n\ + let setFallback {E, ~st : State2 E} f = ~st.setFallback f\n\ + let getFallback {E, ~st : State2 E} () = ~st.getFallback ()\n\n\ module Actions\n\ %s%tend\n\n\ module States\n\ %s%tend\n\n\ - %t" + %t" (fun f -> write_string f A.automaton.a_header) (fun f -> write_term_type f G.symbols) action_lib - (fun f -> IntMap.iter (write_semantic_action f) A.automaton.a_actions) (* FIXME: rec blocks are not indented *) + (fun f -> IntMap.iter (write_semantic_action f) A.automaton.a_actions) + (* FIXME: rec blocks are not indented *) state_lib - (fun f -> IntMap.bindings A.automaton.a_states |> state_letrec (write_state f)) (* FIXME: rec blocks are not indented *) + (fun f -> IntMap.bindings A.automaton.a_states |> state_letrec (write_state f)) + (* FIXME: rec blocks are not indented *) (fun f -> List.iter (write_entry f) A.automaton.a_starting) ;; end From afa5a74c25c65a6932f394e2d6e6dc9458e77e00 Mon Sep 17 00:00:00 2001 From: Adam Szeruda <32493319+adampsz@users.noreply.github.com> Date: Tue, 3 Dec 2024 15:40:49 +0100 Subject: [PATCH 5/8] Remove ocaml-specific tests --- test/Broken.mly | 29 ---- test/bench/.gitignore | 3 - test/bench/Lexer.mll | 17 --- test/bench/Makefile | 46 ------- test/bench/Parser.mly | 59 --------- test/bench/main.ml | 73 ---------- test/calc/ParserBase.mly | 43 ------ test/calc/ParserPrec.mly | 39 ------ test/calc/TestLexer.fram | 42 ------ test/calc/dune | 20 --- test/lua/.gitignore | 1 - test/lua/Ast.ml | 154 --------------------- test/lua/Lexer.mll | 153 --------------------- test/lua/Parser.mly | 279 --------------------------------------- test/lua/README.md | 13 -- test/lua/dune | 32 ----- test/lua/input.sh | 44 ------ test/lua/main.ml | 53 -------- 18 files changed, 1100 deletions(-) delete mode 100644 test/Broken.mly delete mode 100644 test/bench/.gitignore delete mode 100644 test/bench/Lexer.mll delete mode 100644 test/bench/Makefile delete mode 100644 test/bench/Parser.mly delete mode 100644 test/bench/main.ml delete mode 100644 test/calc/ParserBase.mly delete mode 100644 test/calc/ParserPrec.mly delete mode 100644 test/calc/TestLexer.fram delete mode 100644 test/calc/dune delete mode 100644 test/lua/.gitignore delete mode 100644 test/lua/Ast.ml delete mode 100644 test/lua/Lexer.mll delete mode 100644 test/lua/Parser.mly delete mode 100644 test/lua/README.md delete mode 100644 test/lua/dune delete mode 100644 test/lua/input.sh delete mode 100644 test/lua/main.ml diff --git a/test/Broken.mly b/test/Broken.mly deleted file mode 100644 index 67d0aa6..0000000 --- a/test/Broken.mly +++ /dev/null @@ -1,29 +0,0 @@ -(* Broken grammar, used to show errors and warnings *) - -%{ - -%} - -%token TOK TOK -%start broken_start -%start start start - -%left TOK -%left TOK - -%% - - -start: - | broken_nterm BROKEN_TERM { () } - | start %prec broken_prec { () } - | start %prec BROKEN_PREC { () } - | conflict TOK { () } -; - -start:; - -conflict: - | (* reduce *) { () } - | TOK (* shift *) { () } -; diff --git a/test/bench/.gitignore b/test/bench/.gitignore deleted file mode 100644 index e9a74df..0000000 --- a/test/bench/.gitignore +++ /dev/null @@ -1,3 +0,0 @@ -Lexer.ml -Parser*.ml -main.*.exe diff --git a/test/bench/Lexer.mll b/test/bench/Lexer.mll deleted file mode 100644 index 1895897..0000000 --- a/test/bench/Lexer.mll +++ /dev/null @@ -1,17 +0,0 @@ -{ - open Parser -} - -rule token = parse - | [' ' '\t' '\n' '\r'] { token lexbuf } - | ['0'-'9']+ as i { INT (int_of_string i) } - | '+' { PLUS } - | '-' { MINUS} - | '*' { STAR } - | '/' { SLASH } - | '%' { PERCENT } - | '^' { CARET } - | '(' { LPAREN } - | ')' { RPAREN } - | eof { EOF } - | _ { failwith "error" } diff --git a/test/bench/Makefile b/test/bench/Makefile deleted file mode 100644 index 0a968c7..0000000 --- a/test/bench/Makefile +++ /dev/null @@ -1,46 +0,0 @@ -OCAMLC=ocamlopt -OCAMLFLAGS=-O3 -unbox-closures -MENHIRFLAGS= - -.PHONY: bench -bench: main.yacc.exe main.menhir.exe main.cpspg.exe - @echo 'math:' - @echo -n ' ocamlyacc: '; ./main.yacc.exe math - @echo -n ' menhir: '; ./main.menhir.exe math - @echo -n ' cpspg: '; ./main.cpspg.exe math - @echo 'dyck:' - @echo -n ' ocamlyacc: '; ./main.yacc.exe dyck - @echo -n ' menhir: '; ./main.menhir.exe dyck - @echo -n ' cpspg: '; ./main.cpspg.exe dyck - @echo 'leftrec:' - @echo -n ' ocamlyacc: '; ./main.yacc.exe leftrec - @echo -n ' menhir: '; ./main.menhir.exe leftrec - @echo -n ' cpspg: '; ./main.cpspg.exe leftrec - @echo 'rightrec:' - @echo -n ' ocamlyacc: '; ./main.yacc.exe rightrec - @echo -n ' menhir: '; ./main.menhir.exe rightrec - @echo -n ' cpspg: '; ./main.cpspg.exe rightrec - -.PHONY: clean -clean: - rm -f *.cmi *.cmx *.o - rm -f Lexer.ml Parser.*.ml main.*.exe - -Lexer.ml: Lexer.mll - ocamllex $^ - -Parser.yacc.ml: Parser.mly - ocamlyacc -b $(basename $@) $^ - rm $(basename $@).mli - -Parser.menhir.ml: Parser.mly - menhir $(MENHIRFLAGS) -b $(basename $@) $^ - rm $(basename $@).mli - -Parser.cpspg.ml: Parser.mly - dune exec -- cpspg --readable --no-locations $^ -o $@ - -main.%.exe: Parser.%.ml Lexer.ml main.ml - cp Parser.$(*F).ml Parser.ml - $(OCAMLC) $(OCAMLFLAGS) -I +unix unix.cmxa Parser.ml Lexer.ml main.ml -o $@ - diff --git a/test/bench/Parser.mly b/test/bench/Parser.mly deleted file mode 100644 index 62977f6..0000000 --- a/test/bench/Parser.mly +++ /dev/null @@ -1,59 +0,0 @@ -%{ - -(* Used to disable optimizations inside semantic actions - TODO: is there a proper way to do it? *) -external blackbox: int -> int = "%identity" -let blackbox2 a b = blackbox a lxor blackbox b - -%} - -%token INT -%token PLUS MINUS SLASH STAR PERCENT CARET LPAREN RPAREN EOF -%type math -%type dyck leftrec rightrec -%type expr -%type parens left right -%start math dyck leftrec rightrec - -%left PLUS MINUS -%left SLASH STAR PERCENT -%nonassoc UMINUS -%right CARET - -%% - -math: expr EOF { blackbox $1 }; - -expr: - | expr PLUS expr { blackbox2 $1 $3 } - | expr MINUS expr { blackbox2 $1 $3 } - | expr STAR expr { blackbox2 $1 $3 } - | expr SLASH expr { blackbox2 $1 $3 } - | expr PERCENT expr { blackbox2 $1 $3 } - | expr CARET expr { blackbox2 $1 $3 } - - | MINUS expr %prec UMINUS { blackbox $2 } - - | LPAREN expr RPAREN { blackbox $2 } - | INT { blackbox $1 } -; - -dyck: parens EOF { () }; - -parens: - | { () } - | LPAREN parens RPAREN parens { () } -; - -leftrec: left EOF { () }; -rightrec: right EOF { () }; - -left: - | { () } - | left PLUS { () } -; - -right: - | { () } - | PLUS right { () } -; diff --git a/test/bench/main.ml b/test/bench/main.ml deleted file mode 100644 index 143ee92..0000000 --- a/test/bench/main.ml +++ /dev/null @@ -1,73 +0,0 @@ -let rec gen_math depth f = - let gen = gen_math (depth - 1) in - match Random.int 10 with - | _ when depth = 0 -> Format.fprintf f "%d" (Random.int 100) - | 0 -> Format.fprintf f "%t + %t" gen gen - | 1 -> Format.fprintf f "%t - %t" gen gen - | 2 -> Format.fprintf f "%t * %t" gen gen - | 3 -> Format.fprintf f "%t / %t" gen gen - | 4 -> Format.fprintf f "%t %% %t" gen gen - | 5 -> Format.fprintf f "%t ^ %t" gen gen - | 6 -> Format.fprintf f "-%t" gen - | _ -> Format.fprintf f "(%t)" gen -;; - -let rec gen_dyck depth f = - let gen = gen_dyck (depth - 1) in - if depth > 0 then Format.fprintf f "(%t)%t" gen gen -;; - -let gen_math depth = Format.asprintf "%t" (gen_math depth) -let gen_dyck depth = Format.asprintf "%t" (gen_dyck depth) -let gen_plus depth = String.make (Int.shift_left 1 depth) '+' - -let rec read_to_end lexfun lexbuf acc = - match lexfun lexbuf with - | Parser.EOF -> List.rev (Parser.EOF :: acc) - | tok -> read_to_end lexfun lexbuf (tok :: acc) -;; - -let read_to_end lexfun lexbuf = read_to_end lexfun lexbuf [] - -let lexfun_of_list xs = - let xs = ref xs in - fun _ -> - match !xs with - | [] -> Parser.EOF - | x :: tail -> - xs := tail; - x -;; - -let gen_lex gen depth = - let input = gen depth in - let lexbuf = Lexing.from_string input in - let tokens = read_to_end Lexer.token lexbuf in - fun () -> lexfun_of_list tokens, lexbuf -;; - -let bench gen fn depth n m = - Random.init (Unix.gettimeofday () |> int_of_float); - let total = ref 0.0 in - for i = 1 to n do - let lex = gen_lex gen depth in - let start = Unix.gettimeofday () in - for j = 1 to m do - let lexfun, lexbuf = lex () in - fn lexfun lexbuf |> ignore - done; - let finish = Unix.gettimeofday () in - total := !total +. (finish -. start); - Printf.eprintf ".%!" - done; - Printf.printf " %fs (%fs/it)\n" !total (!total /. float_of_int (n * m)) -;; - -let _ = - match Sys.argv with - | [| _; "math" |] -> bench gen_math Parser.math 20 100 10 - | [| _; "dyck" |] -> bench gen_dyck Parser.dyck 15 100 10 - | [| _; "leftrec" |] -> bench gen_plus Parser.leftrec 15 100 10 - | [| _; "rightrec" |] -> bench gen_plus Parser.rightrec 15 100 10 - | _ -> failwith "usage: main " -;; diff --git a/test/calc/ParserBase.mly b/test/calc/ParserBase.mly deleted file mode 100644 index 62d3db6..0000000 --- a/test/calc/ParserBase.mly +++ /dev/null @@ -1,43 +0,0 @@ -%{ -let fail () = Parsing.error "arithmetic error" - -let pow {`re : {type X} -> Unit ->[|_] X} = - let rec aux a (n : Int) = - if n == 0 then 1 - else if n == 1 then a - else (let (b : Int) = aux a (n / 2) in - b * b * (if n % 2 == 0 then 1 else a)) - in aux - -%} - -%token INT -%token PLUS MINUS SLASH STAR PERCENT CARET LPAREN RPAREN EOF -%start main - -%% - -main: x=expr EOF { x }; - -expr: - | l=expr PLUS r=term { let (l : Int) = l in l + r } - | l=expr MINUS r=term { let (l : Int) = l in l - r } - | x=term { x } -; - -term: - | l=term STAR r=factor { let (l : Int) = l in l * r } - | l=term SLASH r=factor { let (l : Int) = l in let `re = fail in l / r } - | l=term PERCENT r=factor { let (l : Int) = l in let `re = fail in l % r } - | x=factor { x } -; - -factor: - | l=base CARET r=factor { let `re = fail in pow l r } - | x=base { x } -; - -base: - | x=INT { x } - | LPAREN x=expr RPAREN { x } -; diff --git a/test/calc/ParserPrec.mly b/test/calc/ParserPrec.mly deleted file mode 100644 index 85d0193..0000000 --- a/test/calc/ParserPrec.mly +++ /dev/null @@ -1,39 +0,0 @@ -%{ -let fail () = Parsing.error "arithmetic error" - -let pow {`re : {type X} -> Unit ->[|_] X} = - let rec aux a (n : Int) = - if n == 0 then 1 - else if n == 1 then a - else (let (b : Int) = aux a (n / 2) in - b * b * (if n % 2 == 0 then 1 else a)) - in aux - -%} - -%token INT -%token PLUS MINUS SLASH STAR PERCENT CARET LPAREN RPAREN EOF -%start main - -%left PLUS MINUS -%left SLASH STAR PERCENT -%nonassoc UMINUS -%right CARET - -%% - -main: x=expr EOF { x }; - -expr: - | l=expr PLUS r=expr { let (l : Int) = l in l + r } - | l=expr MINUS r=expr { let (l : Int) = l in l - r } - | l=expr STAR r=expr { let (l : Int) = l in l * r } - | l=expr SLASH r=expr { let (l : Int) = l in let `re = fail in l / r } - | l=expr PERCENT r=expr { let (l : Int) = l in let `re = fail in l % r } - | l=expr CARET r=expr { let `re = fail in pow l r } - - | MINUS x=expr %prec UMINUS { 0 - x } - - | LPAREN x=expr RPAREN { x } - | x=INT { x } -; diff --git a/test/calc/TestLexer.fram b/test/calc/TestLexer.fram deleted file mode 100644 index 343dc9d..0000000 --- a/test/calc/TestLexer.fram +++ /dev/null @@ -1,42 +0,0 @@ -import List -import open CalcParser -import Parsing - -module Feeder - pub let withFeeder {Tok} - (xs : List Tok) - (eof : Tok) - (f : {R} -> Parsing.Lex R Tok -> [|R] _) = - handle lex = Parsing.Lex - { token = effect () / r => - fn ys => - match ys with - | [] => r eof ys - | y :: ys => r y ys - end - , curPos = effect () / r => fn ys => r Parsing.dummyPos ys - , startPos = effect () / r => fn ys => r Parsing.dummyPos ys } - return x => fn _ => x - finally f => f xs - in f lex -end - -let tests = - [[INT 2, PLUS, INT 3], - [INT 8, STAR, INT 3, STAR, INT 89, PLUS, INT 1], - [LPAREN, INT 9, PLUS, INT 1, RPAREN, SLASH, INT 5], - [INT 4, SLASH, INT 0], - [INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, PERCENT, INT 5], - [LPAREN, INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, RPAREN, PERCENT, INT 5]] - -let execTest xs = - let res = Feeder.withFeeder xs - EOF - (fn lex => main {`lex = lex} ()) in - match res with - | Left s => printStrLn s - | Right n => printInt n ; printStrLn "" - end - -let _ = List.iter execTest tests - diff --git a/test/calc/dune b/test/calc/dune deleted file mode 100644 index d86f28f..0000000 --- a/test/calc/dune +++ /dev/null @@ -1,20 +0,0 @@ -(executable - (name calc)) - -(ocamllex Lexer) - -(rule - ; Change this rule to use a different parser - (copy ParserPrec.ml Parser.ml)) - -(rule - (deps ParserBase.mly) - (target ParserBase.ml) - (action - (run cpspg -o %{target} %{deps}))) - -(rule - (deps ParserPrec.mly) - (target ParserPrec.ml) - (action - (run cpspg -o %{target} %{deps}))) diff --git a/test/lua/.gitignore b/test/lua/.gitignore deleted file mode 100644 index 1e7b979..0000000 --- a/test/lua/.gitignore +++ /dev/null @@ -1 +0,0 @@ -input.lua diff --git a/test/lua/Ast.ml b/test/lua/Ast.ml deleted file mode 100644 index 2d58cf4..0000000 --- a/test/lua/Ast.ml +++ /dev/null @@ -1,154 +0,0 @@ -type unop = - | UnopNeg - | UnopBitNot - | UnopLength - | UnopNot - -type binop = - | BinopAdd - | BinopSub - | BinopMul - | BinopDiv - | BinopIDiv - | BinopMod - | BinopExp - | BinopBitAnd - | BinopBitOr - | BinopBitXor - | BinopBitShr - | BinopBitShl - | BinopEq - | BinopNe - | BinopLt - | BinopLe - | BinopGt - | BinopGe - | BinopAnd - | BinopOr - | BinopConcat - -type funcname = - | Func of { base : string list } - | FuncMethod of - { base : string list - ; name : string - } - -type parlist = - | Parlist of - { params : string list - ; variadic : bool - } - -type call = - | Call of - { callee : exp - ; args : exp list - } - | CallMethod of - { callee : exp - ; name : string - ; args : exp list - } - -and field = - | Field of { value : exp } - | FieldIndex of - { index : exp - ; value : exp - } - | FieldName of - { name : string - ; value : exp - } - -and var = - | VarName of string - | VarIndex of - { target : exp - ; index : exp - } - | VarField of - { target : exp - ; field : string - } - -and exp = - | ExpNil - | ExpTrue - | ExpFalse - | ExpDots - | ExpInt of string - | ExpNumeral of string - | ExpString of string - | ExpTable of field list - | ExpVar of var - | ExpCall of call - | ExpBinop of - { l : exp - ; r : exp - ; op : binop - } - | ExpUnop of - { x : exp - ; op : unop - } - | ExpFunction of - { params : parlist - ; body : block - } - -and stat = - | StatEmpty - | StatBlock of block - | StatLabel of string - | StatGoto of string - | StatCall of call - | StatReturn of exp list - | StatBreak - | StatAssign of - { vars : var list - ; value : exp list - } - | StatFor of - { name : string - ; init : exp - ; limit : exp - ; step : exp option - ; body : block - } - | StatGenericFor of - { vars : string list - ; value : exp list - ; body : block - } - | StatIf of - { arms : (exp * block) list - ; alt : block option - } - | StatWhile of - { cond : exp - ; body : block - } - | StatRepeat of - { body : block - ; cond : exp - } - | StatFuncLocal of - { name : funcname - ; params : parlist - ; body : block - } - | StatFuncNamed of - { name : funcname - ; params : parlist - ; body : block - } - | StatLocal of - { vars : (string * string option) list - ; value : exp list option - } - -and block = stat list - -type chunk = block diff --git a/test/lua/Lexer.mll b/test/lua/Lexer.mll deleted file mode 100644 index ff18c98..0000000 --- a/test/lua/Lexer.mll +++ /dev/null @@ -1,153 +0,0 @@ -{ - open Parser - open Lexing - - let name_or_kw = function - | "and" -> KW_AND - | "break" -> KW_BREAK - | "do" -> KW_DO - | "else" -> KW_ELSE - | "elseif" -> KW_ELSEIF - | "end" -> KW_END - | "false" -> KW_FALSE - | "for" -> KW_FOR - | "function" -> KW_FUNCTION - | "goto" -> KW_GOTO - | "if" -> KW_IF - | "in" -> KW_IN - | "local" -> KW_LOCAL - | "nil" -> KW_NIL - | "not" -> KW_NOT - | "or" -> KW_OR - | "repeat" -> KW_REPEAT - | "return" -> KW_RETURN - | "then" -> KW_THEN - | "true" -> KW_TRUE - | "until" -> KW_UNTIL - | "while" -> KW_WHILE - | id -> NAME id - ;; - - let escape = function - | 'a' -> '\x07' - | 'b' -> '\b' - | 'f' -> '\x0c' - | 'n' -> '\n' - | 'r' -> '\r' - | 't' -> '\t' - | 'v' -> '\x0b' - | '\\' -> '\\' - | '\"' -> '\"' - | '\'' -> '\'' - | '\n' -> '\n' - | _ -> assert false - ;; - - let buffered lexbuf f = - let pos = lexbuf.lex_start_p - and buf = Buffer.create 64 in - f buf lexbuf; - lexbuf.lex_start_p <- pos; - Buffer.contents buf - ;; -} - -let space = [' ' '\t' '\r' '\x0b'] -let name = ['a'-'z' 'A'-'Z' '_'] ['a'-'z' 'A'-'Z' '0'-'9' '_']* - -let digits = ['0'-'9']+ -let hexdigits = ['0'-'9' 'a'-'f' 'A'-'F']+ - -rule token = parse - | eof { EOF } - | space+ { token lexbuf } - | '\n' { new_line lexbuf; token lexbuf } - - | "--" { comment lexbuf; token lexbuf } - | "--" '[' ('='* as l) '[' { let _ = buffered lexbuf (longstring (String.length l) false) in token lexbuf } - - | name as n { name_or_kw n } - - | "+" { P_PLUS } - | "-" { P_MINUS } - | "*" { P_STAR } - | "/" { P_SLASH } - | "%" { P_PERCENT } - | "^" { P_HAT } - | "#" { P_LENGTH } - | "~" { P_TILDE } - | "&" { P_AND } - | "|" { P_OR } - | "<<" { P_SHL } - | ">>" { P_SHR } - | "//" { P_IDIV } - | "==" { P_EQ } - | "~=" { P_NE } - | "<=" { P_LE } - | ">=" { P_GE } - | "<" { P_LT } - | ">" { P_GT } - | "=" { P_ASSIGN } - | "(" { P_LPAREN } - | ")" { P_RPAREN } - | "{" { P_LBRACE } - | "}" { P_RBRACE } - | "[" { P_LBRACKET } - | "]" { P_RBRACKET } - | "::" { P_DBCOLON } - | ";" { P_SEMI } - | ":" { P_COLON } - | "," { P_COMMA } - | "." { P_DOT } - | ".." { P_CONCAT } - | "..." { P_DOTS } - - | digits as n { INT n } - | '0' ['x' 'X'] hexdigits as n { INT n } - - | digits? ('.' digits?) (['e' 'E'] ['+' '-']? digits)? - | digits? ('.' digits?)? (['e' 'E'] ['+' '-']? digits) - | '0' ['x' 'X'] hexdigits? ('.' hexdigits?) (['p' 'P'] ['+' '-']? hexdigits)? - | '0' ['x' 'X'] hexdigits? ('.' hexdigits?)? (['p' 'P'] ['+' '-']? hexdigits) as n - { NUMERAL n } - - | "\"" { STRING (buffered lexbuf (string '\"')) } - | "\'" { STRING (buffered lexbuf (string '\'')) } - - | '[' ('='* as l) '[' { STRING (buffered lexbuf (longstring (String.length l) false)) } - -and string e buf = parse - | "\\" (['a' 'b' 'f' 'n' 'r' 't' 'v' '\\' '\"' '\''] as c) - { Buffer.add_char buf (escape c); string e buf lexbuf } - | "\\" ('\n' as c) - { Buffer.add_char buf (escape c); new_line lexbuf; string e buf lexbuf } - - | "\\z" { string_space lexbuf; string e buf lexbuf } - - | "\"" as c { if c <> e then (Buffer.add_char buf c; string e buf lexbuf) } - | "\'" as c { if c <> e then (Buffer.add_char buf c; string e buf lexbuf) } - | '\n' as c { Buffer.add_char buf c; new_line lexbuf; string e buf lexbuf } - - | _ as c { Buffer.add_char buf c; string e buf lexbuf } - | eof { failwith "unterminated string" } - -and longstring l b buf = parse - | '='* ']' as c - { if b && String.length c - 1 = l then () - else ( - if b then Buffer.add_char buf ']'; - Buffer.add_string buf c; - longstring l true buf lexbuf) } - - | '\n' { Buffer.add_char buf '\n'; new_line lexbuf; longstring l false buf lexbuf } - | _ as c { Buffer.add_char buf c; longstring l false buf lexbuf } - | eof { failwith "unterminated string" } - -and string_space = parse - | space* '\n' { new_line lexbuf; string_space lexbuf } - | space* { } - -and comment = parse - | '\n' { new_line lexbuf } - | _ { comment lexbuf } - | eof { failwith "unterminated comment" } diff --git a/test/lua/Parser.mly b/test/lua/Parser.mly deleted file mode 100644 index bc412a3..0000000 --- a/test/lua/Parser.mly +++ /dev/null @@ -1,279 +0,0 @@ -%{ - open Ast -%} - -%start chunk - -%token EOF - -%token KW_AND KW_BREAK KW_DO KW_ELSE KW_ELSEIF KW_END KW_FALSE KW_FOR - KW_FUNCTION KW_GOTO KW_IF KW_IN KW_LOCAL KW_NIL KW_NOT KW_OR - KW_REPEAT KW_RETURN KW_THEN KW_TRUE KW_UNTIL KW_WHILE - -%token P_AND P_ASSIGN P_COLON P_COMMA P_CONCAT P_DBCOLON P_DOT P_DOTS - P_EQ P_GE P_GT P_HAT P_IDIV P_LBRACE P_LBRACKET P_LE P_LENGTH - P_LPAREN P_LT P_MINUS P_NE P_OR P_PERCENT P_PLUS P_RBRACE - P_RBRACKET P_RPAREN P_SEMI P_SHL P_SHR P_SLASH P_STAR P_TILDE - -%token NAME STRING -%token NUMERAL -%token INT - -%type chunk -%type block -%type stat -%type<(Ast.exp * Ast.block) list> stat_if_elseif -%type stat_if_else -%type stat_return -%type label -%type explist -%type namelist -%type<(string * string option) list> attnamelist -%type attrib -%type exp prefixexp -%type var -%type tableconstructor fieldlist -%type field -%type args -%type fieldsep -%type functioncall -%type varlist -%type functiondef funcbody -%type funcpath -%type funcname -%type parlist - -%nonassoc base -%nonassoc P_LPAREN -%left KW_OR -%left KW_AND -%left P_LT P_GT P_LE P_GE P_NE P_EQ -%left P_OR -%left P_TILDE -%left P_AND -%left P_SHR P_SHL -%right P_CONCAT -%left P_PLUS P_MINUS -%left P_STAR P_SLASH P_IDIV P_PERCENT -%nonassoc KW_NOT P_LENGTH P_MINUS_u P_TILDE_u -%right P_HAT - - -%% - -chunk: - | block EOF { $1 } -; - -block: - | /* empty */ { [] } - | stat_return { [ $1 ] } - | stat block { $1 :: $2 } -; - -stat: - | P_SEMI { StatEmpty } - | KW_DO block KW_END { StatBlock $2 } - | label { StatLabel $1 } - | KW_GOTO NAME { StatGoto $2 } - | functioncall %prec base { StatCall $1 } - | KW_BREAK { StatBreak } - - | varlist P_ASSIGN explist - { StatAssign { vars = $1; value = $3 } } - - | KW_IF exp KW_THEN block stat_if_elseif stat_if_else KW_END - { StatIf { arms = ($2, $4) :: $5; alt = $6 } } - - | KW_FOR NAME P_ASSIGN exp P_COMMA exp KW_DO block KW_END - { StatFor { name = $2; init = $4; limit = $6; step = None; body = $8 } } - - | KW_FOR NAME P_ASSIGN exp P_COMMA exp P_COMMA exp KW_DO block KW_END - { StatFor { name = $2; init = $4; limit = $6; step = Some $8; body = $10 } } - - | KW_FOR namelist KW_IN explist KW_DO block KW_END - { StatGenericFor { vars = $2; value = $4; body = $6 } } - - | KW_WHILE exp KW_DO block KW_END - { StatWhile { cond = $2; body = $4 } } - - | KW_REPEAT block KW_UNTIL exp - { StatRepeat { body = $2; cond = $4 } } - - | KW_LOCAL KW_FUNCTION funcname funcbody - { let params, body = $4 in StatFuncLocal { name = $3; params; body } } - | KW_FUNCTION funcname funcbody - { let params, body = $3 in StatFuncNamed { name = $2; params; body } } - - | KW_LOCAL attnamelist - { StatLocal { vars = $2; value = None } } - | KW_LOCAL attnamelist P_ASSIGN explist - { StatLocal { vars = $2; value = Some $4 } } -; - -stat_if_elseif: - | /* empty */ { [] } - | KW_ELSEIF exp KW_THEN block stat_if_elseif - { ($2, $4) :: $5 } -; - -stat_if_else: - | /* empty */ { None } - | KW_ELSE block { Some $2 } -; - -stat_return: - | KW_RETURN { StatReturn [ ] } - | KW_RETURN P_SEMI { StatReturn [ ] } - | KW_RETURN explist { StatReturn $2 } - | KW_RETURN explist P_SEMI { StatReturn $2 } -; - -label: - | P_DBCOLON NAME P_DBCOLON { $2 } -; - -varlist: - | var { [ $1 ] } - | var P_COMMA varlist { $1 :: $3 } -; - -explist: - | exp { [ $1 ] } - | exp P_COMMA explist { $1 :: $3 } -; - -namelist: - | NAME { [ $1 ] } - | NAME P_COMMA namelist { $1 :: $3 } -; - -attnamelist: - | NAME attrib { [ $1, $2 ] } - | NAME attrib P_COMMA attnamelist { ($1, $2) :: $4 } -; - -attrib: - | /* empty */ { None } - | P_LT NAME P_GT { Some $2 } -; - -exp: - | KW_NIL { ExpNil } - | KW_TRUE { ExpTrue } - | KW_FALSE { ExpFalse } - | P_DOTS { ExpDots } - | INT { ExpInt $1 } - | NUMERAL { ExpNumeral $1 } - | STRING { ExpString $1 } - | tableconstructor { ExpTable $1 } - - | prefixexp { $1 } - | functiondef { let params, body = $1 in ExpFunction { params; body } } - - | exp P_PLUS exp { ExpBinop { l = $1; r = $3; op = BinopAdd } } - | exp P_MINUS exp { ExpBinop { l = $1; r = $3; op = BinopSub } } - | exp P_STAR exp { ExpBinop { l = $1; r = $3; op = BinopMul } } - | exp P_SLASH exp { ExpBinop { l = $1; r = $3; op = BinopDiv } } - | exp P_IDIV exp { ExpBinop { l = $1; r = $3; op = BinopIDiv } } - | exp P_PERCENT exp { ExpBinop { l = $1; r = $3; op = BinopMod } } - | exp P_HAT exp { ExpBinop { l = $1; r = $3; op = BinopExp } } - | exp P_AND exp { ExpBinop { l = $1; r = $3; op = BinopBitAnd } } - | exp P_OR exp { ExpBinop { l = $1; r = $3; op = BinopBitOr } } - | exp P_TILDE exp { ExpBinop { l = $1; r = $3; op = BinopBitXor } } - | exp P_SHR exp { ExpBinop { l = $1; r = $3; op = BinopBitShr } } - | exp P_SHL exp { ExpBinop { l = $1; r = $3; op = BinopBitShl } } - | exp P_EQ exp { ExpBinop { l = $1; r = $3; op = BinopEq } } - | exp P_NE exp { ExpBinop { l = $1; r = $3; op = BinopNe } } - | exp P_LT exp { ExpBinop { l = $1; r = $3; op = BinopLt } } - | exp P_LE exp { ExpBinop { l = $1; r = $3; op = BinopLe } } - | exp P_GT exp { ExpBinop { l = $1; r = $3; op = BinopGt } } - | exp P_GE exp { ExpBinop { l = $1; r = $3; op = BinopGe } } - | exp KW_AND exp { ExpBinop { l = $1; r = $3; op = BinopAnd } } - | exp KW_OR exp { ExpBinop { l = $1; r = $3; op = BinopOr } } - | exp P_CONCAT exp { ExpBinop { l = $1; r = $3; op = BinopConcat } } - - | P_MINUS exp %prec P_MINUS_u { ExpUnop { x = $2; op = UnopNeg } } - | P_TILDE exp %prec P_TILDE_u { ExpUnop { x = $2; op = UnopBitNot } } - | P_LENGTH exp { ExpUnop { x = $2; op = UnopLength } } - | KW_NOT exp { ExpUnop { x = $2; op = UnopNot } } -; - -prefixexp: - | var %prec base { ExpVar $1 } - | functioncall %prec base { ExpCall $1 } - | P_LPAREN exp P_RPAREN %prec base { $2 } -; - -var: - | NAME { VarName $1 } - | prefixexp P_LBRACKET exp P_RBRACKET { VarIndex { target = $1; index = $3 } } - | prefixexp P_DOT NAME { VarField { target = $1; field = $3 } } -; - -tableconstructor: - | P_LBRACE P_RBRACE { [] } - | P_LBRACE fieldlist P_RBRACE { $2 } -; - -fieldlist: - | field { [ $1 ] } - | field fieldsep { [ $1 ] } - | field fieldsep fieldlist { $1 :: $3 } -; - -field: - | exp { Field { value = $1 } } - | P_LBRACKET exp P_RBRACKET P_ASSIGN exp { FieldIndex { index = $2; value = $5 } } - | NAME P_ASSIGN exp { FieldName { name = $1; value = $3 } } -; - -fieldsep: - | P_COMMA { () } - | P_SEMI { () } -; - -functioncall: - | var args { Call { callee = ExpVar $1; args = $2 } } - | functioncall args { Call { callee = ExpCall $1; args = $2 } } - | P_LPAREN exp P_RPAREN args { Call { callee = $2; args = $4 } } - - | var P_COLON NAME args { CallMethod { callee = ExpVar $1; name = $3; args = $4 } } - | functioncall P_COLON NAME args { CallMethod { callee = ExpCall $1; name = $3; args = $4 } } - | P_LPAREN exp P_RPAREN P_COLON NAME args { CallMethod { callee = $2; name = $5; args = $6 } } -; - -args: - | P_LPAREN P_RPAREN { [] } - | P_LPAREN explist P_RPAREN { $2 } - | STRING { [ ExpString $1 ] } - | tableconstructor { [ ExpTable $1] } -; - -functiondef: - | KW_FUNCTION funcbody { $2 } -; - -funcbody: - | P_LPAREN P_RPAREN block KW_END { Parlist { params = []; variadic = false }, $3 } - | P_LPAREN parlist P_RPAREN block KW_END { $2, $4 } -; - -funcname: - | funcpath { Func { base = $1 } } - | funcpath P_COLON NAME { FuncMethod { base = $1; name = $3 } } -; - -funcpath: - | NAME { [ $1 ] } - | NAME P_DOT funcpath { $1 :: $3 } -; - -parlist: - | NAME { Parlist { params = [ $1 ]; variadic = false } } - | P_DOTS { Parlist { params = []; variadic = true } } - - | NAME P_COMMA parlist - { let Parlist { params; variadic } = $3 in - Parlist { params = $1 :: params; variadic } } -; diff --git a/test/lua/README.md b/test/lua/README.md deleted file mode 100644 index e0b9978..0000000 --- a/test/lua/README.md +++ /dev/null @@ -1,13 +0,0 @@ -# Simple Lua 5.4 parser - -Run: - -```sh -bash input.sh # Download test input - -cat input.lua | \ - GEN=cpspg dune exec --profile release ./main.exe - -# Or GEN=mehir dune exec ... -# Or GEN=ocamlyacc dune exec ... -``` diff --git a/test/lua/dune b/test/lua/dune deleted file mode 100644 index 6b33440..0000000 --- a/test/lua/dune +++ /dev/null @@ -1,32 +0,0 @@ -(executable - (public_name lua) - (name main) - (libraries unix) - (ocamlopt_flags - (:standard -O3))) - -(ocamllex Lexer) - -(rule - (deps Parser.mly) - (target Parser.ml) - (enabled_if - (= %{env:GEN=} cpspg)) - (action - (run cpspg --comment -o %{target} %{deps}))) - -(rule - (deps Parser.mly) - (target Parser.ml) - (enabled_if - (= %{env:GEN=} menhir)) - (action - (run menhir %{deps}))) - -(rule - (deps Parser.mly) - (target Parser.ml) - (enabled_if - (= %{env:GEN=} ocamlyacc)) - (action - (run ocamlyacc %{deps}))) diff --git a/test/lua/input.sh b/test/lua/input.sh deleted file mode 100644 index 7f34edc..0000000 --- a/test/lua/input.sh +++ /dev/null @@ -1,44 +0,0 @@ -FILES=( - api.lua - attrib.lua - big.lua - bitwise.lua - bwcoercion.lua - calls.lua - closure.lua - code.lua - constructs.lua - coroutine.lua - cstack.lua - db.lua - errors.lua - events.lua - files.lua - gc.lua - gengc.lua - goto.lua - heavy.lua - literals.lua - locals.lua - main.lua - math.lua - nextvar.lua - pm.lua - sort.lua - strings.lua - tpack.lua - utf8.lua - vararg.lua - verybig.lua - all.lua -) - -URL='https://github.com/lua/lua/raw/v5.4.0/testes' - -rm -f input.lua -for file in "${FILES[@]}"; do - echo $file - echo "function ${file%.*}_lua ()" >> input.lua - curl -sL "$URL/$file" | grep -av '^#' >> input.lua - echo "end" >> input.lua -done diff --git a/test/lua/main.ml b/test/lua/main.ml deleted file mode 100644 index 186371f..0000000 --- a/test/lua/main.ml +++ /dev/null @@ -1,53 +0,0 @@ -let parse lexfun lexbuf = - try Parser.chunk lexfun lexbuf with - | e -> - let open Lexing in - let pos = lexbuf.lex_start_p in - let f, l, c = pos.pos_fname, pos.pos_lnum, pos.pos_cnum - pos.pos_bol in - Format.eprintf "File \"%s\", line %d, character %d:\n" f l c; - Format.eprintf "Error: %s\n" (Printexc.to_string e); - exit 1 -;; - -let lex lexfun lexbuf = - let open Lexing in - let rec loop acc = - match lexfun lexbuf with - | Parser.EOF -> List.rev acc - | token -> loop ((token, lexbuf.lex_start_p, lexbuf.lex_curr_p) :: acc) - in - let lexfun input lexbuf = - match !input with - | [] -> Parser.EOF - | (token, start, curr) :: xs -> - input := xs; - lexbuf.lex_start_p <- start; - lexbuf.lex_curr_p <- curr; - token - in - let input = loop [] in - fun () -> - let input = ref input - and lexbuf = Lexing.from_string "" - and filename = lexbuf.lex_curr_p.pos_fname in - set_filename lexbuf filename; - lexfun input, lexbuf -;; - -let bench input = - let start = Unix.gettimeofday () in - let lex = lex Lexer.token (Lexing.from_string input) in - let chunk = ref [] in - for _ = 1 to 100 do - let lexfun, lexbuf = lex () in - chunk := parse lexfun lexbuf - done; - Unix.gettimeofday () -. start, !chunk -;; - -let _ = - let input = In_channel.input_all stdin in - let time, chunk = bench input in - (* Ast.pp_block Format.std_formatter chunk; *) - Format.eprintf "Time: %fs\n%!" time -;; From b8e75d559739c0cc0a1ba44e910b83f975b39fef Mon Sep 17 00:00:00 2001 From: Adam Szeruda <32493319+adampsz@users.noreply.github.com> Date: Tue, 3 Dec 2024 15:42:08 +0100 Subject: [PATCH 6/8] Restore calculator test --- test/calc/Calc.fram | 41 +++++++++++++++++++++++++++++++++++++++++ test/calc/Parser.mly | 36 ++++++++++++++++++++++++++++++++++++ test/calc/dune | 10 ++++++++++ 3 files changed, 87 insertions(+) create mode 100644 test/calc/Calc.fram create mode 100644 test/calc/Parser.mly create mode 100644 test/calc/dune diff --git a/test/calc/Calc.fram b/test/calc/Calc.fram new file mode 100644 index 0000000..a55e0aa --- /dev/null +++ b/test/calc/Calc.fram @@ -0,0 +1,41 @@ +import List +import open Parser +import Parsing + +module Feeder + pub let withFeeder {Tok} + (xs : List Tok) + (eof : Tok) + (f : {R} -> Parsing.Lex R Tok -> [|R] _) = + handle lex = Parsing.Lex + { token = effect () / r => + fn ys => + match ys with + | [] => r eof ys + | y :: ys => r y ys + end + , curPos = effect () / r => fn ys => r Parsing.dummyPos ys + , startPos = effect () / r => fn ys => r Parsing.dummyPos ys } + return x => fn _ => x + finally f => f xs + in f lex +end + +let tests = + [[INT 2, PLUS, INT 3], + [INT 8, STAR, INT 3, STAR, INT 89, PLUS, INT 1], + [LPAREN, INT 9, PLUS, INT 1, RPAREN, SLASH, INT 5], + [INT 4, SLASH, INT 0], + [INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, PERCENT, INT 5], + [LPAREN, INT 1, PLUS, INT 4, CARET, INT 3, CARET, INT 2, RPAREN, PERCENT, INT 5]] + +let execTest xs = + let res = Feeder.withFeeder xs + EOF + (fn lex => main {~lex = lex} ()) in + match res with + | Left s => printStrLn s + | Right n => printInt n ; printStrLn "" + end + +let _ = List.iter execTest tests diff --git a/test/calc/Parser.mly b/test/calc/Parser.mly new file mode 100644 index 0000000..18f8e62 --- /dev/null +++ b/test/calc/Parser.mly @@ -0,0 +1,36 @@ +%{ +let fail () = Parsing.error "arithmetic error" + +let rec pow {~re : {type X} -> Unit ->[|_] X} (a : Int) (n : Int) = + if n == 0 then 1 + else if n == 1 then a + else (let (b : Int) = pow a (n / 2) in + b * b * (if n % 2 == 0 then 1 else a)) +%} + +%token INT +%token PLUS MINUS SLASH STAR PERCENT CARET LPAREN RPAREN EOF +%start main + +%left PLUS MINUS +%left SLASH STAR PERCENT +%nonassoc UMINUS +%right CARET + +%% + +main: x=expr EOF { x }; + +expr: + | l=expr PLUS r=expr { let (l : Int) = l in l + r } + | l=expr MINUS r=expr { let (l : Int) = l in l - r } + | l=expr STAR r=expr { let (l : Int) = l in l * r } + | l=expr SLASH r=expr { let ~re = fail in let (l : Int) = l in l / r } + | l=expr PERCENT r=expr { let ~re = fail in let (l : Int) = l in l % r } + | l=expr CARET r=expr { let ~re = fail in let (l : Int) = l in pow l r } + + | MINUS x=expr %prec UMINUS { 0 - x } + + | LPAREN x=expr RPAREN { x } + | x=INT { x } +; diff --git a/test/calc/dune b/test/calc/dune new file mode 100644 index 0000000..a3fe9f8 --- /dev/null +++ b/test/calc/dune @@ -0,0 +1,10 @@ +(rule + (deps Parser.mly) + (target Parser.fram) + (action + (run cpspg -o %{target} %{deps}))) + +(rule + (alias runtest) + (deps Calc.fram Parser.fram (source_tree ../../framtools)) + (action (run dbl -I ../../framtools Calc.fram))) From 405379f9facdd3cf163240b2fcdb94c676d67f9a Mon Sep 17 00:00:00 2001 From: Adam Szeruda <32493319+adampsz@users.noreply.github.com> Date: Fri, 6 Dec 2024 23:40:20 +0100 Subject: [PATCH 7/8] Disable line directives only in fram --- bin/main.ml | 2 +- lib/CodeGenFram.ml | 15 +-------------- 2 files changed, 2 insertions(+), 15 deletions(-) diff --git a/bin/main.ml b/bin/main.ml index c635e7b..5055830 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -3,7 +3,7 @@ let source_name = ref None let output_name = ref None let output_format = ref ".ml" let grammar_kind = ref Cpspg.Types.LALR -let codegen_line_directives = ref false (* Disabled for now *) +let codegen_line_directives = ref true let codegen_comments = ref false let codegen_readable_ids = ref false let codegen_locations = ref true diff --git a/lib/CodeGenFram.ml b/lib/CodeGenFram.ml index 2fa1f41..4935ba1 100644 --- a/lib/CodeGenFram.ml +++ b/lib/CodeGenFram.ml @@ -128,20 +128,7 @@ struct loop 0 xs ;; - let write_line_directive f (loc, _) = - Format.fprintf - f - "\n# %d \"%s\"\n%s" - loc.Lexing.pos_lnum - loc.Lexing.pos_fname - (String.make (loc.pos_cnum - loc.pos_bol) ' ') - ;; - - let write_string f { loc; data } = - if S.line_directives - then Format.fprintf f "%t%s" (fun f -> write_line_directive f loc) data - else Format.fprintf f "%s" (String.trim data) - ;; + let write_string f { data; _ } = Format.fprintf f "%s" (String.trim data) let write_arg_id f symbol idx = if S.readable_ids From 652b1d4546a78c514ae80562473ae8df8c992241 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Miko=C5=82aj=20Swoboda?= <331319@uwr.edu.pl> Date: Sun, 25 May 2025 21:44:03 +0200 Subject: [PATCH 8/8] New syntax and one more test/example Updated the code generator to use new Fram syntax. Currently, effect inference takes too long for the Calc example. I have added a simpler example, SExpr, to demonstrate that the program works. --- framtools/Parsing.fram | 26 +++++++++---------- framtools/Utils.fram | 12 --------- lib/CodeGenFram.ml | 57 ++++++++++++++++++++++-------------------- test/calc/Calc.fram | 4 +-- test/calc/Parser.mly | 2 +- test/sexpr/Parser.mly | 19 ++++++++++++++ test/sexpr/SExpr.fram | 57 ++++++++++++++++++++++++++++++++++++++++++ test/sexpr/dune | 10 ++++++++ 8 files changed, 132 insertions(+), 55 deletions(-) delete mode 100644 framtools/Utils.fram create mode 100644 test/sexpr/Parser.mly create mode 100644 test/sexpr/SExpr.fram create mode 100644 test/sexpr/dune diff --git a/framtools/Parsing.fram b/framtools/Parsing.fram index d9dc2b8..3612681 100644 --- a/framtools/Parsing.fram +++ b/framtools/Parsing.fram @@ -1,5 +1,5 @@ -(* This file should be placed in the same directory as the generated - * parser *) +{# This file should be placed in the same directory as the generated + parser #} pub data Pos = Pos of { fname : String @@ -9,20 +9,20 @@ pub data Pos = Pos of pub let dummyPos = Pos {fname = "", lnum = 0, bol = 0, cnum = 0-1} -pub data Lex R Tok = Lex of - { token : Unit ->[|R] Tok - , startPos : Unit ->[|R] Pos - , curPos : Unit -> [|R] Pos } +pub data Lex E Tok = Lex of + { token : Unit ->[E] Tok + , startPos : Unit ->[E] Pos + , curPos : Unit -> [E] Pos } -pub method token {R, Tok, self = Lex {token} : Lex R Tok} = token -pub method startPos {R, Tok, self = Lex {startPos} : Lex R Tok} = startPos -pub method curPos {R, Tok, self = Lex {curPos} : Lex R Tok} = curPos +pub method token {E, Tok} (Lex {token} : Lex E Tok) = token +pub method startPos {E, Tok} (Lex {startPos} : Lex E Tok) = startPos +pub method curPos {E, Tok} (Lex {curPos} : Lex E Tok) = curPos -pub data Error (effect E) = Error of ({type X} -> String ->[E] X) -pub method parseError {E, self = Error f : Error E} = f +pub data Error E = Error of ({type X} -> String ->[E] X) +pub method parseError {E} (Error f : Error E) = f -(** Error-reporting function. Use this function to report errors +{## Error-reporting function. Use this function to report errors in semantic actions. If an error is reported, the result returned by the parser will be the passed string wrapped in - a `Left` constructor. *) + a `Left` constructor. ##} pub let error {E, ~error : Error E} s = ~error.parseError s diff --git a/framtools/Utils.fram b/framtools/Utils.fram deleted file mode 100644 index 6fd97b0..0000000 --- a/framtools/Utils.fram +++ /dev/null @@ -1,12 +0,0 @@ -(* This file contains useful functions that arguably (i.e., in comparison - * with OCaml) belong in the standard library but have not been included - * in it yet. It should eventually fall out of use. - * - * Nonetheless, as long as it hasn't, it should be placed in the same directory - * as the generated parser. *) - -pub let optionGet {~re : {type X} -> Unit ->[|_] X} opt = - match opt with - | None => ~re () - | Some x => x - end diff --git a/lib/CodeGenFram.ml b/lib/CodeGenFram.ml index 4935ba1..ab174cd 100644 --- a/lib/CodeGenFram.ml +++ b/lib/CodeGenFram.ml @@ -2,8 +2,9 @@ module IntMap = Map.Make (Int) module SymbolMap = Map.Make (Automaton.Symbol) let action_lib = - " implicit ~loc\n\ - \ implicit ~error {E_err} : Parsing.Error E_err\n\n\ + " parameter ~loc\n\ + \ parameter E_err\n\ + \ parameter ~error : Parsing.Error E_err\n\n\ \ pub let _kw_endpos _ =\n\ \ match ~loc with\n\ \ | l :: _ => snd l\n\ @@ -24,30 +25,29 @@ let action_lib = ;; let state_lib = - " let lexfun {E_err, E_st, R_lex,\n\ + " let lexfun {E_err, E_st, E_lex,\n\ \ ~error : Parsing.Error E_err,\n\ \ ~st : State2 E_st,\n\ - \ ~lex : Parsing.Lex R_lex Tok} () = \n\ - \ let (aux : Unit ->[E_err, E_st|R_lex] Tok) = \n\ + \ ~lex : Parsing.Lex E_lex Tok} () = \n\ + \ let (aux : Unit ->[E_err, E_st, E_lex] Tok) = \n\ \ fn () => ~lex.token ()\n\ \ in aux ()\n\n\ - \ let shift {E_err, E_st, R_lex,\n\ + \ let shift {E_err, E_st, E_lex,\n\ \ ~error : Parsing.Error E_err,\n\ \ ~st : State2 E_st,\n\ - \ ~lex : Parsing.Lex R_lex Tok} () = \n\ - \ let (aux : Unit ->[E_err, E_st|R_lex] Pair Tok (Pair Parsing.Pos Parsing.Pos)) = \n\ + \ ~lex : Parsing.Lex E_lex Tok} () = \n\ + \ let (aux : Unit ->[E_err, E_st, E_lex] Pair Tok (Pair Parsing.Pos Parsing.Pos)) = \n\ \ (fn () => \n\ - \ let sym = Utils.optionGet {~re = (fn () => Parsing.error \"option\")}\n\ - \ (getPeeked ()) in\n\ + \ let sym = (getPeeked ()).unwrapErr {~onError = fn () => Parsing.error \"option\"} in\n\ \ let () = setPeeked None in\n\ \ let () = setFallback (~lex.curPos ()) in\n\ \ sym)\n\ \ in aux ()\n\n\ - \ let lookahead {E_err, E_st, R_lex,\n\ + \ let lookahead {E_err, E_st, E_lex,\n\ \ ~error : Parsing.Error E_err,\n\ \ ~st : State2 E_st,\n\ - \ ~lex : Parsing.Lex R_lex Tok} () = \n\ - \ let (aux : Unit ->[E_err, E_st|R_lex] Tok) = \n\ + \ ~lex : Parsing.Lex E_lex Tok} () = \n\ + \ let (aux : Unit ->[E_err, E_st, E_lex] Tok) = \n\ \ (fn () => \n\ \ match getPeeked () with\n\ \ | Some (tok, _) => tok\n\ @@ -58,13 +58,13 @@ let state_lib = \ tok\n\ \ end)\n\ \ in aux ()\n\n\ - \ implicit ~loc\n\ + \ parameter ~loc\n\ \ let loc_shift l = l :: ~loc\n\n\ - \ let loc_reduce {E_err, E_st, R_lex,\n\ + \ let loc_reduce {E_err, E_st, E_lex,\n\ \ ~error : Parsing.Error E_err,\n\ \ ~st : State2 E_st,\n\ - \ ~lex : Parsing.Lex R_lex Tok} n =\n\ - \ let (aux : Int ->[E_err, E_st|R_lex] List (Pair Parsing.Pos Parsing.Pos)) = \n\ + \ ~lex : Parsing.Lex E_lex Tok} n =\n\ + \ let (aux : Int ->[E_err, E_st, E_lex] List (Pair Parsing.Pos Parsing.Pos)) = \n\ \ (fn (n : Int) =>\n\ \ if n == 0 then (getFallback (), getFallback ()) :: ~loc\n\ \ else\n\ @@ -80,9 +80,12 @@ let state_lib = \ ~loc)) in\n\ \ l :: skip n ~loc))\n\ \ in aux n\n\n\ - \ implicit ~lex {R_lex} : Parsing.Lex R_lex Tok\n\ - \ implicit ~st {E_st} : State2 E_st\n\ - \ implicit ~error {E_err} : Parsing.Error E_err\n\n" + \ parameter R_lex\n\ + \ parameter ~lex : Parsing.Lex R_lex Tok\n\ + \ parameter E_st\n\ + \ parameter ~st : State2 E_st\n\ + \ parameter E_err\n\ + \ parameter ~error : Parsing.Error E_err\n\n" ;; let iteri2 f xs ys = @@ -403,19 +406,19 @@ struct Format.fprintf f "import Parsing\n\ - import Utils\n\ import List\n\ - implicit ~error {E_err} : Parsing.Error E_err\n\ + parameter E_err\n\ + parameter ~error : Parsing.Error E_err\n\ %t\n\n\ - %tdata State2 (effect E) = State2 of\n\ + %tdata State2 E = State2 of\n\ \ { setPeeked : Option (Pair Tok (Pair Parsing.Pos Parsing.Pos)) ->[E] Unit\n\ \ , setFallback : Parsing.Pos ->[E] Unit\n\ \ , getPeeked : Unit ->[E] Option (Pair Tok (Pair Parsing.Pos Parsing.Pos))\n\ \ , getFallback : Unit ->[E] Parsing.Pos }\n\n\ - method setPeeked {E, self = State2 {setPeeked} : State2 E} = setPeeked\n\ - method getPeeked {E, self = State2 {getPeeked} : State2 E} = getPeeked\n\ - method setFallback {E, self = State2 {setFallback} : State2 E} = setFallback\n\ - method getFallback {E, self = State2 {getFallback} : State2 E} = getFallback\n\n\ + method setPeeked {E} (State2 {setPeeked} : State2 E) = setPeeked\n\ + method getPeeked {E} (State2 {getPeeked} : State2 E) = getPeeked\n\ + method setFallback {E} (State2 {setFallback} : State2 E) = setFallback\n\ + method getFallback {E} (State2 {getFallback} : State2 E) = getFallback\n\n\ let setPeeked {E, ~st : State2 E} p = ~st.setPeeked p\n\ let getPeeked {E, ~st : State2 E} () = ~st.getPeeked ()\n\ let setFallback {E, ~st : State2 E} f = ~st.setFallback f\n\ diff --git a/test/calc/Calc.fram b/test/calc/Calc.fram index a55e0aa..557d3d6 100644 --- a/test/calc/Calc.fram +++ b/test/calc/Calc.fram @@ -6,7 +6,7 @@ module Feeder pub let withFeeder {Tok} (xs : List Tok) (eof : Tok) - (f : {R} -> Parsing.Lex R Tok -> [|R] _) = + (f : {E} -> Parsing.Lex E Tok -> [E] _) = handle lex = Parsing.Lex { token = effect () / r => fn ys => @@ -38,4 +38,4 @@ let execTest xs = | Right n => printInt n ; printStrLn "" end -let _ = List.iter execTest tests +# let _ = List.iter execTest tests diff --git a/test/calc/Parser.mly b/test/calc/Parser.mly index 18f8e62..b82889f 100644 --- a/test/calc/Parser.mly +++ b/test/calc/Parser.mly @@ -1,7 +1,7 @@ %{ let fail () = Parsing.error "arithmetic error" -let rec pow {~re : {type X} -> Unit ->[|_] X} (a : Int) (n : Int) = +let rec pow {~re : {type X} -> Unit ->[_] X} (a : Int) (n : Int) = if n == 0 then 1 else if n == 1 then a else (let (b : Int) = pow a (n / 2) in diff --git a/test/sexpr/Parser.mly b/test/sexpr/Parser.mly new file mode 100644 index 0000000..f7d3c4a --- /dev/null +++ b/test/sexpr/Parser.mly @@ -0,0 +1,19 @@ +%{ +pub data rec SExpr = Nil + | Atom of String + | Cons of SExpr, SExpr + +%} +%token ATOM +%token LPAREN RPAREN DOT EOF +%start main + +%% + +main: x=s EOF { x }; + +s: + | LPAREN RPAREN { Nil } + | x=ATOM { Atom x } + | LPAREN x=s DOT y=s RPAREN { Cons x y } +; diff --git a/test/sexpr/SExpr.fram b/test/sexpr/SExpr.fram new file mode 100644 index 0000000..2ef7615 --- /dev/null +++ b/test/sexpr/SExpr.fram @@ -0,0 +1,57 @@ +import List +import open Parser +import Parsing + +module Feeder + pub let withFeeder {Tok} + (xs : List Tok) + (eof : Tok) + (f : {E} -> Parsing.Lex E Tok -> [E] _) = + handle lex = Parsing.Lex + { token = effect () / r => + fn ys => + match ys with + | [] => r eof ys + | y :: ys => r y ys + end + , curPos = effect () / r => fn ys => r Parsing.dummyPos ys + , startPos = effect () / r => fn ys => r Parsing.dummyPos ys } + return x => fn _ => x + finally f => f xs + in f lex +end + +let bye s = (printStrLn s; exit 1) + +let getTree result = + match result with + | Left s => bye s + | Right t => t + end + +let execTest xs = Feeder.withFeeder xs EOF (fn lex => main {~lex = lex} ()) + +let test = [LPAREN, LPAREN, ATOM "x", DOT, ATOM "y", RPAREN, DOT, LPAREN, RPAREN, RPAREN] +# '((x . y)) + +pub let t = getTree (execTest test) + +pub let examine s = + match s with + | Nil => "Nil" + | Atom s => "Atom " + s + | Cons _ _ => "Cons" + end + +pub let left s = + match s with + | Cons l _ => l + | _ => bye "no left" + end + +pub let right s = + match s with + | Cons _ r => r + | _ => bye "no right" + end + diff --git a/test/sexpr/dune b/test/sexpr/dune new file mode 100644 index 0000000..0e41783 --- /dev/null +++ b/test/sexpr/dune @@ -0,0 +1,10 @@ +(rule + (deps Parser.mly) + (target Parser.fram) + (action + (run cpspg -o %{target} %{deps}))) + +(rule + (alias runtest) + (deps SExpr.fram Parser.fram (source_tree ../../framtools)) + (action (run dbl -I ../../framtools SExpr.fram)))