diff --git a/Makefile b/Makefile index c9075409..296b4e91 100644 --- a/Makefile +++ b/Makefile @@ -1,215 +1,23 @@ # Makefile for ReactiveML -# Taken from Lucid-synchrone -# Organization : SPI team, LIP6 laboratory, University Paris 6 -include configure-tools/version include config -all: config-stamp - (cd compiler; touch .depend; $(MAKE) depend; $(MAKE) $(TARGET)) - (cd stdlib; $(MAKE) all) - (cd interpreter; touch .depend; $(MAKE) depend; $(MAKE) all) - (cd toplevel; $(MAKE) all) - (cd tools; $(MAKE) $(TARGET)) +build: + echo "(* This file is generated *)" > compiler/global/version.ml + echo "let version = \"$(VERSION)\"" >> compiler/global/version.ml + echo "let stdlib = \"$(LIBDIR)\"" >> compiler/global/version.ml + dune build stdlib + RML_RECOMPILE_RZI=0 dune build compiler tools interpreter toplevel -config-stamp: - ./configure - touch $@ +test: build + dune runtest -toplevel: FORCE - (cd toplevel; $(MAKE) all) - -toplevel-install: - (cd toplevel; $(MAKE) install) - - -opt: TARGET := opt -opt: all - -byte: TARGET := byte -byte: all - -.PHONY: install - -install: - (cd compiler; $(MAKE) install) - (cd stdlib; $(MAKE) install) - (cd interpreter; $(MAKE) install) - (cd man; $(MAKE) install) - (cd emacs; $(MAKE) install) - (cd toplevel; $(MAKE) install) - (cd tools; $(MAKE) install) - -checkinstall: config - checkinstall -D --deldoc=yes --deldesc=yes --nodoc -y --install=no +install: build + dune install uninstall: - (cd compiler; $(MAKE) uninstall) - (cd stdlib; $(MAKE) uninstall) - (cd interpreter; $(MAKE) uninstall) - (cd man; $(MAKE) uninstall) - (cd emacs; $(MAKE) uninstall) - (cd toplevel; $(MAKE) uninstall) - (cd tools; $(MAKE) uninstall) - - -### BEGIN Patch from Serge Leblanc - -install.findlib: - @echo "Install ReactiveML interpreter in ocamlfind hierarchy." - @(echo "version = \"$(VERSION)\"" > ./META) - @(cat ./configure-tools/META.in >> ./META) - - [ ! -e ./rmllib.a ] && \ - ln -s ./interpreter/rmllib.a ./rmllib.a - - [ ! -e ./rmllib.cma ] && \ - ln -s ./interpreter/rmllib.cma ./rmllib.cma - - [ ! -e ./rmllib.cmxa ] && \ - ln -s ./interpreter/rmllib.cmxa ./rmllib.cmxa - - [ -r ./META -a -r ./rmllib.a -a -r ./rmllib.cma -a -r ./rmllib.cmxa ] && \ - ocamlfind install rmlc ./META ./rmllib.a ./rmllib.cma ./rmllib.cmxa - - rm -rf rmllib.a rmllib.cma rmllib.cmxa - -uninstall.findlib: - ocamlfind remove rmlc - -### END - - -doc: dvi -dvi: - (cd doc; $(MAKE) dvi) -html: - (cd doc; $(MAKE) html) - -wc: - (cd compiler;$(MAKE) wc) - (cd interpreter; $(MAKE) wc) - (cd toplevel; $(MAKE) wc) - (cd tools; $(MAKE) wc) + dune uninstall clean: - (cd compiler;$(MAKE) clean) - (cd stdlib; $(MAKE) clean) - (cd interpreter; $(MAKE) clean) - (cd toplevel; $(MAKE) clean) - (cd tools; $(MAKE) clean) - (cd man; $(MAKE) clean) - (cd doc; $(MAKE) clean) - (cd patch; $(MAKE) clean) - (cd examples; $(MAKE) clean) - -realclean: clean-distrib - (cd compiler;$(MAKE) realclean) - (cd stdlib; $(MAKE) realclean) - (cd interpreter; $(MAKE) realclean) - (cd toplevel; $(MAKE) realclean) - (cd tools; $(MAKE) realclean) - (cd man; $(MAKE) realclean) - (cd doc; $(MAKE) realclean) - (cd patch; $(MAKE) realclean) - (cd examples; $(MAKE) realclean) - rm -rf META - rm -rf config config-stamp Makefile.common distrib/rml/rmlc.in distrib/rml/Makefile *~ - touch config - rm -rf configure-tools/rmlbuild.config - -cleanall: realclean - -# Making distribution -DATE=`date "+%Y-%m-%d"` - -public-distrib: - touch config - $(MAKE) realclean - mkdir -p distrib/rml-$(VERSION)-$(DATE) - cp -r compiler interpreter stdlib toplevel tools emacs doc man examples \ - distrib/rml-$(VERSION)-$(DATE) - cp -r configure configure-tools patch Makefile CHANGES INSTALL LICENSE \ - distrib/rml-$(VERSION)-$(DATE) - mkdir -p distrib/rml-$(VERSION)-$(DATE)/distrib - cp -r distrib/rml distrib/Makefile.byte distrib/Makefile.opt \ - distrib/rmlc.in.byte distrib/rmlc.in.opt \ - distrib/rml-$(VERSION)-$(DATE)/distrib - (cd distrib/rml-$(VERSION)-$(DATE)/patch; \ - $(MAKE) public-distrib) - (cd distrib; \ - tar --exclude=CVS --exclude=.svn --exclude=.git -zcvf rml-$(VERSION)-$(DATE).tar.gz rml-$(VERSION)-$(DATE); \ - rm -rf rml-$(VERSION)-$(DATE); \ - mv rml-$(VERSION)-$(DATE).tar.gz ..) - - -source-distrib: - touch config - $(MAKE) realclean - mkdir -p distrib/rml-$(VERSION)-$(DATE) - cp -r compiler interpreter stdlib toplevel tools emacs doc man examples \ - distrib/rml-$(VERSION)-$(DATE) - cp -r configure configure-tools patch Makefile CHANGES INSTALL LICENSE \ - distrib/rml-$(VERSION)-$(DATE) - mkdir -p distrib/rml-$(VERSION)-$(DATE)/distrib - cp -r distrib/rml distrib/Makefile.byte distrib/Makefile.opt \ - distrib/rmlc.in.byte distrib/rmlc.in.opt \ - distrib/rml-$(VERSION)-$(DATE)/distrib - (cd distrib; \ - tar --exclude=CVS --exclude=.svn --exclude=.git -zcvf rml-$(VERSION)-$(DATE).tar.gz rml-$(VERSION)-$(DATE); \ - rm -rf rml-$(VERSION)-$(DATE); \ - mv rml-$(VERSION)-$(DATE).tar.gz ..) - -binary-distrib: binary-distrib.opt - -binary-distrib.opt: clean-distrib - touch config - $(MAKE) realclean - ./configure - (cd compiler; touch .depend; $(MAKE) depend; $(MAKE) opt) - (cd stdlib; $(MAKE) all) - (cd interpreter; $(MAKE) all) - (cd toplevel; $(MAKE) all) - (cd tools; $(MAKE) opt) - (cd distrib/rml/; \ - mkdir bin lib lib/rml; \ - cp ../../compiler/rmlc.opt bin/rmlc.opt ; \ - cp ../../toplevel/rmltop bin/rmltop ; \ - cp ../../stdlib/*.rzi ../../stdlib/*.rmli lib/rml ; \ - cp ../../interpreter/*.cma ../../interpreter/*.cmxa ../../interpreter/*.a ../../interpreter/*.cmi lib/rml ; \ - cp ../../toplevel/*.cmo ../../toplevel/*.cmi lib/rml ; \ - cp ../../tools/rmldep/rmldep.opt bin/rmldep ; \ - cp -r ../../emacs . ; \ - cp ../Makefile.opt Makefile; \ - cp ../rmlc.in.opt rmlc.in; \ - cd ..; \ - tar --exclude=CVS --exclude=.svn --exclude=.git -zcvf rml-`../compiler/rmlc -version`.opt.tar.gz rml; \ - mv rml-`../compiler/rmlc -version`.opt.tar.gz ..) - -binary-distrib.byte: clean-distrib - touch config - $(MAKE) realclean - ./configure - (cd compiler; touch .depend; $(MAKE) depend; $(MAKE) byte) - (cd stdlib; $(MAKE) all) - (cd interpreter; $(MAKE) all) - (cd toplevel; $(MAKE) all) - (cd tools; $(MAKE) all) - (cd distrib/rml/ ; \ - mkdir bin lib lib/rml ; \ - cp ../../compiler/rmlc.byte bin/rmlc.byte ; \ - cp ../../toplevel/rmltop bin/rmltop ; \ - cp ../../stdlib/*.rzi ../../stdlib/*.rmli lib/rml ; \ - cp ../../interpreter/*.cma ../../interpreter/*.cmxa ../../interpreter/*.a ../../interpreter/*.cmi lib/rml ; \ - cp ../../toplevel/*.cmo ../../toplevel/*.cmi lib/rml ; \ - cp ../../tools/rmldep/rmldep.byte bin/rmldep ; \ - cp -r ../../emacs . ; \ - cp ../Makefile.byte Makefile ; \ - cp ../rmlc.in.byte rmlc.in ; \ - cd ..; tar --exclude=CVS --exclude=.svn --exclude=.git -zcvf rml-`../compiler/rmlc -version`.byte.tar.gz rml ; \ - mv rml-`../compiler/rmlc -version`.byte.tar.gz ..) - -clean-distrib: - rm -rf distrib/rml/bin \ - distrib/rml/lib \ - distrib/rml/emacs \ - distrib/rml/man - - rm -f rml-`./compiler/rmlc -version`.*.tar.gz - rm -f rml-$(VERSION)-????-??-??.tar.gz - -FORCE: + rm -f compiler/global/version.ml + dune clean diff --git a/compiler/dune b/compiler/dune new file mode 100644 index 00000000..8baf2e1c --- /dev/null +++ b/compiler/dune @@ -0,0 +1,87 @@ +(rule (target rmlc.ml) (action (copy main/rmlc.ml rmlc.ml))) +(rule (target compiler.ml) (action (copy main/compiler.ml compiler.ml))) +(rule (target rml_errors.ml) (action (copy main/rml_errors.ml rml_errors.ml))) +(rule (target options.ml) (action (copy main/options.ml options.ml))) +(rule (target configure.ml) (action (copy main/configure.ml configure.ml))) +(rule (target interactive.ml) (action (copy main/interactive.ml interactive.ml))) + +(rule (target rml_misc.ml) (action (copy global/rml_misc.ml rml_misc.ml))) +(rule (target version.ml) (action (copy global/version.ml version.ml))) +(rule (target modules.ml) (action (copy global/modules.ml modules.ml))) +(rule (target global_ident.ml) (action (copy global/global_ident.ml global_ident.ml))) +(rule (target rml_ident.ml) (action (copy global/rml_ident.ml rml_ident.ml))) +(rule (target rml_asttypes.ml) (action (copy global/rml_asttypes.ml rml_asttypes.ml))) +(rule (target global.ml) (action (copy global/global.ml global.ml))) +(rule (target def_modules.ml) (action (copy global/def_modules.ml def_modules.ml))) +(rule (target rzi.ml) (deps ../configure-tools/embedrzi.exe (env_var RML_RECOMPILE_RZI)) (action (with-stdout-to rzi.ml (run ../configure-tools/embedrzi.exe ..)))) +(rule (target warnings.ml) (action (copy global/warnings.ml warnings.ml))) +(rule (target symbol_table.ml) (action (copy global/symbol_table.ml symbol_table.ml))) +(rule (target initialization.ml) (action (copy global/initialization.ml initialization.ml))) + +(rule (target def_types.ml) (action (copy typing/def_types.ml def_types.ml))) +(rule (target reactivity_check.ml) (action (copy typing/reactivity_check.ml reactivity_check.ml))) +(rule (target reactivity_effects.ml) (action (copy typing/reactivity_effects.ml reactivity_effects.ml))) +(rule (target rml_types.ml) (action (copy typing/rml_types.ml rml_types.ml))) +(rule (target types_printer.ml) (action (copy typing/types_printer.ml types_printer.ml))) +(rule (target typing_errors.ml) (action (copy typing/typing_errors.ml typing_errors.ml))) +(rule (target typing.ml) (action (copy typing/typing.ml typing.ml))) + +(rule (target def_static.ml) (action (copy static/def_static.ml def_static.ml))) +(rule (target static_errors.ml) (action (copy static/static_errors.ml static_errors.ml))) +(rule (target static_printer.ml) (action (copy static/static_printer.ml static_printer.ml))) +(rule (target static.ml) (action (copy static/static.ml static.ml))) + +(rule (target parse_ident.ml) (action (copy parsing/parse_ident.ml parse_ident.ml))) +(rule (target parse_ast.ml) (action (copy parsing/parse_ast.ml parse_ast.ml))) +(rule (target rml_syntaxerr.ml) (action (copy parsing/rml_syntaxerr.ml rml_syntaxerr.ml))) +(rule (target parse_printer.ml) (action (copy parsing/parse_printer.ml parse_printer.ml))) +(rule (target location.ml) (action (copy parsing/location.ml location.ml))) +(rule (target linenum.mll) (action (copy parsing/linenum.mll linenum.mll))) +(rule (target rml_parse.ml) (action (copy parsing/rml_parse.ml rml_parse.ml))) +(rule (target rml_parser.mly) (action (copy parsing/rml_parser.mly rml_parser.mly))) +(rule (target rml_lexer.mll) (action (copy parsing/rml_lexer.mll rml_lexer.mll))) + +(rule (target binding_errors.ml) (action (copy reac/binding_errors.ml binding_errors.ml))) +(rule (target parse2reac.ml) (action (copy reac/parse2reac.ml parse2reac.ml))) +(rule (target reac_ast.ml) (action (copy reac/reac_ast.ml reac_ast.ml))) +(rule (target reac_misc.ml) (action (copy reac/reac_misc.ml reac_misc.ml))) +(rule (target reac2reac.ml) (action (copy reac/reac2reac.ml reac2reac.ml))) +(rule (target rml_annot.ml) (action (copy reac/rml_annot.ml rml_annot.ml))) + +(rule (target reac_optimization.ml) (action (copy optimization/reac_optimization.ml reac_optimization.ml))) + +(rule (target instantaneous_loop.ml) (action (copy other_analysis/instantaneous_loop.ml instantaneous_loop.ml))) +(rule (target wf_rec.ml) (action (copy other_analysis/wf_rec.ml wf_rec.ml))) + +(rule (target lk_ast.ml) (action (copy lk/lk_ast.ml lk_ast.ml))) +(rule (target lk_misc.ml) (action (copy lk/lk_misc.ml lk_misc.ml))) +(rule (target reac2lk.ml) (action (copy lk/reac2lk.ml reac2lk.ml))) + +(rule (target lco_ast.ml) (action (copy lco/lco_ast.ml lco_ast.ml))) +(rule (target lco_misc.ml) (action (copy lco/lco_misc.ml lco_misc.ml))) +(rule (target reac2lco.ml) (action (copy lco/reac2lco.ml reac2lco.ml))) + +(rule (target caml_ast.ml) (action (copy caml/caml_ast.ml caml_ast.ml))) +(rule (target caml_misc.ml) (action (copy caml/caml_misc.ml caml_misc.ml))) +(rule (target caml2caml.ml) (action (copy caml/caml2caml.ml caml2caml.ml))) +(rule (target lco2caml.ml) (action (copy caml/lco2caml.ml lco2caml.ml))) +(rule (target lk2caml.ml) (action (copy caml/lk2caml.ml lk2caml.ml))) +(rule (target print_caml_src.ml) (action (copy caml/print_caml_src.ml print_caml_src.ml))) + +(rule (target external.ml) (action (copy external/external.ml external.ml))) +(rule (target lucky.ml) (action (copy external/lucky.ml lucky.ml))) +(rule (target lucky_errors.ml) (action (copy external/lucky_errors.ml lucky_errors.ml))) + +(ocamllex + (modules rml_lexer linenum)) + +(menhir + (modules rml_parser)) + + +(executables + (names rmlc)) + +(install + (files (rmlc.exe as rmlc)) + (section bin)) \ No newline at end of file diff --git a/compiler/global/global.ml b/compiler/global/global.ml index 1581a0bb..d2fbda3d 100644 --- a/compiler/global/global.ml +++ b/compiler/global/global.ml @@ -28,7 +28,7 @@ (* $Id$ *) -open Rml_misc +(* open Rml_misc unused open *) (* values in the symbol table *) diff --git a/compiler/main/compiler.ml b/compiler/main/compiler.ml index d3c179fb..989972b8 100644 --- a/compiler/main/compiler.ml +++ b/compiler/main/compiler.ml @@ -292,6 +292,7 @@ let compile_implementation module_name filename = "(* "^(Array.fold_right (fun s cmd -> s^" "^cmd) Sys.argv " ")^ "*)\n\n"); (* selection of the interpreter *) + output_string out_chan ("open Rmllib;;\n"); output_string out_chan ("open "^ !interpreter_impl ^";;\n"); (* the implementation *) @@ -452,6 +453,7 @@ let compile_interface parse module_name filename filename_end = begin let out_chan = open_out obj_name in (* selection of the interpreter *) + output_string out_chan ("open Rmllib;;\n"); output_string out_chan ("open "^ !interpreter_impl ^";;\n"); (* the interface *) diff --git a/compiler/main/options.ml b/compiler/main/options.ml index 9b0f91ea..a91468d4 100644 --- a/compiler/main/options.ml +++ b/compiler/main/options.ml @@ -24,60 +24,59 @@ open Rml_misc open Configure -let _ = - let runtime = ref "Lco" in - let v = ref false in - let version = ref false in - let where = ref false in - let stdlib = ref None in - try - Arg.parse - [ "-stdlib", Arg.String (fun s -> stdlib := Some s), doc_stdlib; - "-v", Arg.Set v, doc_v; - "-version", Arg.Set version, doc_version; - "-where", Arg.Set where, doc_where; - "-c",Arg.Set no_link, doc_compilation; - "-I",Arg.String add_include,doc_libraries; - "-s", Arg.String set_simulation_process, doc_simulation; - "-n", Arg.Int set_number_of_instant, doc_number_of_instant; - "-sampling", Arg.Float set_sampling, doc_sampling; - "-i", Arg.Unit set_verbose, doc_verbose; - "-annot", Arg.Unit set_save_types, doc_save_types; - "-dtypes", Arg.Unit set_save_types, doc_save_types; - "-no_reactivity_warning", Arg.Unit unset_reactivity_warning, doc_no_reactivity_warning; - "-dreactivity", Arg.Unit set_dreactivity, doc_dreactivity; - "-no_reactivity_simpl", Arg.Unit unset_no_reactivity_simpl, doc_no_reactivity_simpl; - "-old_loop_warning", Arg.Unit set_old_instantaneous_loop_warning, doc_old_loop_warning; - "-runtime", Arg.Set_string runtime, doc_runtime; - "-thread", Arg.Set with_thread, doc_thread; - "-debug", Arg.Set with_debug, doc_debug; - "-interactive", Arg.Unit set_interactive, doc_interactive; - "-d", Arg.String set_output_dir, doc_d; - "-nostdlib", Arg.Unit set_no_stdlib, doc_no_stdlib; - "-no_nary_opt", Arg.Unit set_no_nary, doc_no_nary; - "-no_static_opt", Arg.Unit set_no_static, doc_no_static; - "-no_for_opt", Arg.Unit set_no_for, doc_no_for; - "-no_const_opt", Arg.Clear const_optimization, doc_no_const_opt; - "-dparse", Arg.Unit set_dparse, doc_dparse; - "-dtime", Arg.Unit set_dtime, doc_dtime; - ] - add_to_compile - errmsg; - set_runtime !runtime; - begin match !stdlib with - | None -> () - | Some s -> set_stdlib s - end; - if !v then show_v (); - if !version then show_version (); - if !where then show_where (); - if !with_thread then add_stdlib_thread (); - with x -> - Rml_errors.report_error Format.err_formatter x; - exit 2 +let set_options () = + let _ = + let runtime = ref "Lco" in + let v = ref false in + let version = ref false in + let where = ref false in + let stdlib = ref None in + try + Arg.parse + [ "-stdlib", Arg.String (fun s -> stdlib := Some s), doc_stdlib; + "-v", Arg.Set v, doc_v; + "-version", Arg.Set version, doc_version; + "-where", Arg.Set where, doc_where; + "-c",Arg.Set no_link, doc_compilation; + "-I",Arg.String add_include,doc_libraries; + "-s", Arg.String set_simulation_process, doc_simulation; + "-n", Arg.Int set_number_of_instant, doc_number_of_instant; + "-sampling", Arg.Float set_sampling, doc_sampling; + "-i", Arg.Unit set_verbose, doc_verbose; + "-annot", Arg.Unit set_save_types, doc_save_types; + "-dtypes", Arg.Unit set_save_types, doc_save_types; + "-no_reactivity_warning", Arg.Unit unset_reactivity_warning, doc_no_reactivity_warning; + "-dreactivity", Arg.Unit set_dreactivity, doc_dreactivity; + "-no_reactivity_simpl", Arg.Unit unset_no_reactivity_simpl, doc_no_reactivity_simpl; + "-old_loop_warning", Arg.Unit set_old_instantaneous_loop_warning, doc_old_loop_warning; + "-runtime", Arg.Set_string runtime, doc_runtime; + "-thread", Arg.Set with_thread, doc_thread; + "-debug", Arg.Set with_debug, doc_debug; + "-interactive", Arg.Unit set_interactive, doc_interactive; + "-d", Arg.String set_output_dir, doc_d; + "-nostdlib", Arg.Unit set_no_stdlib, doc_no_stdlib; + "-no_nary_opt", Arg.Unit set_no_nary, doc_no_nary; + "-no_static_opt", Arg.Unit set_no_static, doc_no_static; + "-no_for_opt", Arg.Unit set_no_for, doc_no_for; + "-no_const_opt", Arg.Clear const_optimization, doc_no_const_opt; + "-dparse", Arg.Unit set_dparse, doc_dparse; + "-dtime", Arg.Unit set_dtime, doc_dtime; + ] + add_to_compile + errmsg; + set_runtime !runtime; + begin match !stdlib with + | None -> () + | Some s -> set_stdlib s + end; + if !v then show_v (); + if !version then show_version (); + if !where then show_where (); + if !with_thread then add_stdlib_thread (); + with x -> + Rml_errors.report_error Format.err_formatter x; + exit 2 -let _ = - to_compile := List.rev !to_compile - -let _ = + in to_compile := List.rev !to_compile; + Printexc.catch configure () diff --git a/compiler/main/rmlc.ml b/compiler/main/rmlc.ml index b5db6fea..072379d4 100644 --- a/compiler/main/rmlc.ml +++ b/compiler/main/rmlc.ml @@ -32,6 +32,8 @@ open Rml_misc open Modules open Compiler +let () = Options.set_options () + (* list of object files passed on the command line *) let object_files = ref [] diff --git a/compiler/parsing/location.ml b/compiler/parsing/location.ml index 02b326c3..9ce2dd78 100644 --- a/compiler/parsing/location.ml +++ b/compiler/parsing/location.ml @@ -67,7 +67,7 @@ let curr lexbuf = { loc_end = lexbuf.lex_curr_p; loc_ghost = false };; - +(* let symbol_rloc () = { loc_start = Parsing.symbol_start_pos (); loc_end = Parsing.symbol_end_pos (); @@ -84,6 +84,18 @@ let rhs_loc n = { loc_start = Parsing.rhs_start_pos n; loc_end = Parsing.rhs_end_pos n; loc_ghost = false; +};;*) + +let loc_of_pos (ps, pe) = { + loc_start = ps; + loc_end = pe; + loc_ghost = false; +};; + +let gloc_of_pos (ps, pe) = { + loc_start = ps; + loc_end = pe; + loc_ghost = true; };; let input_name = ref "" diff --git a/compiler/parsing/rml_parse.ml b/compiler/parsing/rml_parse.ml index 964167be..1df861bf 100644 --- a/compiler/parsing/rml_parse.ml +++ b/compiler/parsing/rml_parse.ml @@ -79,7 +79,7 @@ let wrap parsing_fun lexbuf = | Rml_syntaxerr.Error _ as err -> if !Location.input_name = "" then maybe_skip_phrase lexbuf; raise err - | Parsing.Parse_error | Rml_syntaxerr.Escape_error -> + | Parsing.Parse_error | Rml_parser.Error | Rml_syntaxerr.Escape_error -> let loc = Location.curr lexbuf in if !Location.input_name = "" then maybe_skip_phrase lexbuf; diff --git a/compiler/parsing/rml_parser.mly b/compiler/parsing/rml_parser.mly index be14c766..c3682bf6 100644 --- a/compiler/parsing/rml_parser.mly +++ b/compiler/parsing/rml_parser.mly @@ -48,47 +48,49 @@ open Rml_asttypes open Parse_ident open Parse_ast -let mkident id pos = +let mkident id (ps, pe) = { pident_id = id; - pident_loc = rhs_loc pos; } + pident_loc = loc_of_pos (ps, pe) } + + let mkident_loc id loc = { pident_id = id; pident_loc = loc; } let mksimple id pos = { psimple_id = id; - psimple_loc = rhs_loc pos; } -let mksimple_loc id loc = + psimple_loc = loc_of_pos pos; } +let _mksimple_loc id loc = { psimple_id = id; psimple_loc = loc; } -let mkte d = - { pte_desc = d; pte_loc = symbol_rloc() } -let mkpatt d = - { ppatt_desc = d; ppatt_loc = symbol_rloc() } -let mkexpr d = +let mkte d loc = + { pte_desc = d; pte_loc = loc_of_pos loc } +let mkpatt d loc = + { ppatt_desc = d; ppatt_loc = loc_of_pos loc } +let mkexpr d loc = { pexpr_desc = d; - pexpr_loc = symbol_rloc(); } -let mkconf d = + pexpr_loc = loc_of_pos loc; } +let mkconf d loc = { pconf_desc = d; - pconf_loc = symbol_rloc(); } -let mkimpl d = - { pimpl_desc = d; pimpl_loc = symbol_rloc() } -let mkintf d = - { pintf_desc = d; pintf_loc = symbol_rloc() } + pconf_loc = loc_of_pos loc; } +let mkimpl d loc = + { pimpl_desc = d; pimpl_loc = loc_of_pos loc } +let mkintf d loc = + { pintf_desc = d; pintf_loc = loc_of_pos loc } -let rec mkexpr_until body cfg_when_opt_expr_opt_list = +let mkexpr_until body cfg_when_opt_expr_opt_list loc = match cfg_when_opt_expr_opt_list with - | [] -> raise Parse_error + | [] -> raise Parsing.Parse_error | _ :: _ -> - mkexpr (Pexpr_until (body, cfg_when_opt_expr_opt_list)) + mkexpr (Pexpr_until (body, cfg_when_opt_expr_opt_list)) loc -let reloc_patt x = { x with ppatt_loc = symbol_rloc () };; -let reloc_expr x = { x with pexpr_loc = symbol_rloc () };; +let reloc_patt x loc = { x with ppatt_loc = loc_of_pos loc };; +let reloc_expr x loc = { x with pexpr_loc = loc_of_pos loc };; let mkoperator name pos = { pexpr_desc = Pexpr_ident (mkident (Pident name) pos); - pexpr_loc = rhs_loc pos; } + pexpr_loc = loc_of_pos pos; } (* @@ -108,35 +110,36 @@ let mkoperator name pos = AST node, then the location must be real; in all other cases, it must be ghost. *) -let ghexpr d = { pexpr_desc = d; - pexpr_loc = symbol_gloc (); };; -let ghpatt d = { ppatt_desc = d; ppatt_loc = symbol_gloc () };; -let ghte d = { pte_desc = d; pte_loc = symbol_gloc () };; -let ghimpl d = { pimpl_desc = d; pimpl_loc = symbol_gloc () };; +let ghexpr d loc = { pexpr_desc = d; + pexpr_loc = gloc_of_pos loc; };; +let ghpatt d loc = { ppatt_desc = d; ppatt_loc = gloc_of_pos loc };; +let _ghte d loc = { pte_desc = d; pte_loc = gloc_of_pos loc };; +let ghimpl d loc = { pimpl_desc = d; pimpl_loc = loc };; -let ghexpr_unit () = ghexpr (Pexpr_constant(Const_unit)) +let ghexpr_unit loc = ghexpr (Pexpr_constant(Const_unit)) loc let mkassert e = mkexpr (Pexpr_assert (e)) ;; -let mkinfix arg1 name arg2 = - mkexpr(Pexpr_apply(mkoperator name 2, [arg1; arg2])) +let mkinfix arg1 name arg2 pos = + mkexpr(Pexpr_apply(mkoperator name pos, [arg1; arg2])) pos + +let mkuminus name arg pos1 = -let mkuminus name arg = match name, arg.pexpr_desc with | "-", Pexpr_constant(Const_int n) -> mkexpr(Pexpr_constant(Const_int(-n))) | _, Pexpr_constant(Const_float f) -> mkexpr(Pexpr_constant(Const_float(-. f))) | _ -> - mkexpr(Pexpr_apply(mkoperator ("~" ^ name) 1, [arg])) + mkexpr(Pexpr_apply(mkoperator ("~" ^ name) pos1, [arg])) -let rec mktailexpr = function +let rec mktailexpr loc = function [] -> - ghexpr(Pexpr_construct( mkident_loc (Pident "[]") none, None)) + ghexpr(Pexpr_construct( mkident_loc (Pident "[]") none, None)) loc | e1 :: el -> - let exp_el = mktailexpr el in + let exp_el = mktailexpr loc el in let l = {loc_start = e1.pexpr_loc.loc_start; loc_end = exp_el.pexpr_loc.loc_end; loc_ghost = true} @@ -148,11 +151,11 @@ let rec mktailexpr = function Some arg); pexpr_loc = l;} -let rec mktailpatt = function +let rec mktailpatt loc = function [] -> - ghpatt(Ppatt_construct(mkident_loc (Pident "[]") none, None)) + ghpatt(Ppatt_construct(mkident_loc (Pident "[]") none, None)) loc | p1 :: pl -> - let pat_pl = mktailpatt pl in + let pat_pl = mktailpatt loc pl in let l = {loc_start = p1.ppatt_loc.loc_start; loc_end = pat_pl.ppatt_loc.loc_end; loc_ghost = true} @@ -165,22 +168,22 @@ let rec mktailpatt = function let array_function str name = mkident_loc (Pdot(str, name)) none -let rec deep_mkrangepatt c1 c2 = - if c1 = c2 then ghpatt(Ppatt_constant(Const_char c1)) else - ghpatt(Ppatt_or(ghpatt(Ppatt_constant(Const_char c1)), - deep_mkrangepatt (Char.chr(Char.code c1 + 1)) c2)) +let rec deep_mkrangepatt c1 c2 loc = + if c1 = c2 then ghpatt(Ppatt_constant(Const_char c1)) loc else + ghpatt(Ppatt_or(ghpatt(Ppatt_constant(Const_char c1)) loc, + deep_mkrangepatt (Char.chr(Char.code c1 + 1)) c2 loc)) loc -let rec mkrangepatt c1 c2 = - if c1 > c2 then mkrangepatt c2 c1 else - if c1 = c2 then mkpatt(Ppatt_constant(Const_char c1)) else - reloc_patt (deep_mkrangepatt c1 c2) +let rec mkrangepatt c1 c2 loc = + if c1 > c2 then mkrangepatt c2 c1 loc else + if c1 = c2 then mkpatt (Ppatt_constant(Const_char c1)) loc else + reloc_patt (deep_mkrangepatt c1 c2 loc) loc let syntax_error () = raise Rml_syntaxerr.Escape_error -let unclosed opening_name opening_num closing_name closing_num = - raise(Rml_syntaxerr.Error(Rml_syntaxerr.Unclosed(rhs_loc opening_num, opening_name, - rhs_loc closing_num, closing_name))) +let unclosed opening_name opening_loc closing_name closing_loc = + raise(Rml_syntaxerr.Error(Rml_syntaxerr.Unclosed(loc_of_pos opening_loc, opening_name, + loc_of_pos closing_loc, closing_name))) %} @@ -410,7 +413,7 @@ interface: interactive: /* empty */ { exit 0 } | interactive_defs { $1 } - | seq_expr SEMISEMI { [ghimpl (Pimpl_expr $1)] } + | seq_expr SEMISEMI { [ghimpl (Pimpl_expr $1) (gloc_of_pos $loc)] } ; interactive_defs: structure_item SEMISEMI { [$1] } @@ -421,40 +424,40 @@ interactive_defs: structure: structure_tail { $1 } - | seq_expr structure_tail { ghimpl (Pimpl_expr $1) :: $2 } + | seq_expr structure_tail { ghimpl (Pimpl_expr $1) ($1).pexpr_loc :: $2 } ; structure_tail: /* empty */ { [] } | SEMISEMI { [] } - | SEMISEMI seq_expr structure_tail { ghimpl (Pimpl_expr $2) :: $3 } + | SEMISEMI seq_expr structure_tail { ghimpl (Pimpl_expr $2) ($2).pexpr_loc :: $3 } | SEMISEMI structure_item structure_tail { $2 :: $3 } | structure_item structure_tail { $1 :: $2 } ; structure_item: LET rec_flag let_bindings { match $3 with - [{ppatt_desc = Ppatt_any}, exp] -> mkimpl(Pimpl_expr exp) - | _ -> mkimpl(Pimpl_let($2, List.rev $3)) } + [{ppatt_desc = Ppatt_any; _}, exp] -> mkimpl(Pimpl_expr exp) $loc + | _ -> mkimpl(Pimpl_let($2, List.rev $3)) $loc } | SIGNAL signal_comma_list - { mkimpl(Pimpl_signal(List.rev $2, None)) } + { mkimpl(Pimpl_signal(List.rev $2, None)) $loc } | SIGNAL signal_comma_list DEFAULT par_expr GATHER par_expr - { mkimpl(Pimpl_signal(List.rev $2, Some(Default, $4, $6))) } + { mkimpl(Pimpl_signal(List.rev $2, Some(Default, $4, $6))) $loc } | SIGNAL signal_comma_list MEMORY par_expr GATHER par_expr - { mkimpl(Pimpl_signal(List.rev $2, Some(Memory, $4, $6))) } + { mkimpl(Pimpl_signal(List.rev $2, Some(Memory, $4, $6))) $loc } | TYPE type_declarations - { mkimpl(Pimpl_type(List.rev $2)) } + { mkimpl(Pimpl_type(List.rev $2)) $loc } | EXCEPTION UIDENT constructor_arguments - { mkimpl(Pimpl_exn(mksimple $2 2, $3)) } + { mkimpl(Pimpl_exn(mksimple $2 ($startpos($2), $endpos($2)), $3)) $loc } | EXCEPTION UIDENT EQUAL constr_longident - { mkimpl(Pimpl_exn_rebind(mksimple $2 2, $4)) } + { mkimpl(Pimpl_exn_rebind(mksimple $2 ($startpos($2), $endpos($2)), $4)) $loc } | OPEN UIDENT - { mkimpl(Pimpl_open $2) } + { mkimpl(Pimpl_open $2) $loc } | EXTERNAL DOT LIDENT LIDENT lucky_declarations lucky_declarations EQUAL lucky_files { match $3 with | "luc" -> - mkimpl(Pimpl_lucky(mksimple $4 4, List.rev $5, List.rev $6, $8)) - | _ -> raise (Rml_syntaxerr.Error(Rml_syntaxerr.Other (rhs_loc 1))) + mkimpl(Pimpl_lucky(mksimple $4 ($startpos($4), $endpos($4)), List.rev $5, List.rev $6, $8)) $loc + | _ -> raise (Rml_syntaxerr.Error(Rml_syntaxerr.Other (loc_of_pos ($startpos($1), $endpos($1))))) } ; @@ -467,218 +470,218 @@ signature: ; signature_item: VAL val_ident_colon core_type - { mkintf(Pintf_val($2, $3)) } + { mkintf(Pintf_val($2, $3)) $loc } | EXTERNAL val_ident_colon core_type EQUAL primitive_declaration - { mkintf(Pintf_val($2, $3)) } + { mkintf(Pintf_val($2, $3)) $loc } | TYPE type_declarations - { mkintf(Pintf_type(List.rev $2)) } + { mkintf(Pintf_type(List.rev $2)) $loc } | EXCEPTION UIDENT constructor_arguments - { mkintf(Pintf_exn(mksimple $2 2, $3)) } + { mkintf(Pintf_exn(mksimple $2 ($startpos($2), $endpos($2)), $3)) $loc } | OPEN UIDENT - { mkintf(Pintf_open $2) } + { mkintf(Pintf_open $2) $loc } ; /* Core expressions */ par_expr: | seq_expr %prec below_BARBAR { $1} - | seq_expr BARBAR par_expr { mkexpr(Pexpr_par($1, $3)) } - | seq_expr BARGRATER par_expr { mkexpr(Pexpr_merge($1, $3)) } + | seq_expr BARBAR par_expr { mkexpr(Pexpr_par($1, $3)) $loc } + | seq_expr BARGRATER par_expr { mkexpr(Pexpr_merge($1, $3)) $loc } ; seq_expr: | expr %prec below_SEMI { $1 } - | expr SEMI { reloc_expr $1 } - | expr SEMI seq_expr { mkexpr(Pexpr_seq($1, $3)) } + | expr SEMI { reloc_expr $1 $loc } + | expr SEMI seq_expr { mkexpr(Pexpr_seq($1, $3)) $loc } ; expr: simple_expr %prec below_SHARP { $1 } | simple_expr simple_expr_list - { mkexpr(Pexpr_apply($1, List.rev $2)) } + { mkexpr(Pexpr_apply($1, List.rev $2)) $loc } | LET rec_flag let_bindings IN par_expr - { mkexpr(Pexpr_let($2, List.rev $3, $5)) } + { mkexpr(Pexpr_let($2, List.rev $3, $5)) $loc } | FUNCTION opt_bar match_cases - { mkexpr(Pexpr_function(List.rev $3)) } + { mkexpr(Pexpr_function(List.rev $3)) $loc } | FUN simple_pattern fun_def { let when_opt, expr = $3 in - mkexpr(Pexpr_function([$2, when_opt, expr])) } + mkexpr(Pexpr_function([$2, when_opt, expr])) $loc } | MATCH par_expr WITH opt_bar match_cases - { mkexpr(Pexpr_match($2, List.rev $5)) } + { mkexpr(Pexpr_match($2, List.rev $5)) $loc } | TRY par_expr WITH opt_bar match_cases - { mkexpr(Pexpr_trywith($2, List.rev $5)) } + { mkexpr(Pexpr_trywith($2, List.rev $5)) $loc } | TRY par_expr WITH error { syntax_error() } | expr_comma_list %prec below_COMMA - { mkexpr(Pexpr_tuple(List.rev $1)) } + { mkexpr(Pexpr_tuple(List.rev $1)) $loc } | constr_longident simple_expr %prec prec_constr_appl /*%prec below_SHARP */ - { mkexpr(Pexpr_construct($1, Some $2)) } + { mkexpr(Pexpr_construct($1, Some $2)) $loc } | IF par_expr THEN expr ELSE expr - { mkexpr(Pexpr_ifthenelse($2, $4, Some $6)) } + { mkexpr(Pexpr_ifthenelse($2, $4, Some $6)) $loc } | IF par_expr THEN expr - { mkexpr(Pexpr_ifthenelse($2, $4, None)) } + { mkexpr(Pexpr_ifthenelse($2, $4, None)) $loc } | WHILE par_expr DO par_expr DONE - { mkexpr(Pexpr_while($2, $4)) } + { mkexpr(Pexpr_while($2, $4)) $loc } | FOR val_ident EQUAL par_expr direction_flag par_expr DO par_expr DONE - { mkexpr(Pexpr_for($2, $4, $6, $5, $8)) } + { mkexpr(Pexpr_for($2, $4, $6, $5, $8)) $loc } | FOR val_ident EQUAL par_expr direction_flag par_expr DOPAR par_expr DONE - { mkexpr(Pexpr_fordopar($2, $4, $6, $5, $8)) } + { mkexpr(Pexpr_fordopar($2, $4, $6, $5, $8)) $loc } | expr COLONCOLON expr - { mkexpr(Pexpr_construct(mkident (Pident "::") 2, - Some(ghexpr(Pexpr_tuple[$1;$3])))) } + { mkexpr(Pexpr_construct(mkident (Pident "::") ($startpos($2), $endpos($2)), + Some(ghexpr(Pexpr_tuple[$1;$3]) $loc))) $loc } | expr INFIXOP0 expr - { mkinfix $1 $2 $3 } + { mkinfix $1 $2 $3 $loc } | expr INFIXOP1 expr - { mkinfix $1 $2 $3 } + { mkinfix $1 $2 $3 $loc } | expr INFIXOP2 expr - { mkinfix $1 $2 $3 } + { mkinfix $1 $2 $3 $loc } | expr INFIXOP3 expr - { mkinfix $1 $2 $3 } + { mkinfix $1 $2 $3 $loc } | expr INFIXOP4 expr - { mkinfix $1 $2 $3 } + { mkinfix $1 $2 $3 $loc } | expr PLUS expr - { mkinfix $1 "+" $3 } + { mkinfix $1 "+" $3 $loc } | expr MINUS expr - { mkinfix $1 "-" $3 } + { mkinfix $1 "-" $3 $loc } | expr MINUSDOT expr - { mkinfix $1 "-." $3 } + { mkinfix $1 "-." $3 $loc } | expr STAR expr - { mkinfix $1 "*" $3 } + { mkinfix $1 "*" $3 $loc } | expr EQUAL expr - { mkinfix $1 "=" $3 } + { mkinfix $1 "=" $3 $loc } | expr LESS expr - { mkinfix $1 "<" $3 } + { mkinfix $1 "<" $3 $loc } | expr GREATER expr - { mkinfix $1 ">" $3 } + { mkinfix $1 ">" $3 $loc } | expr OR expr - { mkinfix $1 "or" $3 } + { mkinfix $1 "or" $3 $loc } | expr AMPERSAND expr - { mkinfix $1 "&" $3 } + { mkinfix $1 "&" $3 $loc } | expr AMPERAMPER expr - { mkinfix $1 "&&" $3 } + { mkinfix $1 "&&" $3 $loc } | expr COLONEQUAL expr - { mkinfix $1 ":=" $3 } + { mkinfix $1 ":=" $3 $loc } | subtractive expr %prec prec_unary_minus - { mkuminus $1 $2 } + { mkuminus $1 $2 ($startpos($1), $endpos($1)) $loc } | simple_expr DOT label_longident LESSMINUS expr - { mkexpr(Pexpr_record_update($1, $3, $5)) } + { mkexpr(Pexpr_record_update($1, $3, $5)) $loc } | simple_expr DOT LPAREN par_expr RPAREN LESSMINUS expr - { mkexpr(Pexpr_apply(ghexpr(Pexpr_ident(array_function "Array" "set")), - [$1; $4; $7])) } + { mkexpr(Pexpr_apply(ghexpr(Pexpr_ident(array_function "Array" "set")) $loc, + [$1; $4; $7])) $loc } | simple_expr DOT LBRACKET par_expr RBRACKET LESSMINUS expr - { mkexpr(Pexpr_apply(ghexpr(Pexpr_ident(array_function "String" "set")), - [$1; $4; $7])) } + { mkexpr(Pexpr_apply(ghexpr(Pexpr_ident(array_function "String" "set")) $loc, + [$1; $4; $7])) $loc } | ASSERT simple_expr %prec below_SHARP - { mkassert $2 } + { mkassert $2 $loc } | PRE pre_expr - { let k,s = $2 in mkexpr(Pexpr_pre (k,s)) } + { let k,s = $2 in mkexpr(Pexpr_pre (k,s)) $loc } | LAST QUESTION simple_expr - { mkexpr(Pexpr_last $3) } + { mkexpr(Pexpr_last $3) $loc } | DEFAULT QUESTION simple_expr - { mkexpr(Pexpr_default $3) } + { mkexpr(Pexpr_default $3) $loc } | EMIT simple_expr - { mkexpr(Pexpr_emit $2 ) } + { mkexpr(Pexpr_emit $2 ) $loc } | EMIT simple_expr simple_expr - { mkexpr(Pexpr_emit_val($2, $3)) } + { mkexpr(Pexpr_emit_val($2, $3)) $loc } | SIGNAL signal_comma_list IN par_expr - { mkexpr(Pexpr_signal(List.rev $2, None, $4)) } + { mkexpr(Pexpr_signal(List.rev $2, None, $4)) $loc } | SIGNAL signal_comma_list DEFAULT par_expr GATHER par_expr IN par_expr - { mkexpr(Pexpr_signal(List.rev $2, Some(Default, $4, $6), $8)) } + { mkexpr(Pexpr_signal(List.rev $2, Some(Default, $4, $6), $8)) $loc } | SIGNAL signal_comma_list MEMORY par_expr GATHER par_expr IN par_expr - { mkexpr(Pexpr_signal(List.rev $2, Some(Memory, $4, $6), $8)) } + { mkexpr(Pexpr_signal(List.rev $2, Some(Memory, $4, $6), $8)) $loc } | DO par_expr UNTIL opt_bar until_cases DONE - { mkexpr_until $2 $5 } + { mkexpr_until $2 $5 $loc } | DO par_expr WHEN event_config DONE - { mkexpr(Pexpr_when($4, $2)) } + { mkexpr(Pexpr_when($4, $2)) $loc } | CONTROL par_expr WITH event_config DONE - { mkexpr(Pexpr_control($4, None, $2)) } + { mkexpr(Pexpr_control($4, None, $2)) $loc } | CONTROL par_expr WITH event_config WHEN par_expr DONE - { mkexpr(Pexpr_control($4, Some $6, $2)) } + { mkexpr(Pexpr_control($4, Some $6, $2)) $loc } | PRESENT event_config THEN expr ELSE expr - { mkexpr(Pexpr_present($2, $4, $6)) } + { mkexpr(Pexpr_present($2, $4, $6)) $loc } | PRESENT event_config THEN expr - { mkexpr(Pexpr_present($2, $4, ghexpr(Pexpr_nothing))) } + { mkexpr(Pexpr_present($2, $4, ghexpr(Pexpr_nothing) $loc)) $loc } | PRESENT event_config ELSE expr - { mkexpr(Pexpr_present($2, ghexpr(Pexpr_nothing), $4)) } + { mkexpr(Pexpr_present($2, ghexpr(Pexpr_nothing) $loc, $4)) $loc } | AWAIT await_flag event_config %prec above_IN { if (snd $2) = One - then raise(Rml_syntaxerr.Error(Rml_syntaxerr.Other (rhs_loc 2))) - else mkexpr(Pexpr_await(fst $2, $3)) } + then raise(Rml_syntaxerr.Error(Rml_syntaxerr.Other (loc_of_pos ($startpos($2), $endpos($2))))) + else mkexpr(Pexpr_await(fst $2, $3)) $loc } | AWAIT await_flag event_config IN par_expr { match $2 with - | Immediate, All -> raise(Rml_syntaxerr.Error(Rml_syntaxerr.Other (rhs_loc 2))) - | im, k -> mkexpr(Pexpr_await_val(im, k, $3, None, $5)) } + | Immediate, All -> raise(Rml_syntaxerr.Error(Rml_syntaxerr.Other (loc_of_pos ($startpos($2), $endpos($2))))) + | im, k -> mkexpr(Pexpr_await_val(im, k, $3, None, $5)) $loc } | AWAIT await_flag event_config WHEN par_expr IN par_expr { match $2 with - | Immediate, All -> raise(Rml_syntaxerr.Error(Rml_syntaxerr.Other (rhs_loc 2))) + | Immediate, All -> raise(Rml_syntaxerr.Error(Rml_syntaxerr.Other (loc_of_pos ($startpos($2), $endpos($2))))) | im, k -> - mkexpr(Pexpr_await_val(im, k, $3, Some $5, $7)) } + mkexpr(Pexpr_await_val(im, k, $3, Some $5, $7)) $loc } | PROCESS proc_def { $2 } | PROC simple_pattern proc_fun_def - { mkexpr(Pexpr_function([$2, None, $3])) } + { mkexpr(Pexpr_function([$2, None, $3])) $loc } | RUN simple_expr simple_expr_list - { let e = mkexpr(Pexpr_apply($2, List.rev $3)) in - mkexpr(Pexpr_run(e)) } + { let e = mkexpr(Pexpr_apply($2, List.rev $3)) $loc in + mkexpr(Pexpr_run(e)) $loc } | RUN simple_expr - { mkexpr(Pexpr_run($2)) } + { mkexpr(Pexpr_run($2)) $loc } ; simple_expr: val_longident - { mkexpr(Pexpr_ident $1) } + { mkexpr(Pexpr_ident $1) $loc } | constant - { mkexpr(Pexpr_constant $1) } + { mkexpr(Pexpr_constant $1) $loc } | constr_longident %prec prec_constant_constructor - { mkexpr(Pexpr_construct($1, None)) } + { mkexpr(Pexpr_construct($1, None)) $loc } | LPAREN par_expr RPAREN - { reloc_expr $2 } + { reloc_expr $2 $loc } | LPAREN par_expr error - { unclosed "(" 1 ")" 3 } + { unclosed "(" ($startpos($1), $endpos($1)) ")" ($startpos($3), $endpos($3)) } | BEGIN par_expr END - { reloc_expr $2 } + { reloc_expr $2 $loc } | BEGIN END - { mkexpr (Pexpr_constant Const_unit) } + { mkexpr (Pexpr_constant Const_unit) $loc } | BEGIN par_expr error - { unclosed "begin" 1 "end" 3 } + { unclosed "begin" ($startpos($1), $endpos($1)) "end" ($startpos($3), $endpos($3)) } | LPAREN par_expr type_constraint RPAREN - { mkexpr(Pexpr_constraint($2, $3)) } + { mkexpr(Pexpr_constraint($2, $3)) $loc } | simple_expr DOT label_longident - { mkexpr(Pexpr_record_access($1, $3)) } + { mkexpr(Pexpr_record_access($1, $3)) $loc } | simple_expr DOT LPAREN par_expr RPAREN - { mkexpr(Pexpr_apply(ghexpr(Pexpr_ident(array_function "Array" "get")), - [$1; $4])) } + { mkexpr(Pexpr_apply(ghexpr(Pexpr_ident(array_function "Array" "get")) $loc, + [$1; $4])) $loc } | simple_expr DOT LPAREN par_expr error - { unclosed "(" 3 ")" 5 } + { unclosed "(" ($startpos($3), $endpos($3)) ")" ($startpos($5), $endpos($5)) } | simple_expr DOT LBRACKET par_expr RBRACKET - { mkexpr(Pexpr_apply(ghexpr(Pexpr_ident(array_function "String" "get")), - [$1; $4])) } + { mkexpr(Pexpr_apply(ghexpr(Pexpr_ident(array_function "String" "get")) $loc, + [$1; $4])) $loc } | simple_expr DOT LBRACKET par_expr error - { unclosed "[" 3 "]" 5 } + { unclosed "[" ($startpos($3), $endpos($3)) "]" ($startpos($5), $endpos($5)) } | LBRACE record_expr RBRACE - { mkexpr(Pexpr_record($2)) } + { mkexpr(Pexpr_record($2)) $loc } | LBRACE record_expr error - { unclosed "{" 1 "}" 5 } + { unclosed "{" ($startpos($1), $endpos($1)) "}" ($startpos($3), $endpos($3)) } | LBRACE simple_expr WITH record_expr RBRACE - { mkexpr(Pexpr_record_with ($2, $4)) } + { mkexpr(Pexpr_record_with ($2, $4)) $loc } | LBRACKETBAR expr_semi_list opt_semi BARRBRACKET - { mkexpr(Pexpr_array(List.rev $2)) } + { mkexpr(Pexpr_array(List.rev $2)) $loc } | LBRACKETBAR expr_semi_list opt_semi error - { unclosed "[|" 1 "|]" 4 } + { unclosed "[|" ($startpos($1), $endpos($1)) "|]" ($startpos($4), $endpos($4)) } | LBRACKETBAR BARRBRACKET - { mkexpr(Pexpr_array []) } + { mkexpr(Pexpr_array []) $loc } | LBRACKET expr_semi_list opt_semi RBRACKET - { reloc_expr (mktailexpr (List.rev $2)) } + { reloc_expr (mktailexpr $loc (List.rev $2)) $loc } | LBRACKET expr_semi_list opt_semi error - { unclosed "[" 1 "]" 4 } + { unclosed "[" ($startpos($1), $endpos($1)) "]" ($startpos($4), $endpos($4)) } | PREFIXOP simple_expr - { mkexpr(Pexpr_apply(mkoperator $1 1, [$2])) } + { mkexpr(Pexpr_apply(mkoperator $1 ($startpos($1), $endpos($1)), [$2])) $loc } | NOTHING - { mkexpr Pexpr_nothing } + { mkexpr Pexpr_nothing $loc } | PAUSE - { mkexpr Pexpr_pause } + { mkexpr Pexpr_pause $loc } | HALT - { mkexpr Pexpr_halt } + { mkexpr Pexpr_halt $loc } | LOOP par_expr END - { mkexpr (Pexpr_loop $2) } + { mkexpr (Pexpr_loop $2) $loc } | SHARP ident { match $2 with | "suspend" -> @@ -686,8 +689,8 @@ simple_expr: (Pexpr_apply (mkexpr (Pexpr_ident (mkident (Pdot("Rmltop_controller", - "set_suspend")) 2)), - [mkexpr (Pexpr_constant Const_unit)])) + "set_suspend")) ($startpos($2), $endpos($2)))) $loc, + [mkexpr (Pexpr_constant Const_unit) $loc])) $loc (* !!!!!!!!!! mkexpr (Pexpr_seq @@ -699,59 +702,59 @@ simple_expr: [mkexpr (Pexpr_constant Const_unit)])), mkexpr Pexpr_pause)) !!!!!!!!!! *) - | _ -> raise (Rml_syntaxerr.Error(Rml_syntaxerr.Other (rhs_loc 2))) } + | _ -> raise (Rml_syntaxerr.Error(Rml_syntaxerr.Other (loc_of_pos ($startpos($2), $endpos($2))))) } ; very_simple_expr: /* simple_expr without "LPAREN expr RPAREN" */ val_longident - { mkexpr(Pexpr_ident $1) } + { mkexpr(Pexpr_ident $1) $loc } | constant - { mkexpr(Pexpr_constant $1) } + { mkexpr(Pexpr_constant $1) $loc } | constr_longident %prec prec_constant_constructor - { mkexpr(Pexpr_construct($1, None)) } + { mkexpr(Pexpr_construct($1, None)) $loc } | BEGIN par_expr END - { reloc_expr $2 } + { reloc_expr $2 $loc } | BEGIN END - { mkexpr (Pexpr_constant Const_unit) } + { mkexpr (Pexpr_constant Const_unit) $loc } | BEGIN par_expr error - { unclosed "begin" 1 "end" 3 } + { unclosed "begin" ($startpos($1), $endpos($1)) "end" ($startpos($3), $endpos($3)) } | very_simple_expr DOT label_longident - { mkexpr(Pexpr_record_access($1, $3)) } + { mkexpr(Pexpr_record_access($1, $3)) $loc } | very_simple_expr DOT LPAREN par_expr RPAREN - { mkexpr(Pexpr_apply(ghexpr(Pexpr_ident(array_function "Array" "get")), - [$1; $4])) } + { mkexpr(Pexpr_apply(ghexpr(Pexpr_ident(array_function "Array" "get")) $loc, + [$1; $4])) $loc } | very_simple_expr DOT LPAREN par_expr error - { unclosed "(" 3 ")" 5 } + { unclosed "(" ($startpos($3), $endpos($3)) ")" ($startpos($5), $endpos($5)) } | very_simple_expr DOT LBRACKET par_expr RBRACKET - { mkexpr(Pexpr_apply(ghexpr(Pexpr_ident(array_function "String" "get")), - [$1; $4])) } + { mkexpr(Pexpr_apply(ghexpr(Pexpr_ident(array_function "String" "get")) $loc, + [$1; $4])) $loc } | very_simple_expr DOT LBRACKET par_expr error - { unclosed "[" 3 "]" 5 } + { unclosed "[" ($startpos($3), $endpos($3)) "]" ($startpos($5), $endpos($5)) } | LBRACE record_expr RBRACE - { mkexpr(Pexpr_record($2)) } + { mkexpr(Pexpr_record($2)) $loc } | LBRACE record_expr error - { unclosed "{" 1 "}" 5 } + { unclosed "{" ($startpos($1), $endpos($1)) "}" ($startpos($3), $endpos($3)) } | LBRACE simple_expr WITH record_expr RBRACE - { mkexpr(Pexpr_record_with ($2, $4)) } + { mkexpr(Pexpr_record_with ($2, $4)) $loc } | LBRACKETBAR expr_semi_list opt_semi BARRBRACKET - { mkexpr(Pexpr_array(List.rev $2)) } + { mkexpr(Pexpr_array(List.rev $2)) $loc } | LBRACKETBAR expr_semi_list opt_semi error - { unclosed "[|" 1 "|]" 4 } + { unclosed "[|" ($startpos($1), $endpos($1)) "|]" ($startpos($4), $endpos($4)) } | LBRACKETBAR BARRBRACKET - { mkexpr(Pexpr_array []) } + { mkexpr(Pexpr_array []) $loc } | LBRACKET expr_semi_list opt_semi RBRACKET - { reloc_expr (mktailexpr (List.rev $2)) } + { reloc_expr (mktailexpr $loc (List.rev $2)) $loc } | LBRACKET expr_semi_list opt_semi error - { unclosed "[" 1 "]" 4 } + { unclosed "[" ($startpos($1), $endpos($1)) "]" ($startpos($4), $endpos($4)) } | PREFIXOP simple_expr - { mkexpr(Pexpr_apply(mkoperator $1 1, [$2])) } + { mkexpr(Pexpr_apply(mkoperator $1 ($startpos($1), $endpos($1)), [$2])) $loc } | NOTHING - { mkexpr Pexpr_nothing } + { mkexpr Pexpr_nothing $loc } | PAUSE - { mkexpr Pexpr_pause } + { mkexpr Pexpr_pause $loc } | HALT - { mkexpr Pexpr_halt } + { mkexpr Pexpr_halt $loc } | LOOP par_expr END - { mkexpr (Pexpr_loop $2) } + { mkexpr (Pexpr_loop $2) $loc } | SHARP ident { match $2 with | "suspend" -> @@ -759,8 +762,8 @@ very_simple_expr: /* simple_expr without "LPAREN expr RPAREN" */ (Pexpr_apply (mkexpr (Pexpr_ident (mkident (Pdot("Rmltop_controller", - "set_suspend")) 2)), - [mkexpr (Pexpr_constant Const_unit)])) + "set_suspend")) ($startpos($2), $endpos($2)))) $loc, + [mkexpr (Pexpr_constant Const_unit) $loc])) $loc (* !!!!!!!!!! mkexpr (Pexpr_seq @@ -772,7 +775,7 @@ very_simple_expr: /* simple_expr without "LPAREN expr RPAREN" */ [mkexpr (Pexpr_constant Const_unit)])), mkexpr Pexpr_pause)) !!!!!!!!!! *) - | _ -> raise (Rml_syntaxerr.Error(Rml_syntaxerr.Other (rhs_loc 2))) } + | _ -> raise (Rml_syntaxerr.Error(Rml_syntaxerr.Other (loc_of_pos ($startpos($2), $endpos($2))))) } ; pre_expr: simple_expr @@ -782,17 +785,17 @@ pre_expr: ; event_config: very_simple_expr %prec below_LPAREN - { mkconf(Pconf_present($1, None))} + { mkconf(Pconf_present($1, None)) $loc } | very_simple_expr LPAREN pattern RPAREN - { mkconf(Pconf_present($1, Some $3))} + { mkconf(Pconf_present($1, Some $3)) $loc } | event_config BACKSLASHSLASH event_config - { mkconf(Pconf_or($1,$3)) } + { mkconf(Pconf_or($1,$3)) $loc } | event_config SLASHBACKSLASH event_config - { mkconf(Pconf_and($1,$3)) } + { mkconf(Pconf_and($1,$3)) $loc } | LPAREN event_config RPAREN { $2 } | LPAREN event_config error - { unclosed "(" 1 ")" 3 } + { unclosed "(" ($startpos($1), $endpos($1)) ")" ($startpos($3), $endpos($3)) } ; simple_expr_list: simple_expr @@ -805,41 +808,41 @@ let_bindings: | let_bindings AND let_binding { $3 :: $1 } /* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */ | val_longident LESS pattern GREATER - { [$3, { pexpr_desc = Pexpr_get (mkexpr(Pexpr_ident $1)); - pexpr_loc = rhs_loc 1; }] } + { [$3, { pexpr_desc = Pexpr_get (mkexpr(Pexpr_ident $1) $loc); + pexpr_loc = loc_of_pos ($startpos($1), $endpos($1)); }] } /* !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! */ ; let_binding: val_ident fun_binding - { ({ppatt_desc = Ppatt_var $1; ppatt_loc = rhs_loc 1}, $2) } + { ({ppatt_desc = Ppatt_var $1; ppatt_loc = loc_of_pos ($startpos($1), $endpos($1))}, $2) } | pattern EQUAL par_expr { ($1, $3) } | PROCESS val_ident proc_binding - { ({ppatt_desc = Ppatt_var $2; ppatt_loc = rhs_loc 2}, $3) } + { ({ppatt_desc = Ppatt_var $2; ppatt_loc = loc_of_pos ($startpos($2), $endpos($2))}, $3) } ; fun_binding: strict_binding { $1 } | type_constraint EQUAL par_expr - { ghexpr(Pexpr_constraint($3, $1)) } + { ghexpr(Pexpr_constraint($3, $1)) $loc } ; strict_binding: EQUAL par_expr { $2 } | simple_pattern fun_binding - { ghexpr(Pexpr_function([$1, None, $2])) } + { ghexpr(Pexpr_function([$1, None, $2])) $loc } ; proc_binding: strict_proc_binding { $1 } | type_constraint EQUAL par_expr - { ghexpr(Pexpr_constraint(ghexpr(Pexpr_process($3)), $1)) } + { ghexpr(Pexpr_constraint(ghexpr(Pexpr_process($3)) $loc, $1)) $loc } ; strict_proc_binding: EQUAL par_expr - { ghexpr(Pexpr_process($2)) } + { ghexpr(Pexpr_process($2)) $loc } | simple_pattern proc_binding - { ghexpr(Pexpr_function([$1, None, $2])) } + { ghexpr(Pexpr_function([$1, None, $2])) $loc } ; match_cases: pattern match_action @@ -853,15 +856,15 @@ fun_def: match_action { $1 } | simple_pattern fun_def { let when_opt, expr = $2 in - when_opt, ghexpr(Pexpr_function([$1, None, expr])) } + when_opt, ghexpr(Pexpr_function([$1, None, expr])) $loc } ; proc_fun_def: - MINUSGREATER par_expr { mkexpr (Pexpr_process $2) } + MINUSGREATER par_expr { mkexpr (Pexpr_process $2) $loc } | simple_pattern proc_fun_def - { ghexpr(Pexpr_function([$1, None, $2])) } + { ghexpr(Pexpr_function([$1, None, $2])) $loc } ; proc_def: - simple_expr { mkexpr(Pexpr_process $1) } + simple_expr { mkexpr(Pexpr_process $1) $loc } /* MINUSGREATER par_expr { mkexpr(Pexpr_process $2) } | simple_pattern proc_def @@ -874,7 +877,7 @@ match_action: ; until_action: MINUSGREATER par_expr { None, $2 } - | WHEN par_expr { Some $2, ghexpr_unit() } + | WHEN par_expr { Some $2, ghexpr_unit $loc } | WHEN par_expr MINUSGREATER par_expr { Some $2, $4 } ; expr_comma_list: @@ -918,50 +921,50 @@ pattern: simple_pattern { $1 } | pattern AS val_ident - { mkpatt(Ppatt_alias($1, $3)) } + { mkpatt(Ppatt_alias($1, $3)) $loc } | pattern_comma_list %prec below_COMMA - { mkpatt(Ppatt_tuple(List.rev $1)) } + { mkpatt(Ppatt_tuple(List.rev $1)) $loc } | constr_longident pattern %prec prec_constr_appl - { mkpatt(Ppatt_construct($1, Some $2)) } + { mkpatt(Ppatt_construct($1, Some $2)) $loc } | pattern COLONCOLON pattern - { mkpatt(Ppatt_construct(mkident (Pident "::") 2, - Some(ghpatt(Ppatt_tuple[$1;$3])))) } + { mkpatt(Ppatt_construct(mkident (Pident "::") ($startpos($2), $endpos($2)), + Some(ghpatt(Ppatt_tuple[$1;$3]) $loc))) $loc } | pattern BAR pattern - { mkpatt(Ppatt_or($1, $3)) } + { mkpatt(Ppatt_or($1, $3)) $loc } ; simple_pattern: val_ident %prec below_EQUAL - { mkpatt(Ppatt_var $1) } + { mkpatt(Ppatt_var $1) $loc } | UNDERSCORE - { mkpatt(Ppatt_any) } + { mkpatt(Ppatt_any) $loc } | signed_constant - { mkpatt(Ppatt_constant $1) } + { mkpatt(Ppatt_constant $1) $loc } | CHAR DOTDOT CHAR - { mkrangepatt $1 $3 } + { mkrangepatt $1 $3 $loc } | constr_longident - { mkpatt(Ppatt_construct($1, None)) } + { mkpatt(Ppatt_construct($1, None)) $loc } | LBRACE lbl_pattern_list opt_semi RBRACE - { mkpatt(Ppatt_record(List.rev $2)) } + { mkpatt(Ppatt_record(List.rev $2)) $loc } | LBRACE lbl_pattern_list opt_semi error - { unclosed "{" 1 "}" 4 } + { unclosed "{" ($startpos($1), $endpos($1)) "}" ($startpos($4), $endpos($4)) } | LBRACKET pattern_semi_list opt_semi RBRACKET - { reloc_patt (mktailpatt (List.rev $2)) } + { reloc_patt (mktailpatt $loc (List.rev $2)) $loc } | LBRACKET pattern_semi_list opt_semi error - { unclosed "[" 1 "]" 4 } + { unclosed "[" ($startpos($1), $endpos($1)) "]" ($startpos($4), $endpos($4)) } | LBRACKETBAR pattern_semi_list opt_semi BARRBRACKET - { mkpatt(Ppatt_array(List.rev $2)) } + { mkpatt(Ppatt_array(List.rev $2)) $loc } | LBRACKETBAR BARRBRACKET - { mkpatt(Ppatt_array []) } + { mkpatt(Ppatt_array []) $loc } | LBRACKETBAR pattern_semi_list opt_semi error - { unclosed "[|" 1 "|]" 4 } + { unclosed "[|" ($startpos($1), $endpos($1)) "|]" ($startpos($4), $endpos($4)) } | LPAREN pattern RPAREN - { reloc_patt $2 } + { reloc_patt $2 $loc } | LPAREN pattern error - { unclosed "(" 1 ")" 3 } + { unclosed "(" ($startpos($1), $endpos($1)) ")" ($startpos($3), $endpos($3)) } | LPAREN pattern COLON core_type RPAREN - { mkpatt(Ppatt_constraint($2, $4)) } + { mkpatt(Ppatt_constraint($2, $4)) $loc } | LPAREN pattern COLON core_type error - { unclosed "(" 1 ")" 5 } + { unclosed "(" ($startpos($1), $endpos($1)) ")" ($startpos($5), $endpos($5)) } ; pattern_comma_list: @@ -993,7 +996,7 @@ type_declarations: type_declaration: type_parameters LIDENT type_kind - { (mksimple $2 2, $1, $3) } + { (mksimple $2 ($startpos($2), $endpos($2)), $1, $3) } ; type_kind: /*empty*/ @@ -1044,35 +1047,35 @@ core_type: simple_core_type_or_tuple { $1 } | core_type MINUSGREATER core_type - { mkte(Ptype_arrow($1, $3)) } + { mkte(Ptype_arrow($1, $3)) $loc } ; simple_core_type: simple_core_type2 { $1} | LPAREN core_type_comma_list RPAREN - { match $2 with [sty] -> sty | _ -> raise Parse_error } + { match $2 with [sty] -> sty | _ -> raise Parsing.Parse_error } simple_core_type2: QUOTE ident - { mkte(Ptype_var $2) } + { mkte(Ptype_var $2) $loc } | type_longident - { mkte(Ptype_constr($1, [])) } + { mkte(Ptype_constr($1, [])) $loc } | simple_core_type2 type_longident - { mkte(Ptype_constr($2, [$1])) } + { mkte(Ptype_constr($2, [$1])) $loc } | LPAREN core_type_comma_list RPAREN type_longident - { mkte(Ptype_constr($4, List.rev $2)) } + { mkte(Ptype_constr($4, List.rev $2)) $loc } | simple_core_type PROCESS - { mkte(Ptype_process ($1, Def_static.Dontknow)) } + { mkte(Ptype_process ($1, Def_static.Dontknow)) $loc } | simple_core_type PROCESS PLUS - { mkte(Ptype_process ($1, Def_static.Noninstantaneous)) } + { mkte(Ptype_process ($1, Def_static.Noninstantaneous)) $loc } | simple_core_type PROCESS MINUS - { mkte(Ptype_process ($1, Def_static.Instantaneous)) } + { mkte(Ptype_process ($1, Def_static.Instantaneous)) $loc } ; simple_core_type_or_tuple: simple_core_type { $1 } | simple_core_type STAR core_type_list - { mkte(Ptype_tuple($1 :: List.rev $3)) } + { mkte(Ptype_tuple($1 :: List.rev $3)) $loc } ; core_type_comma_list: core_type { [$1] } @@ -1083,7 +1086,7 @@ core_type_list: | core_type_list STAR simple_core_type { $3 :: $1 } ; label: - LIDENT { mksimple $1 1 } + LIDENT { mksimple $1 ($startpos($1), $endpos($1)) } ; /* Constants */ @@ -1110,13 +1113,13 @@ ident: | LIDENT { $1 } ; val_ident: - LIDENT { mksimple $1 1 } - | LPAREN operator RPAREN { mksimple $2 2 } + LIDENT { mksimple $1 ($startpos($1), $endpos($1)) } + | LPAREN operator RPAREN { mksimple $2 ($startpos($2), $endpos($2)) } ; val_ident_colon: - LIDENT COLON { mksimple $1 1 } - | LPAREN operator RPAREN COLON { mksimple $2 2 } - | LABEL { mksimple $1 1 } + LIDENT COLON { mksimple $1 ($startpos($1), $endpos($1)) } + | LPAREN operator RPAREN COLON { mksimple $2 ($startpos($2), $endpos($2)) } + | LABEL { mksimple $1 ($startpos($1), $endpos($1)) } ; operator: PREFIXOP { $1 } @@ -1138,43 +1141,43 @@ operator: | COLONEQUAL { ":=" } ; constr_ident: - UIDENT { mksimple $1 1 } + UIDENT { mksimple $1 ($startpos($1), $endpos($1)) } /* | LBRACKET RBRACKET { "[]" } */ - | COLONCOLON { mksimple "::" 1 } + | COLONCOLON { mksimple "::" ($startpos($1), $endpos($1)) } ; val_longident: val_ident - { mkident (Pident $1.psimple_id) 1 } + { mkident (Pident $1.psimple_id) ($startpos($1), $endpos($1)) } | UIDENT DOT val_ident - { mkident_loc (Pdot($1, $3.psimple_id)) (symbol_rloc()) } + { mkident (Pdot($1, $3.psimple_id)) $loc } ; constr_longident: UIDENT %prec below_DOT - { mkident (Pident $1) 1 } + { mkident (Pident $1) ($startpos($1), $endpos($1)) } | UIDENT DOT UIDENT - { mkident_loc (Pdot($1, $3)) (symbol_rloc()) } + { mkident (Pdot($1, $3)) $loc } | LBRACKET RBRACKET - { mkident_loc (Pident "[]") (symbol_rloc()) } + { mkident (Pident "[]") $loc } ; label_longident: LIDENT - { mkident (Pident $1) 1 } + { mkident (Pident $1)($startpos($1), $endpos($1)) } | UIDENT DOT LIDENT - { mkident_loc (Pdot($1, $3)) (symbol_rloc()) } + { mkident (Pdot($1, $3)) $loc } ; type_longident: LIDENT - { mkident (Pident $1) 1 } + { mkident (Pident $1) ($startpos($1), $endpos($1)) } | UIDENT DOT LIDENT - { mkident_loc (Pdot($1, $3)) (symbol_rloc()) } + { mkident (Pdot($1, $3)) $loc } ; /* Signals */ signal_decl: - LIDENT { (mksimple $1 1, None) } + LIDENT { (mksimple $1 ($startpos($1), $endpos($1)), None) } | LIDENT COLON core_type - { (mksimple $1 1, Some $3) } + { (mksimple $1 ($startpos($1), $endpos($1)), Some $3) } ; signal_comma_list: signal_decl { [$1] } @@ -1240,15 +1243,15 @@ lucky_declaration: lucky_label COLON core_type { ($1, $3) } ; lucky_label: - LIDENT { mksimple $1 1 } - | UIDENT { mksimple $1 1 } + LIDENT { mksimple $1 ($startpos($1), $endpos($1)) } + | UIDENT { mksimple $1 ($startpos($1), $endpos($1)) } ; /* string list */ lucky_files: | LBRACKET string_semi_list opt_semi RBRACKET { List.rev $2 } | LBRACKET string_semi_list opt_semi error - { unclosed "[" 1 "]" 4 } + { unclosed "[" ($startpos($1), $endpos($1)) "]" ($startpos($4), $endpos($4)) } ; string_semi_list: constant diff --git a/configure-tools/dune b/configure-tools/dune new file mode 100644 index 00000000..a5690dd2 --- /dev/null +++ b/configure-tools/dune @@ -0,0 +1,11 @@ +(rule (target rml_asttypes.ml) (action (copy ../compiler/global/rml_asttypes.ml rml_asttypes.ml))) +(rule (target def_modules.ml) (action (copy ../compiler/global/def_modules.ml def_modules.ml))) +(rule (target global.ml) (action (copy ../compiler/global/global.ml global.ml))) +(rule (target global_ident.ml) (action (copy ../compiler/global/global_ident.ml global_ident.ml))) +(rule (target rml_ident.ml) (action (copy ../compiler/global/rml_ident.ml rml_ident.ml))) +(rule (target def_types.ml) (action (copy ../compiler/typing/def_types.ml def_types.ml))) +(rule (target def_static.ml) (action (copy ../compiler/static/def_static.ml def_static.ml))) + + +(executable + (name embedrzi)) \ No newline at end of file diff --git a/configure-tools/embedrzi.ml b/configure-tools/embedrzi.ml index 70c34d61..cf7448de 100755 --- a/configure-tools/embedrzi.ml +++ b/configure-tools/embedrzi.ml @@ -28,9 +28,4 @@ let () = List.iter stdlib_files in let () = Buffer.add_string buf "]" in -let out = open_out_gen - [Open_creat; Open_wronly; Open_trunc] - 0o640 - (basedir // "compiler" // "global" // "rzi.ml") -in -Printf.fprintf out "%s\n" (Buffer.contents buf) +Printf.fprintf Stdlib.stdout "%s\n" (Buffer.contents buf) diff --git a/dune b/dune new file mode 100644 index 00000000..fcb534df --- /dev/null +++ b/dune @@ -0,0 +1,3 @@ +(env + (dev + (flags (:standard -warn-error -A)))) \ No newline at end of file diff --git a/dune-project b/dune-project new file mode 100644 index 00000000..135ee626 --- /dev/null +++ b/dune-project @@ -0,0 +1,4 @@ +(lang dune 2.9.1) +(name rmlc) +(version rml-1.09.8-dev) +(using menhir 2.1) diff --git a/interpreter/dune b/interpreter/dune new file mode 100644 index 00000000..a567777f --- /dev/null +++ b/interpreter/dune @@ -0,0 +1,10 @@ +(library + (name rmllib) + (libraries threads) + (flags (:standard -rectypes)) + (modules_without_implementation lco_interpreter lk_interpreter) + (modules :standard \ lk_threaded thread_implem)) + +(install + (files rmllib.a) + (section lib)) \ No newline at end of file diff --git a/rml.opam b/rml.opam new file mode 100644 index 00000000..503e7db3 --- /dev/null +++ b/rml.opam @@ -0,0 +1,28 @@ +version: "rml-1.09.08-dev" +opam-version: "0.0.1" +maintainer: "Louis Mandel " +authors: [ "Louis Mandel " ] +license: "QPL" +dev-repo: "git+https://github.com/reactiveml/rml" +tags: [ "syntax" ] +build: [ + ["./configure" "--prefix" "%{prefix}%"] + ["make" "-j" jobs] + ["dune" "test" "-j" jobs] {with-test} +] + +install: [ + ["dune" "install" "-j" jobs] +] + +depends: [ + "ocaml" {>= "4.09.0"} + "dune" {>= "1.6.3"} + "menhir" + "alcotest" {with-test} +] + +synopsis: "Reactive ML" +description: """ +ReactiveML: a programming language for implementing interactive systems. +""" diff --git a/stdlib/dune b/stdlib/dune new file mode 100644 index 00000000..f1f01f6f --- /dev/null +++ b/stdlib/dune @@ -0,0 +1,36 @@ +(rule (target arg.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c arg.rmli))) +(rule (target buffer.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c buffer.rmli))) +(rule (target camlinternalBigarray.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c camlinternalBigarray.rmli))) +(rule (target complex.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c complex.rmli))) +(rule (target digest.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c digest.rmli))) +(rule (target filename.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c filename.rmli))) +(rule (target format.rzi) (deps stdlib.rzi buffer.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c format.rmli))) +(rule (target gc.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c gc.rmli))) +(rule (target genlex.rzi) (deps stdlib.rzi stream.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c genlex.rmli))) +(rule (target graphics.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c graphics.rmli))) +(rule (target hashtbl.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c hashtbl.rmli))) +(rule (target int32.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c int32.rmli))) +(rule (target int64.rzi) (deps stdlib.rzi nativeint.rzi int32.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c int64.rmli))) +(rule (target lazy.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c lazy.rmli))) +(rule (target lexing.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c lexing.rmli))) +(rule (target list.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c list.rmli))) +(rule (target luc4ocaml_nolbl.rzi) (deps stdlib.rzi luc4ocaml.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c luc4ocaml_nolbl.rmli))) +(rule (target luc4ocaml.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c luc4ocaml.rmli))) +(rule (target marshal.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c marshal.rmli))) +(rule (target nativeint.rzi) (deps stdlib.rzi int32.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c nativeint.rmli))) +(rule (target obj.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c obj.rmli))) +(rule (target parsing.rzi) (deps stdlib.rzi obj.rzi lexing.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c parsing.rmli))) +(rule (target printexc.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c printexc.rmli))) +(rule (target printf.rzi) (deps stdlib.rzi buffer.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c printf.rmli))) +(rule (target queue.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c queue.rmli))) +(rule (target random.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c random.rmli))) +(rule (target sort.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c sort.rmli))) +(rule (target stack.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c stack.rmli))) +(rule (target stream.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c stream.rmli))) +(rule (target string.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c string.rmli))) +(rule (target str.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c str.rmli))) +(rule (target sys.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c sys.rmli))) +(rule (target unix.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c unix.rmli))) +(rule (target weak.rzi) (deps stdlib.rzi ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c weak.rmli))) + +(rule (target stdlib.rzi) (deps ../compiler/rmlc.exe) (mode (promote (until-clean))) (action (run ../compiler/rmlc.exe -c stdlib.rmli))) diff --git a/test/await.rml b/test/await.rml new file mode 100644 index 00000000..287afc01 --- /dev/null +++ b/test/await.rml @@ -0,0 +1,27 @@ + +let ratio = 1000000 + +signal s default 0 gather fun x y -> x + y;; +signal s2 default 1 gather fun x y -> x * y;; +signal s3 default (0, 0) gather fun x _ -> x;; +signal s4 default [] gather fun x y -> x :: y;; + +let process spam n = + for i = 1 to n dopar + emit s i; + emit s2 i; + pause; + emit s (i * 2); + done + +let process catch p = + (* Here, both s3 and s4 won't ever be present (never emitted) but it shows the macro works :tm: *) + await ((s(i1) /\ s2(i2)) \/ s3((i1, i2)) \/ s4([i1; i2])) when (i1 + i2 >= 0) in + await s(i3) in + p := (i1 * ratio * ratio + i2 * ratio + i3) + + +let process compare n = + let p = ref 0 in + let () = run (spam n) || run (catch p) + in !p \ No newline at end of file diff --git a/test/await_ocaml.ml b/test/await_ocaml.ml new file mode 100644 index 00000000..52c0b6ec --- /dev/null +++ b/test/await_ocaml.ml @@ -0,0 +1,20 @@ + +open Rmllib +open Implem_lco_ctrl_tree_record +let run p = + Rml_machine.rml_exec ([]) + (fun () -> Lco_ctrl_tree_record.rml_run (function | () -> p ) ) + +let compute_n_seq n = + let rec fac n = if n < 2 then 1 else n * fac (n - 1) in + let n2 = ((n + 1) * n) / 2 in + Await.ratio * Await.ratio * n2 + Await.ratio * (fac n) + (2 * n2) + + let compute_n n = run (Await.compare n) + + let test_await () = + Alcotest.(check int) "await_when 1" (compute_n_seq 10) (compute_n 10) + + let test_set = [ + ("await_when", `Quick, test_await) + ] \ No newline at end of file diff --git a/test/dune b/test/dune new file mode 100644 index 00000000..7ef8ac60 --- /dev/null +++ b/test/dune @@ -0,0 +1,7 @@ +(rule (target await.ml) (deps (file await.rml) ../compiler/rmlc.exe) (action (run ../compiler/rmlc.exe await.rml))) + + +(test + (name test) + (libraries alcotest rmllib) + (flags (:standard -rectypes))) \ No newline at end of file diff --git a/test/test.ml b/test/test.ml new file mode 100644 index 00000000..def7ff7c --- /dev/null +++ b/test/test.ml @@ -0,0 +1,4 @@ +let () = + Alcotest.run "Rml ppx" [ + ("Await_rml", Await_ocaml.test_set); + ] \ No newline at end of file diff --git a/toplevel/dune b/toplevel/dune new file mode 100644 index 00000000..140ed37c --- /dev/null +++ b/toplevel/dune @@ -0,0 +1,40 @@ +(rule (target rmltop_machine_body.ml) (action (run ../compiler/rmlc.exe -I ../stdlib -runtime Lco_ctrl_tree rmltop_machine_body.rml))) +(rule (target rmltop_global.rzi) (action (run ../compiler/rmlc.exe -c -I ../stdlib rmltop_global.rmli))) +(rule (target rmltop_reactive_machine.rzi) (deps rmltop_global.rzi) (action (run ../compiler/rmlc.exe -c -I ../stdlib rmltop_reactive_machine.rmli))) +(rule (targets rmltop_controller.ml rmltop_controller.rzi) (deps rmltop_reactive_machine.rzi rmltop_global.rzi) (action (run ../compiler/rmlc.exe -I ../stdlib -runtime Rmltop rmltop_controller.rml))) + +(ocamllex rmltop_lexer) + +(library + (name rmltop_lexer) + (modules rmltop_lexer)) + +(library (name rmltop_global) (modules rmltop_global) (libraries rmllib) (flags (:standard -rectypes))) +(library (name rmltop_machine_body) (modules rmltop_machine_body) (libraries rmllib) (flags (:standard -rectypes))) +(library (name rmltop_implem) (modules rmltop_implem) (libraries rmllib) (flags (:standard -rectypes))) +(library (name rmltop_reactive_machine) (modules rmltop_reactive_machine) (libraries rmltop_machine_body rmltop_global rmllib) (flags (:standard -rectypes))) +(library (name rmltop_controller) (modules rmltop_controller) (libraries rmllib rmltop_reactive_machine rmltop_global rmltop_implem) (flags (:standard -rectypes))) +(library (name rmltop_directives) (modules rmltop_directives) (libraries rmllib rmltop_global) (flags (:standard -rectypes))) + + +(library + (name rmltop_main) + (flags (:standard -rectypes)) + (libraries rmllib rmltop_lexer rmltop_global rmltop_implem rmltop_controller) + (modules rmltop_main)) + + +(executables + (names rmltop) + (flags (:standard -rectypes)) + (libraries rmllib rmltop_main rmltop_lexer) + (modules rmltop)) + +(install + (files rmltop) + (section bin)) + +(install + (files rmltop_global.a rmltop_machine_body.a rmltop_reactive_machine.a + rmltop_controller.a rmltop_lexer.a rmltop_directives.a rmltop_implem.a rmltop_main.a rmltop_global.rzi rmltop_controller.rzi) + (section lib)) diff --git a/toplevel/rmltop_global.ml b/toplevel/rmltop_global.ml index 57378c06..cb9ea138 100644 --- a/toplevel/rmltop_global.ml +++ b/toplevel/rmltop_global.ml @@ -20,6 +20,7 @@ (* file: rmltop_global.ml *) (* author: Louis Mandel *) (* created: 2005-09-23 *) +open Rmllib type 'a rml_process = 'a Implem_lco_ctrl_tree_record.Lco_ctrl_tree_record.process diff --git a/toplevel/rmltop_global.mli b/toplevel/rmltop_global.mli index e833bf8e..9de5eb26 100644 --- a/toplevel/rmltop_global.mli +++ b/toplevel/rmltop_global.mli @@ -20,6 +20,7 @@ (* file: rmltop_global.mli *) (* author: Louis Mandel *) (* created: 2005-09-23 *) +open Rmllib type 'a rml_process = 'a Implem_lco_ctrl_tree_record.Lco_ctrl_tree_record.process diff --git a/toplevel/rmltop_implem.ml b/toplevel/rmltop_implem.ml index 53b42c08..f08d1ca8 100644 --- a/toplevel/rmltop_implem.ml +++ b/toplevel/rmltop_implem.ml @@ -20,6 +20,7 @@ (* file: rmltop_implem.ml *) (* author: Louis Mandel *) (* created: 2005-10-25 *) +open Rmllib module Sig_env (* : S *) = struct diff --git a/toplevel/rmltop_reactive_machine.ml b/toplevel/rmltop_reactive_machine.ml index 3b1d8024..8bb0c064 100644 --- a/toplevel/rmltop_reactive_machine.ml +++ b/toplevel/rmltop_reactive_machine.ml @@ -20,7 +20,7 @@ (* file: rmltop_reactive_machine.ml *) (* created: 2007-12-03 *) (* author: Louis Mandel *) - +open Rmllib;; module Interpretor = Implem_lco_ctrl_tree_record.Lco_ctrl_tree_record let rml_react_unsafe =