diff --git a/bin/main.ml b/bin/main.ml index 90adc72..adb87aa 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -107,6 +107,7 @@ let main () = let module Code = (val match !output_format with | ".ml" -> (module Cpspg.CodeGenMl.Make (Settings) (Grammar) (Automaton)) + | ".fram" -> (module Cpspg.CodeGenFram.Make (Settings) (Grammar) (Automaton)) | ".dot" -> (module Cpspg.CodeGenDot.Make (Settings) (Grammar) (Automaton)) | _ -> failwith "Unknown output format" : Cpspg.Types.Code) diff --git a/framtools/Parsing.fram b/framtools/Parsing.fram new file mode 100644 index 0000000..3612681 --- /dev/null +++ b/framtools/Parsing.fram @@ -0,0 +1,28 @@ +{# 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 E Tok = Lex of + { token : Unit ->[E] Tok + , startPos : Unit ->[E] Pos + , curPos : Unit -> [E] Pos } + +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 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 + 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/lib/CodeGenFram.ml b/lib/CodeGenFram.ml new file mode 100644 index 0000000..ab174cd --- /dev/null +++ b/lib/CodeGenFram.ml @@ -0,0 +1,441 @@ +module IntMap = Map.Make (Int) +module SymbolMap = Map.Make (Automaton.Symbol) + +let action_lib = + " 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\ + \ | [] => Parsing.dummyPos\n\ + \ end\n\n\ + \ pub let _kw_startpos (n : Int) =\n\ + \ match List.nth ~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\ + \ \n" +;; + +let state_lib = + " let lexfun {E_err, E_st, E_lex,\n\ + \ ~error : Parsing.Error E_err,\n\ + \ ~st : State2 E_st,\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, E_lex,\n\ + \ ~error : Parsing.Error E_err,\n\ + \ ~st : State2 E_st,\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 = (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, E_lex,\n\ + \ ~error : Parsing.Error E_err,\n\ + \ ~st : State2 E_st,\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\ + \ | 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\ + \ parameter ~loc\n\ + \ let loc_shift l = l :: ~loc\n\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 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\ + \ (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\ + \ 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 = + let f i x y = + f i x y; + i + 1 + in + List.fold_left2 f 0 xs ys |> ignore +;; + +module Make (S : Types.Settings) (G : Types.Grammar) (A : Types.Automaton) : Types.Code = +struct + open Automaton + module D = CodeGenDot.Make (S) (G) (A) + + let term_name t = (G.term t).ti_name.data + let nterm_name n = (G.nterm n).ni_name.data + + let symbol_name = function + | Term t -> term_name t + | NTerm n -> nterm_name n + ;; + + let symbol_has_value = function + | NTerm _ -> true + | Term t -> (G.term t).ti_ty |> Option.is_some + ;; + + let indent s i = + String.trim s + |> String.split_on_char '\n' + |> List.map String.trim + |> String.concat ("\n" ^ i) + ;; + + let letrec ?(pre = "rec let") ?(pre' = "let") ?(post = "") ?(post' = " end in") f xs = + let rec loop i = function + | [] -> () + | x :: xs -> + f i x (if i = 0 then pre else pre') (if xs = [] then post' else post); + loop (i + 1) xs + in + loop 0 xs + ;; + + let write_string f { data; _ } = Format.fprintf f "%s" (String.trim data) + + let write_arg_id f symbol idx = + if S.readable_ids + then Format.fprintf f "a%d_%s" idx (symbol_name symbol) + else Format.fprintf f "a%d" idx + ;; + + (* Continuations are prefixed with underscore because + precedence declarations could make them unused + (see unary minus in `calc/ParserPres.mly`) *) + let write_cont_id f group idx = + match S.readable_ids, group.g_starting with + | false, _ -> Format.fprintf f "_c%d" idx + | true, false -> Format.fprintf f "_c%d_%s" idx (nterm_name group.g_symbol) + | true, true -> Format.fprintf f "_c%d_%s_starting" idx (nterm_name group.g_symbol) + ;; + + let write_semantic_action_id f action idx = + if S.readable_ids + then Format.fprintf f "a%d_%s" idx (nterm_name action.sa_symbol) + else Format.fprintf f "a%d" idx + ;; + + let write_state_id f idx = + if S.readable_ids then Format.fprintf f "state_%d" idx else Format.fprintf f "s%d" idx + ;; + + let write_cont_ids f p groups = + let iter i g = if p g then Format.fprintf f " %t" (fun f -> write_cont_id f g i) in + List.iteri iter groups + ;; + + let write_arg_ids f symbols = + let iter i s = + if symbol_has_value s then Format.fprintf f " %t" (fun f -> write_arg_id f s i) + in + List.iteri iter symbols + ;; + + let write_term_pattern f bind t = + if symbol_has_value (Term t) + then Format.fprintf f "%s %s" (term_name t) (if bind then "x" else "_") + else Format.fprintf f "%s" (term_name t) + ;; + + (* 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 + ;; + + 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 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) + ;; + + let write_cont_definition f state group idx = + let sym = NTerm group.g_symbol in + Format.fprintf + f + "%t%s x = %t" + (fun f -> write_cont_id f group idx) + (if S.locations then " {~loc}" else "") + (fun f -> write_goto_call f state sym) + ;; + + let write_semantic_action_call f group = function + | { i_action = -1; _ } -> + assert (List.length group.g_prefix = 1); + write_arg_ids f group.g_prefix + | { i_action; _ } -> + let action = IntMap.find i_action A.automaton.a_actions in + Format.fprintf + f + " Actions.%t%t ()" + (fun f -> write_semantic_action_id f action i_action) + (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 _l" in + if S.comments then Format.fprintf f " (* Shift *)\n"; + Format.fprintf + f + " | %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)) + ;; + + 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 + 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 + ;; + + let write_action f state lookahead = function + | Shift -> TermSet.iter (write_action_shift f state) lookahead + | Reduce (i, j) -> write_action_reduce f state lookahead i j + ;; + + 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 " | _ => Parsing.error \"\"\n end\n" + ;; + + let write_actions_starting f state = + if S.comments then Format.fprintf f " (* Reduce *)\n"; + let group = List.hd state.s_kernel in + let item = List.nth group.g_items 0 in + Format.fprintf + f + " let x =%t in\n %t x\n" + (fun f -> write_semantic_action_call f group item) + (fun f -> write_cont_id f group 0) + ;; + + let write_term_cons f = function + | { ti_name; ti_ty = None; _ } -> + Format.fprintf f " | %t\n" (fun f -> write_string f ti_name) + | { ti_name; ti_ty = Some ty; _ } -> + Format.fprintf + f + " | %t of (%t)\n" + (fun f -> write_string f ti_name) + (fun f -> write_string f ty) + ;; + + let write_term_type f symbols = + let get_info = function + | NTerm _ -> None + | Term t -> Some (G.term t) + 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 "pub data Tok =\n"; + List.iter (write_term_cons f) infos; + Format.fprintf f "\n" + ;; + + let write_semantic_action_code f action = + let n = List.length action.sa_args + and code = action.sa_code in + let write_part f l r = + let len = r.Lexing.pos_cnum - l.Lexing.pos_cnum + and ofs = l.pos_cnum - (fst action.sa_code.loc).pos_cnum in + write_string f { data = String.sub (fst code.data) ofs len; loc = l, r } + and get_impl = function + | Ast.KwArg i -> + (match List.nth_opt action.sa_args (i - 1) with + | Some (Some a) -> a + | Some None -> Printf.sprintf "_arg%d" i + | None -> "()") + | 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) + | (kw, loc) :: kws -> + write_part f pos (fst loc); + let impl = get_impl kw in + Format.fprintf f "(%s) " impl; + loop (snd loc) kws + in + loop (fst action.sa_code.loc) (snd action.sa_code.data |> List.rev) + ;; + + let write_semantic_action f id action = + let item = List.nth (G.group action.sa_symbol).g_items action.sa_index in + let iter i s = function + | _ when symbol_has_value s = false -> () + | Some a -> Format.fprintf f " %s" a + | None -> Format.fprintf f " _arg%d" (List.length action.sa_args - i) + in + write_semantic_action_id f action id; + iteri2 iter (List.rev item.i_suffix) (List.rev action.sa_args); + Format.fprintf f " () = %t" (fun f -> write_semantic_action_code f action) + ;; + + let write_state_comment f state = + let ci = Format.asprintf "%a" D.fmt_state state + and cs = Format.asprintf "%a" D.fmt_state_shifts state + and ca = Format.asprintf "%a" D.fmt_state_actions state in + Format.fprintf + f + " (* ITEMS:\n %s\n GOTO:\n %s\n ACTION:\n %s *)\n" + (indent ci " ") + (indent cs " ") + (indent ca " ") + ;; + + let write_state_sig f id state = + Format.fprintf + f + "%t%s%t%t =\n" + (fun f -> write_state_id f id) + (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) + ;; + + let write_state_body f state = + let kn = List.length state.s_kernel in + let gen_state_cont_def i group pre post = + let fc f = write_cont_definition f state group (i + kn) in + Format.fprintf f " %s %t%s\n" pre fc post + in + letrec gen_state_cont_def state.s_closure; + let group = List.hd state.s_kernel in + if group.g_starting && (List.hd group.g_items).i_suffix = [] + then write_actions_starting f state + else write_actions f state + ;; + + let write_state f id state = + write_state_sig f id state; + write_state_body f state + ;; + + let write_entry f symbol id = + Format.fprintf + f + "pub let %s {~lex} () =\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\ + \ , 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 "") + ;; + + let write f = + let 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 ~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 + "import Parsing\n\ + import List\n\ + parameter E_err\n\ + parameter ~error : Parsing.Error E_err\n\ + %t\n\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} (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\ + 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" + (fun f -> List.iter (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 *) + state_lib + (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/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/Calc.fram b/test/calc/Calc.fram new file mode 100644 index 0000000..557d3d6 --- /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 : {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 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/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/Parser.mly b/test/calc/Parser.mly new file mode 100644 index 0000000..b82889f --- /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/ParserBase.mly b/test/calc/ParserBase.mly deleted file mode 100644 index 7cdcc9c..0000000 --- a/test/calc/ParserBase.mly +++ /dev/null @@ -1,42 +0,0 @@ -%{ - -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) -;; - -%} - -%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 { l + r } - | l=expr MINUS r=term { 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 } - | x=factor { x } -; - -factor: - | l=base CARET r=factor { 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 7a0fe79..0000000 --- a/test/calc/ParserPrec.mly +++ /dev/null @@ -1,38 +0,0 @@ -%{ - -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) -;; - -%} - -%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 { 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 } - - | LPAREN x=expr RPAREN { x } - | x=INT { x } -; 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 () -;; diff --git a/test/calc/dune b/test/calc/dune index d86f28f..a3fe9f8 100644 --- a/test/calc/dune +++ b/test/calc/dune @@ -1,20 +1,10 @@ -(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) + (deps Parser.mly) + (target Parser.fram) (action (run cpspg -o %{target} %{deps}))) (rule - (deps ParserPrec.mly) - (target ParserPrec.ml) - (action - (run cpspg -o %{target} %{deps}))) + (alias runtest) + (deps Calc.fram Parser.fram (source_tree ../../framtools)) + (action (run dbl -I ../../framtools Calc.fram))) 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 cba6c0c..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} 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 27cd3f8..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 -;; 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)))