diff options
Diffstat (limited to 'ocaml-binary-annot/camlp4/unmaintained')
71 files changed, 11717 insertions, 0 deletions
diff --git a/ocaml-binary-annot/camlp4/unmaintained/Makefile b/ocaml-binary-annot/camlp4/unmaintained/Makefile new file mode 100644 index 0000000000..b6db0753cb --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/Makefile @@ -0,0 +1,20 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# The unmaintained directory +# + +include ../config/Makefile.cnf + +DIRS=format lefteval ocamllex olabl scheme sml + +include ../config/Makefile.base diff --git a/ocaml-binary-annot/camlp4/unmaintained/compile/.cvsignore b/ocaml-binary-annot/camlp4/unmaintained/compile/.cvsignore new file mode 100644 index 0000000000..47817ccef6 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/compile/.cvsignore @@ -0,0 +1,4 @@ +*.fast +*.fast.opt +o_fast.ml +pa_o_fast.ml diff --git a/ocaml-binary-annot/camlp4/unmaintained/compile/.depend b/ocaml-binary-annot/camlp4/unmaintained/compile/.depend new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/compile/.depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/compile/Makefile b/ocaml-binary-annot/camlp4/unmaintained/compile/Makefile new file mode 100644 index 0000000000..bd4078f22c --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/compile/Makefile @@ -0,0 +1,37 @@ + + +include ../config/Makefile.cnf + +INCLUDES=-I ../camlp4 -I ../lib +SRC=../etc/pa_o.ml ../etc/pa_op.ml # FIXME and why not pa_$D.ml? +D=o +COMP_OPT=-strict_parsing -e "Grammar.Entry.obj Pcaml.interf" -e "Grammar.Entry.obj Pcaml.implem" -e "Grammar.Entry.obj Pcaml.top_phrase" -e "Grammar.Entry.obj Pcaml.use_file" +CLEANFILES=pa_*_fast.ml *_fast.ml + +# FIXME +EXECUTABLES=#camlp4$D.fast + +include ../config/Makefile.base + +WARNINGS=Ay + +camlp4$D.fast: pa_$D_fast.cmo + rm -f camlp4$D.fast + cd ../camlp4; $(MAKE) CAMLP4=../compile/camlp4$D.fast CAMLP4M="../compile/pa_$D_fast.cmo ../meta/pr_dump.cmo" + +camlp4$D.fast.opt: pa_$D_fast.cmx + rm -f camlp4$D.fast.opt + cd ../camlp4; $(MAKE) ../compile/camlp4$D.fast.opt CAMLP4OPT=../compile/camlp4$D.fast.opt CAMLP4M="../compile/pa_$D_fast.cmx ../meta/pr_dump.cmx" + +pa_$D_fast.ml: comp_head.ml $D_fast.ml comp_trail.ml + cat $(SRC) | sed -e "s/Plexer.make_lexer *()/P.lexer_pos/" -e "/EXTEND/,/END/d" -e "/Grammar.Entry.of_parser/d" -e "/Grammar.Entry.gcreate/d" | cat comp_head.ml - $D_fast.ml comp_trail.ml > pa_$D_fast.ml + +$D_fast.ml: compile.cmo $(SRC) + echo '(* camlp4r *)' >$D_fast.ml + OTOP=$(OTOP) EXE=$(EXE) ./compile.sh $(COMP_OPT) $(SRC) >> $D_fast.ml + +install-local: + if test -f camlp4$D.fast.opt; then cp camlp4$D.fast.opt $(BINDIR)/camlp4$D.opt$(EXE); fi + for TARG in pa_$D_fast.cmi pa_$D_fast.cmo pa_$D_fast.cmx ; do if test -f $$TARG; then cp $$TARG "$(LIBDIR)/camlp4/."; fi; done + +include .depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/compile/comp_head.ml b/ocaml-binary-annot/camlp4/unmaintained/compile/comp_head.ml new file mode 100644 index 0000000000..cd62343641 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/compile/comp_head.ml @@ -0,0 +1,70 @@ +(* camlp4r q_MLast.cmo pa_extend.cmo *) + + +module P = + struct + value gloc bp strm = Grammar.loc_of_token_interval bp (Stream.count strm); + value list0 symb = + let rec loop al = + parser + [ [: a = symb; s :] -> loop [a :: al] s + | [: :] -> al ] + in + parser [: a = loop [] :] -> List.rev a + ; + value list0sep symb sep = + let rec kont al = + parser + [ [: v = sep; a = symb; s :] -> kont [a :: al] s + | [: :] -> al ] + in + parser + [ [: a = symb; s :] -> List.rev (kont [a] s) + | [: :] -> [] ] + ; + value list1 symb = + let rec loop al = + parser + [ [: a = symb; s :] -> loop [a :: al] s + | [: :] -> al ] + in + parser [: a = symb; s :] -> List.rev (loop [a] s) + ; + value list1sep symb sep = + let rec kont al = + parser + [ [: v = sep; a = symb; s :] -> kont [a :: al] s + | [: :] -> al ] + in + parser [: a = symb; s :] -> List.rev (kont [a] s) + ; + value option f = + parser + [ [: x = f :] -> Some x + | [: :] -> None ] + ; + value token (p_con, p_prm) = + if p_prm = "" then parser [: `(con, prm) when con = p_con :] -> prm + else parser [: `(con, prm) when con = p_con && prm = p_prm :] -> prm + ; + value orzero f f0 = + parser bp + [ [: x = f :] -> x + | [: x = f0 :] ep -> +(* +let (loc1, loc2) = Grammar.loc_of_token_interval bp ep in +let _ = do { Printf.eprintf "recovered or_zero at loc (%d, %d)\n" loc1 loc2; flush stderr } in +*) + x ] + ; + value error entry prev_symb symb = + symb ^ " expected" ^ + (if prev_symb = "" then "" else " after " ^ prev_symb) ^ + " (in [" ^ entry ^ "])" + ; + value lexer = Plexer.gmake(); + end +; + +(****************************************) + diff --git a/ocaml-binary-annot/camlp4/unmaintained/compile/comp_trail.ml b/ocaml-binary-annot/camlp4/unmaintained/compile/comp_trail.ml new file mode 100644 index 0000000000..75f40abbf4 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/compile/comp_trail.ml @@ -0,0 +1,33 @@ +(* camlp4r pa_extend.cmo *) +(****************************************) + +value interf_p = + Grammar.Entry.of_parser Pcaml.gram "interf" interf_0 +; + +value implem_p = + Grammar.Entry.of_parser Pcaml.gram "implem" implem_0 +; + +value top_phrase_p = + Grammar.Entry.of_parser Pcaml.gram "top_phrase" top_phrase_0 +; + +value use_file_p = + Grammar.Entry.of_parser Pcaml.gram "use_file" use_file_0 +; + +EXTEND + interf: + [ [ x = interf_p -> x ] ] + ; + implem: + [ [ x = implem_p -> x ] ] + ; + top_phrase: + [ [ x = top_phrase_p -> x ] ] + ; + use_file: + [ [ x = use_file_p -> x ] ] + ; +END; diff --git a/ocaml-binary-annot/camlp4/unmaintained/compile/compile.ml b/ocaml-binary-annot/camlp4/unmaintained/compile/compile.ml new file mode 100644 index 0000000000..b5e6ba5a17 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/compile/compile.ml @@ -0,0 +1,574 @@ +(* camlp4r *) + + +open Gramext; + +value strict_parsing = ref False; +value keywords = ref []; + +value _loc = Loc.ghost; + +(* Watch the segmentation faults here! the compiled file must have been + loaded in camlp4 with the option pa_extend.cmo -meta_action. *) +value magic_act (act : Obj.t) : MLast.expr = Obj.magic act; + +(* Names of symbols for error messages; code borrowed to grammar.ml *) + +value rec name_of_symbol entry = + fun + [ Snterm e -> "[" ^ e.ename ^ "]" + | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]" + | Sself | Snext -> "[" ^ entry.ename ^ "]" + | Stoken tok -> entry.egram.glexer.Token.tok_text tok + | _ -> "???" ] +; + +value rec name_of_symbol_failed entry = + fun + [ Slist0 s -> name_of_symbol_failed entry s + | Slist0sep s _ -> name_of_symbol_failed entry s + | Slist1 s -> name_of_symbol_failed entry s + | Slist1sep s _ -> name_of_symbol_failed entry s + | Sopt s -> name_of_symbol_failed entry s + | Stree t -> name_of_tree_failed entry t + | s -> name_of_symbol entry s ] +and name_of_tree_failed entry = + fun + [ Node {node = s; brother = bro; son = son} -> + let txt = name_of_symbol_failed entry s in + let txt = + match (s, son) with + [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son + | _ -> txt ] + in + let txt = + match bro with + [ DeadEnd | LocAct _ _ -> txt + | _ -> txt ^ " or " ^ name_of_tree_failed entry bro ] + in + txt + | DeadEnd | LocAct _ _ -> "???" ] +; + +value tree_failed entry prev_symb tree = + let (s2, s3) = + let txt = name_of_tree_failed entry tree in + match prev_symb with + [ Slist0 s -> + let txt1 = name_of_symbol_failed entry s in + ("", txt1 ^ " or " ^ txt) + | Slist1 s -> + let txt1 = name_of_symbol_failed entry s in + ("", txt1 ^ " or " ^ txt) + | Slist0sep s sep -> + let txt1 = name_of_symbol_failed entry s in + ("", txt1 ^ " or " ^ txt) + | Slist1sep s sep -> + let txt1 = name_of_symbol_failed entry s in + ("", txt1 ^ " or " ^ txt) + | Sopt _ | Stree _ -> ("", txt) + | _ -> (name_of_symbol entry prev_symb, txt) ] + in + <:expr< + P.error $str:entry.ename$ $`str:s2$ $`str:s3$ + >> +; + +(* Compilation *) + +value rec find_act = + fun + [ DeadEnd -> failwith "find_act" + | LocAct act _ -> (magic_act act, 0) + | Node {son = son; brother = bro} -> + let (act, n) = try find_act son with [ Failure _ -> find_act bro ] in + (act, n + 1) ] +; + +value level_number e l = + match e.edesc with + [ Dlevels elevs -> + loop 0 elevs where rec loop n = + fun + [ [lev :: levs] -> if lev.lname = Some l then n else loop (n + 1) levs + | [] -> failwith ("level " ^ l ^ " not found in entry " ^ e.ename) ] + | Dparser _ -> 0 ] +; + +value nth_patt_of_act (e, n) = + let patt_list = + loop e where rec loop = + fun + [ <:expr< fun (_loc : Locaction.t) -> $_$ >> -> + [] + | <:expr< fun ($p$ : $_$) -> $e$ >> -> [p :: loop e] + | <:expr< fun $p$ -> $e$ >> -> [p :: loop e] + | _ -> failwith "nth_patt_of_act" ] + in + List.nth patt_list n +; + +value rec last_patt_of_act = + fun + [ <:expr< fun ($p$ : $_$) (_loc : Locaction.t) -> + $_$ >> -> p + | <:expr< fun $_$ -> $e$ >> -> last_patt_of_act e + | _ -> failwith "last_patt_of_act" ] +; + +#load "pr_r.cmo"; +value rec final_action = + fun + [ + <:expr< fun (_loc : Loc.t) -> ($e$ : $_$) >> -> e + | <:expr< fun $_$ -> $e$ >> -> final_action e + | ast -> do { + print_endline "final_action failed"; + Pcaml.print_implem.val [(MLast.StExp _loc ast, _loc)]; + failwith "final_action"; + } ] +; + +value parse_standard_symbol e rkont fkont ending_act = + <:expr< + match try Some ($e$ __strm) with [ Stream.Failure -> None ] with + [ Some $nth_patt_of_act ending_act$ -> $rkont$ + | _ -> $fkont$ ] + >> +; + +value parse_symbol_no_failure e rkont fkont ending_act = + <:expr< + let $nth_patt_of_act ending_act$ = + try $e$ __strm with [ Stream.Failure -> raise (Stream.Error "") ] + in + $rkont$ + >> +; + +value rec contain_loc = + fun + [ <:expr< $lid:s$ >> -> (s = "loc") || (s = "_loc") + | <:expr< $uid:_$ >> -> False + | <:expr< $str:_$ >> -> False + | <:expr< ($list:el$) >> -> List.exists contain_loc el + | <:expr< $e1$ $e2$ >> -> contain_loc e1 || contain_loc e2 + | _ -> True ] +; + +value gen_let_loc _loc e = + if contain_loc e then <:expr< let _loc = P.gloc bp __strm in $e$ >> else e +; + +value phony_entry = Grammar.Entry.obj Pcaml.implem; + +value rec parse_tree entry nlevn alevn (tree, fst_symb) act_kont kont = + match tree with + [ DeadEnd -> kont + | LocAct act _ -> + let act = magic_act act in + act_kont False act + | Node {node = Sself; son = LocAct act _; brother = bro} -> + let act = magic_act act in + let n = entry.ename ^ "_" ^ string_of_int alevn in + let e = + if strict_parsing.val || alevn = 0 || fst_symb then <:expr< $lid:n$ >> + else <:expr< P.orzero $lid:n$ $lid:entry.ename ^ "_0"$ >> + in + let p2 = + match bro with + [ DeadEnd -> kont + | _ -> parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont ] + in + let p1 = act_kont True act in + parse_standard_symbol e p1 p2 (act, 0) + | Node {node = s; son = LocAct act _; brother = bro} -> + let act = magic_act act in + let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in + let p1 = act_kont False act in + parse_symbol entry nlevn s p1 p2 (act, 0) + | Node {node = s; son = son; brother = bro} -> + let p2 = parse_tree entry nlevn alevn (bro, fst_symb) act_kont kont in + let p1 = + let err = + let txt = tree_failed entry s son in + <:expr< raise (Stream.Error $txt$) >> + in + match son with + [ Node {brother = DeadEnd} -> + parse_tree entry nlevn alevn (son, False) act_kont err + | _ -> + let p1 = + parse_tree entry nlevn alevn (son, True) act_kont + <:expr< raise Stream.Failure >> + in + <:expr< try $p1$ with [ Stream.Failure -> $err$ ] >> ] + in + parse_symbol entry nlevn s p1 p2 (find_act son) ] +and parse_symbol entry nlevn s rkont fkont ending_act = + match s with + [ Slist0 s -> + let e = <:expr< P.list0 $symbol_parser entry nlevn s$ >> in + parse_symbol_no_failure e rkont fkont ending_act + | Slist1 s -> + let e = <:expr< P.list1 $symbol_parser entry nlevn s$ >> in + parse_standard_symbol e rkont fkont ending_act + | Slist0sep s sep -> + let e = + <:expr< + P.list0sep $symbol_parser entry nlevn s$ + $symbol_parser entry nlevn sep$ >> + in + parse_symbol_no_failure e rkont fkont ending_act + | Slist1sep s sep -> + let e = + <:expr< + P.list1sep $symbol_parser entry nlevn s$ + $symbol_parser entry nlevn sep$ >> + in + parse_standard_symbol e rkont fkont ending_act + | Sopt s -> + let e = <:expr< P.option $symbol_parser entry nlevn s$ >> in + parse_symbol_no_failure e rkont fkont ending_act + | Stree tree -> + let kont = <:expr< raise Stream.Failure >> in + let act_kont _ act = gen_let_loc _loc (final_action act) in + let e = parse_tree phony_entry 0 0 (tree, True) act_kont kont in + parse_standard_symbol <:expr< fun __strm -> $e$ >> rkont fkont ending_act + | Snterm e -> + let n = + match e.edesc with + [ Dparser _ -> e.ename + | Dlevels _ -> e.ename ^ "_0" ] + in + parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act + | Snterml e l -> + let n = e.ename ^ "_" ^ string_of_int (level_number e l) in + parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act + | Sself -> + let n = entry.ename ^ "_0" in + parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act + | Snext -> + let n = entry.ename ^ "_" ^ string_of_int nlevn in + parse_standard_symbol <:expr< $lid:n$ >> rkont fkont ending_act + | Stoken tok -> + let _ = + do { + if fst tok = "" && not (List.mem (snd tok) keywords.val) then + keywords.val := [snd tok :: keywords.val] + else () + } + in + let p = + let patt = nth_patt_of_act ending_act in + let p_con = fst tok in + let p_prm = snd tok in + if snd tok = "" then + if fst tok = "ANY" then <:patt< (_, $patt$) >> + else <:patt< ($`str:p_con$, $patt$) >> + else + match patt with + [ <:patt< _ >> -> <:patt< ($`str:p_con$, $`str:p_prm$) >> + | _ -> <:patt< ($`str:p_con$, ($`str:p_prm$ as $patt$)) >> ] + in + <:expr< + match Stream.peek __strm with + [ Some $p$ -> do { Stream.junk __strm; $rkont$ } + | _ -> $fkont$ ] + >> + | _ -> + parse_standard_symbol <:expr< not_impl >> rkont fkont ending_act ] +and symbol_parser entry nlevn = + fun + [ Snterm e -> + let n = e.ename ^ "_0" in + <:expr< $lid:n$ >> + | Snterml e l -> + let n = e.ename ^ "_" ^ string_of_int (level_number e l) in + <:expr< $lid:n$ >> + | Snext -> + let n = entry.ename ^ "_" ^ string_of_int nlevn in + if strict_parsing.val then <:expr< $lid:n$ >> + else + let n0 = entry.ename ^ "_0" in + <:expr< P.orzero $lid:n$ $lid:n0$ >> + | Stoken tok -> + let _ = + do { + if fst tok = "" && not (List.mem (snd tok) keywords.val) then + keywords.val := [snd tok :: keywords.val] + else () + } + in + <:expr< P.token ($`str:fst tok$, $`str:snd tok$) >> + | Stree tree -> + let kont = <:expr< raise Stream.Failure >> in + let act_kont _ act = final_action act in + <:expr< + fun __strm -> + $parse_tree phony_entry 0 0 (tree, True) act_kont kont$ + >> + | _ -> + <:expr< aaa >> ] +; + +value rec start_parser_of_levels entry clevn levs = + let n = entry.ename ^ "_" ^ string_of_int clevn in + let next = entry.ename ^ "_" ^ string_of_int (clevn + 1) in + let p = <:patt< $lid:n$ >> in + match levs with + [ [] -> [Some (p, <:expr< fun __strm -> raise Stream.Failure >>)] + | [lev :: levs] -> + let pel = start_parser_of_levels entry (succ clevn) levs in + match lev.lprefix with + [ DeadEnd -> + let ncont = + if not strict_parsing.val && clevn = 0 then + entry.ename ^ "_gen_cont" + else entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" + in + let curr = + <:expr< let a = $lid:next$ __strm in $lid:ncont$ bp a __strm >> + in + let curr = <:expr< let bp = Stream.count __strm in $curr$ >> in + let e = <:expr< fun __strm -> $curr$ >> in + let pel = if levs = [] then [] else pel in + [Some (p, e) :: pel] + | tree -> + let alevn = clevn in + let (kont, pel) = + match levs with + [ [] -> (<:expr< raise Stream.Failure >>, []) + | _ -> + let e = + match (lev.assoc, lev.lsuffix) with + [ (NonA, _) | (_, DeadEnd) -> <:expr< $lid:next$ __strm >> + | _ -> + let ncont = + entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" + in + <:expr< + let a = $lid:next$ __strm in + $lid:ncont$ bp a __strm + >> ] + in + (e, pel) ] + in + let act_kont end_with_self act = + if lev.lsuffix = DeadEnd then gen_let_loc _loc (final_action act) + else + let ncont = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in + gen_let_loc _loc + <:expr< $lid:ncont$ bp $final_action act$ __strm >> + in + let curr = + parse_tree entry (succ clevn) alevn (tree, True) act_kont kont + in + let curr = <:expr< let bp = Stream.count __strm in $curr$ >> in + let e = <:expr< fun __strm -> $curr$ >> in + [Some (p, e) :: pel] ] ] +; + +value rec continue_parser_of_levels entry clevn levs = + let n = entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" in + let p = <:patt< $lid:n$ >> in + match levs with + [ [] -> [None] + | [lev :: levs] -> + let pel = continue_parser_of_levels entry (succ clevn) levs in + match lev.lsuffix with + [ DeadEnd -> + [None :: pel] + | tree -> + let alevn = + match lev.assoc with + [ LeftA | NonA -> succ clevn + | RightA -> clevn ] + in + let (kont, pel) = + match levs with + [ [] -> (<:expr< a__ >>, []) + | _ -> (<:expr< a__ >>, pel) ] + in + let act_kont end_with_self act = + let p = last_patt_of_act act in + match lev.assoc with + [ RightA | NonA -> + <:expr< + let $p$ = a__ in + $gen_let_loc _loc (final_action act)$ + >> + | LeftA -> + let ncont = + entry.ename ^ "_" ^ string_of_int clevn ^ "_cont" + in + gen_let_loc _loc + <:expr< + let $p$ = a__ in + $lid:ncont$ bp $final_action act$ __strm + >> ] + in + let curr = + parse_tree entry (succ clevn) alevn (tree, True) act_kont kont + in + let e = <:expr< fun bp a__ __strm -> $curr$ >> in + [Some (p, e) :: pel] ] ] +; + +value continue_parser_of_levels_again entry levs = + let n = entry.ename ^ "_gen_cont" in + let e = + loop <:expr< a__ >> 0 levs where rec loop var levn = + fun + [ [] -> <:expr< if x == a__ then x else $lid:n$ bp x __strm >> + | [lev :: levs] -> + match lev.lsuffix with + [ DeadEnd -> loop var (levn + 1) levs + | _ -> + let n = entry.ename ^ "_" ^ string_of_int levn ^ "_cont" in + let rest = loop <:expr< x >> (levn + 1) levs in + <:expr< let x = $lid:n$ bp $var$ __strm in $rest$ >> ] ] + in + (<:patt< $lid:n$ >>, <:expr< fun bp a__ __strm -> $e$ >>) +; + +value empty_entry ename = + let p = <:patt< $lid:ename$ >> in + let e = + <:expr< + fun __strm -> + raise (Stream.Error $str:"entry [" ^ ename ^ "] is empty"$) >> + in + [Some (p, e)] +; + +value start_parser_of_entry entry = + match entry.edesc with + [ Dlevels [] -> empty_entry entry.ename + | Dlevels elev -> start_parser_of_levels entry 0 elev + | Dparser p -> [] ] +; + +value continue_parser_of_entry entry = + match entry.edesc with + [ Dlevels elev -> continue_parser_of_levels entry 0 elev + | Dparser p -> [] ] +; + +value continue_parser_of_entry_again entry = + if strict_parsing.val then [] + else + match entry.edesc with + [ Dlevels ([_; _ :: _] as levs) -> + [continue_parser_of_levels_again entry levs] + | _ -> [] ] +; + +value rec list_alternate l1 l2 = + match (l1, l2) with + [ ([x1 :: l1], [x2 :: l2]) -> [x1; x2 :: list_alternate l1 l2] + | ([], l2) -> l2 + | (l1, []) -> l1 ] +; + +value compile_entry entry = + let pel1 = start_parser_of_entry entry in + let pel2 = continue_parser_of_entry entry in + let pel = list_alternate pel1 pel2 in + List.fold_right + (fun pe list -> + match pe with + [ Some pe -> [pe :: list] + | None -> list ]) + pel (continue_parser_of_entry_again entry) +; + +(* get all entries connected together *) + +value rec scan_tree list = + fun + [ Node {node = n; son = son; brother = bro} -> + let list = scan_symbol list n in + let list = scan_tree list son in + let list = scan_tree list bro in + list + | LocAct _ _ | DeadEnd -> list ] +and scan_symbol list = + fun + [ Snterm e -> scan_entry list e + | Snterml e l -> scan_entry list e + | Slist0 s -> scan_symbol list s + | Slist0sep s sep -> scan_symbol (scan_symbol list s) sep + | Slist1 s -> scan_symbol list s + | Slist1sep s sep -> scan_symbol (scan_symbol list s) sep + | Sopt s -> scan_symbol list s + | Stree t -> scan_tree list t + | Smeta _ _ _ | Sself | Snext | Stoken _ -> list ] +and scan_level list lev = + let list = scan_tree list lev.lsuffix in + let list = scan_tree list lev.lprefix in + list +and scan_levels list levs = List.fold_left scan_level list levs +and scan_entry list entry = + if List.memq entry list then list + else + match entry.edesc with + [ Dlevels levs -> scan_levels [entry :: list] levs + | Dparser _ -> list ] +; + +value all_entries_in_graph list entry = + List.rev (scan_entry list entry) +; + +(* main *) + +value entries = ref []; + +value rec list_mem_right_assoc x = + fun + [ [] -> False + | [(a, b) :: l] -> x = b || list_mem_right_assoc x l ] +; + +value rec expr_list = + fun + [ [] -> <:expr< [] >> + | [x :: l] -> <:expr< [$`str:x$ :: $expr_list l$] >> ] +; + +value compile () = + let _ = do { keywords.val := []; } in + let list = List.fold_left all_entries_in_graph [] entries.val in + let list = + List.filter (fun e -> List.memq e list) entries.val @ + List.filter (fun e -> not (List.memq e entries.val)) list + in + let list = + let set = ref [] in + List.fold_right + (fun entry list -> + if List.mem entry.ename set.val then + list + else do { set.val := [entry.ename :: set.val]; [entry :: list] }) + list [] + in + let pell = List.map compile_entry list in + let pel = List.flatten pell in + let si1 = <:str_item< value rec $list:pel$ >> in + let si2 = + let list = List.sort compare keywords.val in + <:str_item< + List.iter (fun kw -> P.lexer.Token.tok_using ("", kw)) + $expr_list list$ + >> + in + let loc = Loc.ghost in + ([(si1, loc); (si2, loc)], False) +; + +Pcaml.parse_implem.val := fun _ _ -> compile (); + +Pcaml.add_option "-strict_parsing" (Arg.Set strict_parsing) + "Don't generate error recovering by trying continuations or first levels" +; diff --git a/ocaml-binary-annot/camlp4/unmaintained/compile/compile.sh b/ocaml-binary-annot/camlp4/unmaintained/compile/compile.sh new file mode 100755 index 0000000000..a2f4f77321 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/compile/compile.sh @@ -0,0 +1,27 @@ +#!/bin/sh -e + +ARGS= +FILES= +ENTRIES= +while test "" != "$1"; do + case $1 in + -e) + shift; + if test "$ENTRIES" != ""; then ENTRIES="$ENTRIES; "; fi + ENTRIES="$ENTRIES$1";; + *.ml*) FILES="$FILES $1";; + *) ARGS="$ARGS $1";; + esac + shift +done + +cat $FILES | sed -e 's/Pcaml.parse_i.*$//' > tmp.ml +echo "Compile.entries.val := [$ENTRIES];" >> tmp.ml +> tmp.mli +set -x +$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -c tmp.mli +$OTOP/boot/ocamlrun$EXE ../boot/camlp4boot$EXE -meta_action tmp.ml -o tmp.ppo +$OTOP/boot/ocamlrun$EXE $OTOP/boot/ocamlc -I $OTOP/boot -I ../lib -I ../camlp4 -c -impl tmp.ppo +rm tmp.ppo +> tmp.null +$OTOP/boot/ocamlrun$EXE ../camlp4/camlp4$EXE ./compile.cmo ./tmp.cmo ../etc/pr_r.cmo ../etc/pr_rp.cmo $ARGS -sep "\n\n" -impl tmp.null && rm tmp.* diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/.cvsignore b/ocaml-binary-annot/camlp4/unmaintained/etc/.cvsignore new file mode 100644 index 0000000000..50d8a8ea2f --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/.cvsignore @@ -0,0 +1,7 @@ +*.cm[oia] +camlp4o +camlp4sch +camlp4o.opt +version.sh +mkcamlp4.sh +mkcamlp4.mpw diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/.depend b/ocaml-binary-annot/camlp4/unmaintained/etc/.depend new file mode 100644 index 0000000000..863adc1cad --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/.depend @@ -0,0 +1,6 @@ +parserify.cmo: parserify.cmi +parserify.cmx: parserify.cmi +pr_op_main.cmo: parserify.cmi +pr_op_main.cmx: parserify.cmx +pr_rp_main.cmo: parserify.cmi +pr_rp_main.cmx: parserify.cmx diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/Makefile b/ocaml-binary-annot/camlp4/unmaintained/etc/Makefile new file mode 100644 index 0000000000..47bc412044 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/Makefile @@ -0,0 +1,62 @@ + + +include ../config/Makefile.cnf + +INCLUDES=-I ../camlp4 -I ../lib -I ../meta -I $(OTOP)/lex -I $(OTOP)/parsing +OBJS=q_phony.cmo pa_o.cmo pa_op.cmo pa_oop.cmo pa_ru.cmo pa_extfun.cmo pa_fstream.cmo pa_ifdef.cmo pr_r.cmo pr_rp.cmo pr_o.cmo pr_op.cmo pr_extend.cmo pr_extfun.cmo pr_null.cmo pr_depend.cmo genTraversal.cmo fi_exc_tracer.cmo +INTF=pa_o.cmi +CAMLP4OM=pa_o.cmo pa_op.cmo ../meta/pr_dump.cmo +CAMLP4OMX=$(CAMLP4OM:.cmo=.cmx) +EXECUTABLES=camlp4o + +include ../config/Makefile.base + +all-local: mkcamlp4.sh + +pr_rp.cmo: parserify.cmo pr_rp_main.cmo + $(OCAMLC) parserify.cmo pr_rp_main.cmo -a -o $@ + +pr_op.cmo: parserify.cmo pr_op_main.cmo + $(OCAMLC) parserify.cmo pr_op_main.cmo -a -o $@ + +pr_rp.cmx: parserify.cmx pr_rp_main.cmx + $(OCAMLOPT) parserify.cmx pr_rp_main.cmx -a -o pr_rp.cmxa + mv pr_rp.cmxa pr_rp.cmx + mv pr_rp.$(A) pr_rp.$(O) + +pr_op.cmx: parserify.cmx pr_op_main.cmx + $(OCAMLOPT) parserify.cmx pr_op_main.cmx -a -o pr_op.cmxa + mv pr_op.cmxa pr_op.cmx + mv pr_op.$(A) pr_op.$(O) + +camlp4o$(EXE): ../camlp4/camlp4$(EXE) $(CAMLP4OM) + rm -f camlp4o$(EXE) + cd ../camlp4; $(MAKE) CAMLP4=../etc/camlp4o$(EXE) CAMLP4M="-I ../etc $(CAMLP4OM)" + +camlp4o.opt: $(CAMLP4OMX) + rm -f camlp4o.opt + cd ../camlp4; $(MAKE) ../etc/camlp4o.opt CAMLP4OPT=../etc/camlp4o.opt CAMLP4M="-I ../etc $(CAMLP4OMX)" + +mkcamlp4.sh: mkcamlp4.sh.tpl version.sh + sed -e "s!LIBDIR!$(LIBDIR)!g" -e "/define VERSION/r version.sh" \ + mkcamlp4.sh.tpl > mkcamlp4.sh + +version.sh : $(OTOP)/VERSION + echo "VERSION=\"`sed -e 1q ../VERSION`\"" >version.sh + +install-local: + -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" + cp $(OBJS) "$(LIBDIR)/camlp4/." + cp $(INTF) "$(LIBDIR)/camlp4/." + cp camlp4o$(EXE) "$(BINDIR)/." + if test -f camlp4o.opt; then \ + cp camlp4o.opt "$(BINDIR)/camlp4o.opt$(EXE)"; \ + cp $(OBJSX) "$(LIBDIR)/camlp4/."; \ + for file in $(OBJSX); do \ + cp "`echo $$file | sed -e 's/\.cmx$$/.$(O)/'`" "$(LIBDIR)/camlp4/."; \ + done ; \ + fi + cp mkcamlp4.sh "$(BINDIR)/mkcamlp4" + chmod a+x "$(BINDIR)/mkcamlp4" + +include .depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/pa_fstream.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/pa_fstream.ml new file mode 100644 index 0000000000..e5027b5805 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/pa_fstream.ml @@ -0,0 +1,163 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) + + +open Pcaml; + +type spat_comp = + [ SpTrm of Loc.t and MLast.patt and option MLast.expr + | SpNtr of Loc.t and MLast.patt and MLast.expr + | SpStr of Loc.t and MLast.patt ] +; +type sexp_comp = + [ SeTrm of Loc.t and MLast.expr + | SeNtr of Loc.t and MLast.expr ] +; + +(* parsers *) + +value strm_n = "__strm"; +value next_fun _loc = <:expr< Fstream.next >>; + +value rec pattern_eq_expression p e = + match (p, e) with + [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b + | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b + | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> + pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 + | (<:patt< ($list:pl$) >>, <:expr< ($list:el$) >>) -> + loop pl el where rec loop pl el = + match (pl, el) with + [ ([p :: pl], [e :: el]) -> + pattern_eq_expression p e && loop pl el + | ([], []) -> True + | _ -> False ] + | _ -> False ] +; + +value stream_pattern_component skont = + fun + [ SpTrm _loc p wo -> + let p = <:patt< Some ($p$, $lid:strm_n$) >> in + if wo = None && pattern_eq_expression p skont then + <:expr< $next_fun _loc$ $lid:strm_n$ >> + else + <:expr< match $next_fun _loc$ $lid:strm_n$ with + [ $p$ $when:wo$ -> $skont$ + | _ -> None ] >> + | SpNtr _loc p e -> + let p = <:patt< Some ($p$, $lid:strm_n$) >> in + if pattern_eq_expression p skont then <:expr< $e$ $lid:strm_n$ >> + else + <:expr< match $e$ $lid:strm_n$ with + [ $p$ -> $skont$ + | _ -> None ] >> + | SpStr _loc p -> + <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] +; + +value rec stream_pattern _loc epo e = + fun + [ [] -> + let e = + match epo with + [ Some ep -> <:expr< let $ep$ = Fstream.count $lid:strm_n$ in $e$ >> + | None -> e ] + in + <:expr< Some ($e$, $lid:strm_n$) >> + | [spc :: spcl] -> + let skont = stream_pattern _loc epo e spcl in + stream_pattern_component skont spc ] +; + +value rec parser_cases _loc = + fun + [ [] -> <:expr< None >> + | [(spcl, epo, e) :: spel] -> + match parser_cases _loc spel with + [ <:expr< None >> -> stream_pattern _loc epo e spcl + | pc -> + <:expr< match $stream_pattern _loc epo e spcl$ with + [ Some _ as x -> x + | None -> $pc$ ] >> ] ] +; + +value cparser_match _loc me bpo pc = + let pc = parser_cases _loc pc in + let e = + match bpo with + [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> + | None -> pc ] + in + <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> +; + +value cparser _loc bpo pc = + let e = parser_cases _loc pc in + let e = + match bpo with + [ Some bp -> <:expr< let $bp$ = Fstream.count $lid:strm_n$ in $e$ >> + | None -> e ] + in + let p = <:patt< ($lid:strm_n$ : Fstream.t _) >> in <:expr< fun $p$ -> $e$ >> +; + +(* streams *) + +value slazy _loc x = <:expr< fun () -> $x$ >>; + +value rec cstream _loc = + fun + [ [] -> <:expr< Fstream.nil >> + | [SeTrm _loc e :: sel] -> + let e2 = cstream _loc sel in + let x = <:expr< Fstream.cons $e$ $e2$ >> in + <:expr< Fstream.flazy $slazy _loc x$ >> + | [SeNtr _loc e] -> + e + | [SeNtr _loc e :: sel] -> + let e2 = cstream _loc sel in + let x = <:expr< Fstream.app $e$ $e2$ >> in + <:expr< Fstream.flazy $slazy _loc x$ >> ] +; + +EXTEND + GLOBAL: expr; + expr: LEVEL "top" + [ [ "fparser"; po = OPT ipatt; "["; pcl = LIST0 parser_case SEP "|"; "]" -> + <:expr< $cparser _loc po pcl$ >> + | "fparser"; po = OPT ipatt; pc = parser_case -> + <:expr< $cparser _loc po [pc]$ >> + | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; "["; + pcl = LIST0 parser_case SEP "|"; "]" -> + <:expr< $cparser_match _loc e po pcl$ >> + | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; + pc = parser_case -> + <:expr< $cparser_match _loc e po [pc]$ >> ] ] + ; + parser_case: + [ [ "[:"; sp = stream_patt; ":]"; po = OPT ipatt; "->"; e = expr -> + (sp, po, e) ] ] + ; + stream_patt: + [ [ spc = stream_patt_comp -> [spc] + | spc = stream_patt_comp; ";"; sp = LIST1 stream_patt_comp SEP ";" -> + [spc :: sp] + | -> [] ] ] + ; + stream_patt_comp: + [ [ "`"; p = patt; eo = OPT [ "when"; e = expr -> e ] -> SpTrm _loc p eo + | p = patt; "="; e = expr -> SpNtr _loc p e + | p = patt -> SpStr _loc p ] ] + ; + ipatt: + [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] + ; + expr: LEVEL "simple" + [ [ "fstream"; "[:"; se = LIST0 stream_expr_comp SEP ";"; ":]" -> + <:expr< $cstream _loc se$ >> ] ] + ; + stream_expr_comp: + [ [ "`"; e = expr -> SeTrm _loc e + | e = expr -> SeNtr _loc e ] ] + ; +END; diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/pa_ifdef.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/pa_ifdef.ml new file mode 100644 index 0000000000..06652630a0 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/pa_ifdef.ml @@ -0,0 +1,91 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) + + +(* This module is deprecated since version 3.07; use pa_macro.ml instead *) + +value _ = + prerr_endline "Warning: pa_ifdef is deprecated since OCaml 3.07. Use pa_macro instead." +; + +type item_or_def 'a = + [ SdStr of 'a | SdDef of string | SdUnd of string | SdNop ] +; + +value list_remove x l = + List.fold_right (fun e l -> if e = x then l else [e :: l]) l [] +; + +value defined = ref ["OCAML_308"; "OCAML_307"; "OCAML_305"; "CAMLP4_300"; "NEWSEQ"]; +value define x = defined.val := [x :: defined.val]; +value undef x = defined.val := list_remove x defined.val; + +EXTEND + GLOBAL: Pcaml.expr Pcaml.str_item Pcaml.sig_item; + Pcaml.expr: LEVEL "top" + [ [ "ifdef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else"; + e2 = Pcaml.expr -> + if List.mem c defined.val then e1 else e2 + | "ifndef"; c = UIDENT; "then"; e1 = Pcaml.expr; "else"; + e2 = Pcaml.expr -> + if List.mem c defined.val then e2 else e1 ] ] + ; + Pcaml.str_item: FIRST + [ [ x = def_undef_str -> + match x with + [ SdStr si -> si + | SdDef x -> do { define x; <:str_item< declare end >> } + | SdUnd x -> do { undef x; <:str_item< declare end >> } + | SdNop -> <:str_item< declare end >> ] ] ] + ; + def_undef_str: + [ [ "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef; + "else"; e2 = str_item_def_undef -> + if List.mem c defined.val then e1 else e2 + | "ifdef"; c = UIDENT; "then"; e1 = str_item_def_undef -> + if List.mem c defined.val then e1 else SdNop + | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef; + "else"; e2 = str_item_def_undef -> + if List.mem c defined.val then e2 else e1 + | "ifndef"; c = UIDENT; "then"; e1 = str_item_def_undef -> + if List.mem c defined.val then SdNop else e1 + | "define"; c = UIDENT -> SdDef c + | "undef"; c = UIDENT -> SdUnd c ] ] + ; + str_item_def_undef: + [ [ d = def_undef_str -> d + | si = Pcaml.str_item -> SdStr si ] ] + ; + Pcaml.sig_item: FIRST + [ [ x = def_undef_sig -> + match x with + [ SdStr si -> si + | SdDef x -> do { define x; <:sig_item< declare end >> } + | SdUnd x -> do { undef x; <:sig_item< declare end >> } + | SdNop -> <:sig_item< declare end >> ] ] ] + ; + def_undef_sig: + [ [ "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef; + "else"; e2 = sig_item_def_undef -> + if List.mem c defined.val then e1 else e2 + | "ifdef"; c = UIDENT; "then"; e1 = sig_item_def_undef -> + if List.mem c defined.val then e1 else SdNop + | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef; + "else"; e2 = sig_item_def_undef -> + if List.mem c defined.val then e2 else e1 + | "ifndef"; c = UIDENT; "then"; e1 = sig_item_def_undef -> + if List.mem c defined.val then SdNop else e1 + | "define"; c = UIDENT -> SdDef c + | "undef"; c = UIDENT -> SdUnd c ] ] + ; + sig_item_def_undef: + [ [ d = def_undef_sig -> d + | si = Pcaml.sig_item -> SdStr si ] ] + ; +END; + +Pcaml.add_option "-D" (Arg.String define) + "<string> Define for ifdef instruction." +; +Pcaml.add_option "-U" (Arg.String undef) + "<string> Undefine for ifdef instruction." +; diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/pa_oop.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/pa_oop.ml new file mode 100644 index 0000000000..bb5684ba4e --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/pa_oop.ml @@ -0,0 +1,155 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + + + +open Pcaml; + +type spat_comp = + [ SpTrm of Loc.t and MLast.patt and option MLast.expr + | SpNtr of Loc.t and MLast.patt and MLast.expr + | SpStr of Loc.t and MLast.patt ] +; +type sexp_comp = + [ SeTrm of Loc.t and MLast.expr | SeNtr of Loc.t and MLast.expr ] +; + +value strm_n = "__strm"; +value peek_fun _loc = <:expr< Stream.peek >>; +value junk_fun _loc = <:expr< Stream.junk >>; + +(* Parsers. *) + +value stream_pattern_component skont = + fun + [ SpTrm _loc p wo -> + (<:expr< $peek_fun _loc$ $lid:strm_n$ >>, p, wo, + <:expr< do { $junk_fun _loc$ $lid:strm_n$; $skont$ } >>) + | SpNtr _loc p e -> + (<:expr< try Some ($e$ $lid:strm_n$) with + [ Stream.Failure -> None ] >>, + p, None, skont) + | SpStr _loc p -> + (<:expr< Some $lid:strm_n$ >>, p, None, skont) ] +; + +value rec stream_pattern _loc epo e ekont = + fun + [ [] -> + match epo with + [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> + | _ -> e ] + | [(spc, err) :: spcl] -> + let skont = + let ekont err = + let str = + match err with + [ Some estr -> estr + | _ -> <:expr< "" >> ] + in + <:expr< raise (Stream.Error $str$) >> + in + stream_pattern _loc epo e ekont spcl + in + let (tst, p, wo, e) = stream_pattern_component skont spc in + let ckont = ekont err in + <:expr< match $tst$ with + [ Some $p$ $when:wo$ -> $e$ | _ -> $ckont$ ] >> ] +; + +value rec parser_cases _loc = + fun + [ [] -> <:expr< raise Stream.Failure >> + | [(spcl, epo, e) :: spel] -> + stream_pattern _loc epo e (fun _ -> parser_cases _loc spel) spcl ] +; + +value cparser _loc bpo pc = + let e = parser_cases _loc pc in + let e = + match bpo with + [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> + | None -> e ] + in + let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in + <:expr< fun $p$ -> $e$ >> +; + +value cparser_match _loc me bpo pc = + let pc = parser_cases _loc pc in + let e = + match bpo with + [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> + | None -> pc ] + in + <:expr< let $lid:strm_n$ = $me$ in $e$ >> +; + +(* streams *) + +value slazy _loc e = <:expr< fun _ -> $e$ >>; + +value rec cstream gloc = + fun + [ [] -> let _loc = gloc in <:expr< Stream.sempty >> + | [SeTrm _loc e :: secl] -> + <:expr< Stream.lcons $slazy _loc e$ $cstream gloc secl$ >> + | [SeNtr _loc e :: secl] -> + <:expr< Stream.lapp $slazy _loc e$ $cstream gloc secl$ >> ] +; + +(* Syntax extensions in Ocaml grammar *) + + +EXTEND + GLOBAL: expr; + expr: LEVEL "expr1" + [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" -> + <:expr< $cparser _loc po pcl$ >> + | "match"; e = expr; "with"; "parser"; po = OPT ipatt; OPT "|"; + pcl = LIST1 parser_case SEP "|" -> + <:expr< $cparser_match _loc e po pcl$ >> ] ] + ; + parser_case: + [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr -> + (sp, po, e) ] ] + ; + stream_patt: + [ [ spc = stream_patt_comp -> [(spc, None)] + | spc = stream_patt_comp; ";"; sp = LIST1 stream_patt_comp_err SEP ";" -> + [(spc, None) :: sp] + | (* empty *) -> [] ] ] + ; + stream_patt_comp_err: + [ [ spc = stream_patt_comp; + eo = OPT [ "??"; e = expr LEVEL "expr1" -> e ] -> + (spc, eo) ] ] + ; + stream_patt_comp: + [ [ "'"; p = patt; eo = OPT [ "when"; e = (expr LEVEL "expr1") -> e ] -> + SpTrm _loc p eo + | p = patt; "="; e = (expr LEVEL "expr1") -> SpNtr _loc p e + | p = patt -> SpStr _loc p ] ] + ; + ipatt: + [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] + ; + + expr: LEVEL "simple" + [ [ "[<"; se = LIST0 stream_expr_comp SEP ";"; ">]" -> + <:expr< $cstream _loc se$ >> ] ] + ; + stream_expr_comp: + [ [ "'"; e = expr LEVEL "expr1" -> SeTrm _loc e + | e = expr LEVEL "expr1" -> SeNtr _loc e ] ] + ; +END; diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/pa_ru.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/pa_ru.ml new file mode 100644 index 0000000000..1761c5e47f --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/pa_ru.ml @@ -0,0 +1,46 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + + + +open Pcaml; + +value o2b = + fun + [ Some _ -> True + | None -> False ] +; + +EXTEND + GLOBAL: expr; + expr: LEVEL "top" + [ [ "do"; "{"; seq = sequence; "}" -> + match seq with + [ [e] -> e + | _ -> <:expr< do { $list:seq$ } >> ] ] ] + ; + sequence: + [ [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; [ "in" | ";" ]; + el = SELF -> + let e = + match el with + [ [e] -> e + | _ -> <:expr< do { $list:el$ } >> ] + in + [ <:expr< let $opt:o2b o$ $list:l$ in $e$ >> ] + | e = expr; ";"; el = SELF -> + let e = let _loc = MLast.loc_of_expr e in <:expr< ($e$ : unit) >> in + [e :: el] + | e = expr; ";" -> [e] + | e = expr -> [e] ] ] + ; +END; diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/parserify.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/parserify.ml new file mode 100644 index 0000000000..f0a3be8bbb --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/parserify.ml @@ -0,0 +1,305 @@ +(* camlp4r q_MLast.cmo *) + + +(* FIXME FIXME *) +value _loc = Loc.mk "FIXME parserify.ml"; + +type spc = + [ SPCterm of (MLast.patt * option MLast.expr) + | SPCnterm of MLast.patt and MLast.expr + | SPCsterm of MLast.patt ] +; + +exception NotImpl; + +value rec subst v = + MLast.Map.Expr.expr (fun [ <:expr@_loc< __strm >> -> <:expr< $lid:v$ >> + | e -> e ]) +(* FIXME FIXME *) + (* match e with + [ <:expr< $lid:x$ >> -> if x = "__strm" then <:expr< $lid:v$ >> else e + | <:expr< $uid:_$ >> -> e + | <:expr< $int:_$ >> -> e + | <:expr< $chr:_$ >> -> e + | <:expr< $str:_$ >> -> e + | <:expr@_loc< $e1$ . $lab$ >> -> <:expr< $subst v e1$ . $lab$ >> + | <:expr@_loc< $x$ $y$ >> -> <:expr< $subst v x$ $subst v y$ >> + | <:expr@_loc< let $lid:s1$ = $e1$ in $e2$ >> -> + if s1 = v then <:expr< let $lid:s1$ = $subst v e1$ in $e2$ >> + else <:expr< let $lid:s1$ = $subst v e1$ in $subst v e2$ >> + | <:expr@_loc< let _ = $e1$ in $e2$ >> -> + <:expr< let _ = $subst v e1$ in $subst v e2$ >> + | <:expr@_loc< ($list:el$) >> -> <:expr< ($list:List.map (subst v) el$) >> + | _ -> raise NotImpl ] *) +; + +value rec is_free v = + fun + [ <:expr< $lid:x$ >> -> x <> v + | <:expr< $uid:_$ >> -> True + | <:expr< $int:_$ >> -> True + | <:expr< $chr:_$ >> -> True + | <:expr< $str:_$ >> -> True + | <:expr< $e$ . $_$ >> -> is_free v e + | <:expr< $x$ $y$ >> -> is_free v x && is_free v y + | <:expr< let $lid:s1$ = $e1$ in $e2$ >> -> + is_free v e1 && (s1 = v || is_free v e2) + | <:expr< let _ = $e1$ in $e2$ >> -> is_free v e1 && is_free v e2 + | <:expr< ($list:el$) >> -> List.for_all (is_free v) el + | _ -> raise NotImpl ] +; + +value gensym = + let cnt = ref 0 in + fun () -> + do { incr cnt; "pr_rp_symb_" ^ string_of_int cnt.val } +; + +value free_var_in_expr c e = + let rec loop_alpha v = + let x = String.make 1 v in + if is_free x e then Some x + else if v = 'z' then None + else loop_alpha (Char.chr (Char.code v + 1)) + in + let rec loop_count cnt = + let x = String.make 1 c ^ string_of_int cnt in + if is_free x e then x else loop_count (succ cnt) + in + try + match loop_alpha c with + [ Some v -> v + | None -> loop_count 1 ] + with + [ NotImpl -> gensym () ] +; + +value parserify _loc = + fun + [ <:expr< $e$ __strm >> -> e + | e -> <:expr< fun __strm -> $e$ >> ] +; + +value is_raise_failure = + fun + [ <:expr< raise Stream.Failure >> -> True + | _ -> False ] +; + +value is_raise_error = + fun + [ <:expr< raise (Stream.Error $_$) >> -> True + | _ -> False ] +; + +value semantic _loc e = + try + if is_free "__strm" e then e + else + let v = free_var_in_expr 's' e in + <:expr< let $lid:v$ = __strm in $subst v e$ >> + with + [ NotImpl -> e ] +; + +value rewrite_parser = + rewrite True where rec rewrite top ge = + match ge with + [ <:expr@_loc< let $p$ = try $e$ with [ Stream.Failure -> raise $exc$ ] in + $sp_kont$ >> -> + let f = parserify _loc e in + <:expr< + match try Some ($f$ __strm) with [ Stream.Failure -> None ] with + [ Some $p$ -> $rewrite False sp_kont$ + | _ -> raise $exc$ ] + >> + | <:expr@_loc< let $p$ = Stream.count __strm in $f$ >> -> + try + if is_free "__strm" f then ge + else + let v = free_var_in_expr 's' f in + <:expr< + let $lid:v$ = __strm in + let $p$ = Stream.count __strm in $subst v f$ + >> + with + [ NotImpl -> ge ] + | <:expr@_loc< let $p$ = __strm in $e$ >> -> + <:expr< let $p$ = __strm in $rewrite False e$ >> + | <:expr@_loc< let $p$ = $f$ __strm in $sp_kont$ >> when top -> + <:expr< + match try Some ($f$ __strm) with [ Stream.Failure -> None ] with + [ Some $p$ -> $rewrite False sp_kont$ + | _ -> raise Stream.Failure ] + >> + | <:expr@_loc< let $p$ = $e$ in $sp_kont$ >> -> + if match e with + [ <:expr< match try Some $_$ with [ Stream.Failure -> None ] with + [ $list:_$ ] >> + | <:expr< match Stream.peek __strm with [ $list:_$ ] >> + | <:expr< try $_$ with [ Stream.Failure -> $_$ ] >> + | <:expr< let $_$ = Stream.count __strm in $_$ >> -> True + | _ -> False ] + then + let f = rewrite True <:expr< fun __strm -> $e$ >> in + let exc = + if top then <:expr< Stream.Failure >> + else <:expr< Stream.Error "" >> + in + <:expr< + match try Some ($f$ __strm) with [ Stream.Failure -> None ] with + [ Some $p$ -> $rewrite False sp_kont$ + | _ -> raise $exc$ ] + >> + else semantic _loc ge + | <:expr@_loc< match try Some $e$ with [ Stream.Failure -> None ] with + [ Some $p$ -> $sp_kont$ + | _ -> $p_kont$ ] >> -> + let f = parserify _loc e in + if not top && is_raise_failure p_kont then semantic _loc ge + else + let (p, f, sp_kont, p_kont) = + if top || is_raise_error p_kont then + (p, f, rewrite False sp_kont, rewrite top p_kont) + else + let f = + <:expr< + fun __strm -> + match + try Some ($f$ __strm) with [ Stream.Failure -> None ] + with + [ Some $p$ -> $rewrite False sp_kont$ + | _ -> $rewrite top p_kont$ ] + >> + in + (<:patt< a >>, f, <:expr< a >>, + <:expr< raise (Stream.Error "") >>) + in + <:expr< + match try Some ($f$ __strm) with [ Stream.Failure -> None ] with + [ Some $p$ -> $sp_kont$ + | _ -> $p_kont$ ] + >> + | <:expr< match Stream.peek __strm with [ $list:pel$ ] >> -> + let rec iter pel = + match pel with + [ [(<:patt< Some $p$ >>, eo, + <:expr< do { Stream.junk __strm; $sp_kont$ } >>); + (<:patt< _ >>, None, p_kont) :: _] -> + <:expr< + match Stream.peek __strm with + [ Some $p$ $when:eo$ -> + do { Stream.junk __strm; $rewrite False sp_kont$ } + | _ -> $rewrite top p_kont$ ] + >> + | [(<:patt< Some $p$ >>, eo, + <:expr< do { Stream.junk __strm; $sp_kont$ } >>) :: pel] -> + let p_kont = iter pel in + <:expr< + match Stream.peek __strm with + [ Some $p$ $when:eo$ -> + do { Stream.junk __strm; $rewrite False sp_kont$ } + | _ -> $p_kont$ ] + >> + | _ -> + <:expr< match Stream.peek __strm with [ $list:pel$ ] >> ] + in + iter pel + | <:expr@_loc< try Some $e$ with [ Stream.Failure -> $p_kont$ ] >> -> + let f = parserify _loc e in + let e = + <:expr< + match try Some ($f$ __strm) with [ Stream.Failure -> None ] with + [ Some a -> Some a + | _ -> $p_kont$ ] + >> + in + rewrite top e + | <:expr@_loc< try $e$ with [ Stream.Failure -> $p_kont$ ] >> -> + let f = parserify _loc e in + let e = + <:expr< + match try Some ($f$ __strm) with [ Stream.Failure -> None ] with + [ Some a -> a + | _ -> $rewrite top p_kont$ ] + >> + in + rewrite top e + | <:expr< $f$ __strm >> -> + if top then + <:expr< + match try Some ($f$ __strm) with [ Stream.Failure -> None ] with + [ Some a -> a + | _ -> raise Stream.Failure ] + >> + else + let v = free_var_in_expr 's' f in + <:expr< let $lid:v$ = __strm in $subst v f$ $lid:v$ >> + | e -> let loc = MLast.loc_of_expr e in semantic loc e ] +; + +value spc_of_parser = + let rec parser_cases e = + match e with + [ <:expr< + match try Some ($f$ __strm) with [ Stream.Failure -> None ] with + [ Some $p$ -> $sp_kont$ + | _ -> $p_kont$ ] + >> -> + let spc = (SPCnterm p f, None) in + let (sp, epo, e) = kont sp_kont in + [([spc :: sp], epo, e) :: parser_cases p_kont] + | <:expr< + match Stream.peek __strm with + [ Some $p$ $when:wo$ -> do { Stream.junk __strm; $sp_kont$ } + | _ -> $p_kont$ ] + >> -> + let spc = (SPCterm (p, wo), None) in + let (sp, epo, e) = kont sp_kont in + [([spc :: sp], epo, e) :: parser_cases p_kont] + | <:expr< let $p$ = __strm in $sp_kont$ >> -> + let spc = (SPCsterm p, None) in + let (sp, epo, e) = kont sp_kont in + [([spc :: sp], epo, e)] + | <:expr< let $p$ = Stream.count __strm in $e$ >> -> [([], Some p, e)] + | <:expr< raise Stream.Failure >> -> [] + | _ -> [([], None, e)] ] + and kont e = + match e with + [ <:expr< + match try Some ($f$ __strm) with [ Stream.Failure -> None ] with + [ Some $p$ -> $sp_kont$ + | _ -> raise (Stream.Error $err$) ] + >> -> + let err = + match err with + [ <:expr< "" >> -> None + | _ -> Some err ] + in + let spc = (SPCnterm p f, err) in + let (sp, epo, e) = kont sp_kont in + ([spc :: sp], epo, e) + | <:expr< + match Stream.peek __strm with + [ Some $p$ $when:wo$ -> do { Stream.junk __strm; $sp_kont$ } + | _ -> raise (Stream.Error $err$) ] + >> -> + let err = + match err with + [ <:expr< "" >> -> None + | _ -> Some err ] + in + let spc = (SPCterm (p, wo), err) in + let (sp, epo, e) = kont sp_kont in + ([spc :: sp], epo, e) + | <:expr< let $p$ = __strm in $sp_kont$ >> -> + let spc = (SPCsterm p, None) in + let (sp, epo, e) = kont sp_kont in + ([spc :: sp], epo, e) + | <:expr< let $p$ = Stream.count __strm in $e$ >> -> ([], Some p, e) + | _ -> ([], None, e) ] + in + parser_cases +; + +value parser_of_expr e = spc_of_parser (rewrite_parser e); diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/parserify.mli b/ocaml-binary-annot/camlp4/unmaintained/etc/parserify.mli new file mode 100644 index 0000000000..c1affdbae8 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/parserify.mli @@ -0,0 +1,12 @@ +(* camlp4r *) + + +type spc = + [ SPCterm of (MLast.patt * option MLast.expr) + | SPCnterm of MLast.patt and MLast.expr + | SPCsterm of MLast.patt ] +; + +value parser_of_expr : + MLast.expr -> + list (list (spc * option MLast.expr) * option MLast.patt * MLast.expr); diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/pr_depend.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_depend.ml new file mode 100644 index 0000000000..53224daa48 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_depend.ml @@ -0,0 +1,321 @@ +(* camlp4r *) + + +open MLast; + +value not_impl name x = + Format.eprintf "pr_depend: not impl: %s; %a@." name ObjTools.print (Obj.repr x) +; + +module StrSet = + Set.Make (struct type t = string; value compare = compare; end) +; + +value fset = ref StrSet.empty; +value addmodule s = fset.val := StrSet.add s fset.val; + +value list = List.iter; + +value option f = + fun + [ Some x -> f x + | None -> () ] +; + +value longident = + fun + [ [s; _ :: _] -> addmodule s + | _ -> () ] +; + +value rec ctyp = + fun + [ TyAcc _ t _ -> ctyp_module t + | TyAli _ t1 t2 -> do { ctyp t1; ctyp t2; } + | TyApp _ t1 t2 -> do { ctyp t1; ctyp t2; } + | TyAny _ -> () + | TyArr _ t1 t2 -> do { ctyp t1; ctyp t2; } + | TyCls _ li -> longident li + | TyLab _ _ t -> ctyp t + | TyLid _ _ -> () + | TyMan _ t1 t2 -> do { ctyp t1; ctyp t2; } + | TyOlb _ _ t -> ctyp t + | TyQuo _ _ -> () + | TyRec _ ldl -> list label_decl ldl + | TySum _ cdl -> list constr_decl cdl + | TyPrv _ t -> ctyp t + | TyTup _ tl -> list ctyp tl + | TyVrn _ sbtll _ -> list variant sbtll + | x -> not_impl "ctyp" x ] +and constr_decl (_, _, tl) = list ctyp tl +and label_decl (_, _, _, t) = ctyp t +and variant = + fun + [ RfTag _ _ tl -> list ctyp tl + | RfInh t -> ctyp t ] +and ctyp_module = + fun + [ TyAcc _ t _ -> ctyp_module t + | TyApp _ t1 t2 -> do { ctyp t1; ctyp t2; } + | TyUid _ m -> addmodule m + | x -> not_impl "ctyp_module" x ] +; + +value rec patt = + fun + [ PaAcc _ p _ -> patt_module p + | PaAli _ p1 p2 -> do { patt p1; patt p2; } + | PaAny _ -> () + | PaApp _ p1 p2 -> do { patt p1; patt p2; } + | PaArr _ pl -> list patt pl + | PaChr _ _ -> () + | PaInt _ _ -> () + | PaLab _ _ po -> option patt po + | PaLid _ _ -> () + | PaOlb _ _ peoo -> + option (fun (p, eo) -> do { patt p; option expr eo }) peoo + | PaOrp _ p1 p2 -> do { patt p1; patt p2; } + | PaRec _ lpl -> list label_patt lpl + | PaRng _ p1 p2 -> do { patt p1; patt p2; } + | PaStr _ _ -> () + | PaTup _ pl -> list patt pl + | PaTyc _ p t -> do { patt p; ctyp t; } + | PaUid _ _ -> () + | PaVrn _ _ -> () + | x -> not_impl "patt" x ] +and patt_module = + fun + [ PaUid _ m -> addmodule m + | PaAcc _ p _ -> patt_module p + | x -> not_impl "patt_module" x ] +and label_patt (p1, p2) = do { patt p1; patt p2; } +and expr = + fun + [ ExAcc _ e1 e2 -> do { expr_module e1; expr e2; } + | ExApp _ e1 e2 -> do { expr e1; expr e2; } + | ExAre _ e1 e2 -> do { expr e1; expr e2; } + | ExArr _ el -> list expr el + | ExAsf _ -> () + | ExAsr _ e -> do { expr e; } + | ExAss _ e1 e2 -> do { expr e1; expr e2; } + | ExChr _ _ -> () + | ExCoe _ e t1 t2 -> do { expr e; option ctyp t1; ctyp t2 } + | ExFor _ _ e1 e2 _ el -> do { expr e1; expr e2; list expr el; } + | ExFun _ pwel -> list match_case pwel + | ExIfe _ e1 e2 e3 -> do { expr e1; expr e2; expr e3; } + | ExInt _ _ -> () + | ExInt32 _ _ -> () + | ExInt64 _ _ -> () + | ExNativeInt _ _ -> () + | ExFlo _ _ -> () + | ExLab _ _ eo -> option expr eo + | ExLaz _ e -> expr e + | ExLet _ _ pel e -> do { list let_binding pel; expr e; } + | ExLid _ _ -> () + | ExLmd _ _ me e -> do { module_expr me; expr e; } + | ExMat _ e pwel -> do { expr e; list match_case pwel; } + | ExNew _ li -> longident li + | ExOlb _ _ eo -> option expr eo + | ExRec _ lel w -> do { list label_expr lel; option expr w; } + | ExSeq _ el -> list expr el + | ExSnd _ e _ -> expr e + | ExSte _ e1 e2 -> do { expr e1; expr e2; } + | ExStr _ _ -> () + | ExTry _ e pwel -> do { expr e; list match_case pwel; } + | ExTup _ el -> list expr el + | ExTyc _ e t -> do { expr e; ctyp t; } + | ExUid _ _ -> () + | ExVrn _ _ -> () + | ExWhi _ e el -> do { expr e; list expr el; } + | x -> not_impl "expr" x ] +and expr_module = + fun + [ ExUid _ m -> addmodule m + | e -> expr e ] +and let_binding (p, e) = do { patt p; expr e } +and label_expr (p, e) = do { patt p; expr e } +and match_case (p, w, e) = do { patt p; option expr w; expr e; } +and module_type = + fun + [ MtAcc _ (MtUid _ m) _ -> addmodule m + | MtFun _ _ mt1 mt2 -> do { module_type mt1; module_type mt2; } + | MtSig _ sil -> list sig_item sil + | MtUid _ _ -> () + | MtWit _ mt wc -> do { module_type mt; list with_constr wc; } + | x -> not_impl "module_type" x ] +and with_constr = + fun + [ WcTyp _ _ _ t -> ctyp t + | x -> not_impl "with_constr" x ] +and sig_item = + fun + [ SgDcl _ sil -> list sig_item sil + | SgExc _ _ tl -> list ctyp tl + | SgExt _ _ t _ -> ctyp t + | SgMod _ _ mt -> module_type mt + | SgRecMod _ mts -> list (fun (_, mt) -> module_type mt) mts + | SgMty _ _ mt -> module_type mt + | SgOpn _ [s :: _] -> addmodule s + | SgTyp _ tdl -> list type_decl tdl + | SgVal _ _ t -> ctyp t + | x -> not_impl "sig_item" x ] +and module_expr = + fun + [ MeAcc _ (MeUid _ m) _ -> addmodule m + | MeApp _ me1 me2 -> do { module_expr me1; module_expr me2; } + | MeFun _ _ mt me -> do { module_type mt; module_expr me; } + | MeStr _ sil -> list str_item sil + | MeTyc _ me mt -> do { module_expr me; module_type mt; } + | MeUid _ _ -> () + | x -> not_impl "module_expr" x ] +and str_item = + fun + [ StCls _ cil -> list (fun ci -> class_expr ci.ciExp) cil + | StDcl _ sil -> list str_item sil + | StDir _ _ _ -> () + | StExc _ _ tl _ -> list ctyp tl + | StExp _ e -> expr e + | StExt _ _ t _ -> ctyp t + | StMod _ _ me -> module_expr me + | StRecMod _ nmtmes -> list (fun (_, mt, me) -> do { module_expr me; module_type mt; }) nmtmes + | StMty _ _ mt -> module_type mt + | StOpn _ [s :: _] -> addmodule s + | StTyp _ tdl -> list type_decl tdl + | StVal _ _ pel -> list let_binding pel + | x -> not_impl "str_item" x ] +and type_decl (_, _, t, _) = ctyp t +and class_expr = + fun + [ CeApp _ ce e -> do { class_expr ce; expr e; } + | CeCon _ li tl -> do { longident li; list ctyp tl; } + | CeFun _ p ce -> do { patt p; class_expr ce; } + | CeLet _ _ pel ce -> do { list let_binding pel; class_expr ce; } + | CeStr _ po csil -> do { option patt po; list class_str_item csil; } + | x -> not_impl "class_expr" x ] +and class_str_item = + fun + [ CrInh _ ce _ -> class_expr ce + | CrIni _ e -> expr e + | CrMth _ _ _ e None -> expr e + | CrMth _ _ _ e (Some t) -> do { expr e; ctyp t } + | CrVal _ _ _ e -> expr e + | CrVir _ _ _ t -> ctyp t + | x -> not_impl "class_str_item" x ] +; + +(* Print dependencies *) + +value load_path = ref [""]; + +value find_in_path path name = + if not (Filename.is_implicit name) then + if Sys.file_exists name then name else raise Not_found + else + let rec try_dir = + fun + [ [] -> raise Not_found + | [dir :: rem] -> + let fullname = Filename.concat dir name in + if Sys.file_exists fullname then fullname else try_dir rem ] + in + try_dir path +; + +value find_depend modname (byt_deps, opt_deps) = + let name = String.uncapitalize modname in + try + let filename = find_in_path load_path.val (name ^ ".mli") in + let basename = Filename.chop_suffix filename ".mli" in + let byt_dep = basename ^ ".cmi" in + let opt_dep = + if Sys.file_exists (basename ^ ".ml") then basename ^ ".cmx" + else basename ^ ".cmi" + in + ([byt_dep :: byt_deps], [opt_dep :: opt_deps]) + with + [ Not_found -> + try + let filename = find_in_path load_path.val (name ^ ".ml") in + let basename = Filename.chop_suffix filename ".ml" in + ([basename ^ ".cmo" :: byt_deps], [basename ^ ".cmx" :: opt_deps]) + with + [ Not_found -> (byt_deps, opt_deps) ] ] +; + +value (depends_on, escaped_eol) = + match Sys.os_type with + [ "Unix" | "Win32" | "Cygwin" -> (": ", "\\\n ") + | "MacOS" -> ("\196 ", "\182\n ") + | _ -> assert False ] +; + +value print_depend target_file deps = + match deps with + [ [] -> () + | _ -> + do { + print_string target_file; + print_string depends_on; + let rec print_items pos = + fun + [ [] -> print_string "\n" + | [dep :: rem] -> + if pos + String.length dep <= 77 then do { + print_string dep; + print_string " "; + print_items (pos + String.length dep + 1) rem + } + else do { + print_string escaped_eol; + print_string dep; + print_string " "; + print_items (String.length dep + 5) rem + } ] + in + print_items (String.length target_file + 2) deps + } ] +; + +(* Main *) + +value depend_sig ast = + do { + fset.val := StrSet.empty; + List.iter (fun (si, _) -> sig_item si) ast; + let basename = Filename.chop_suffix Pcaml.input_file.val ".mli" in + let (byt_deps, _) = StrSet.fold find_depend fset.val ([], []) in + print_depend (basename ^ ".cmi") byt_deps; + } +; + +value depend_str ast = + do { + fset.val := StrSet.empty; + List.iter (fun (si, _) -> str_item si) ast; + let basename = + if Filename.check_suffix Pcaml.input_file.val ".ml" then + Filename.chop_suffix Pcaml.input_file.val ".ml" + else + try + let len = String.rindex Pcaml.input_file.val '.' in + String.sub Pcaml.input_file.val 0 len + with + [ Failure _ | Not_found -> Pcaml.input_file.val ] + in + let init_deps = + if Sys.file_exists (basename ^ ".mli") then + let cmi_name = basename ^ ".cmi" in ([cmi_name], [cmi_name]) + else ([], []) + in + let (byt_deps, opt_deps) = StrSet.fold find_depend fset.val init_deps in + print_depend (basename ^ ".cmo") byt_deps; + print_depend (basename ^ ".cmx") opt_deps; + } +; + +Pcaml.print_interf.val := depend_sig; +Pcaml.print_implem.val := depend_str; + +Pcaml.add_option "-I" + (Arg.String (fun dir -> load_path.val := load_path.val @ [dir])) + "<dir> Add <dir> to the list of include directories."; diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/pr_extend.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_extend.ml new file mode 100644 index 0000000000..5f8b6933d8 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_extend.ml @@ -0,0 +1,518 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + + + +open Pcaml; +open Spretty; + +value no_slist = ref False; + +value expr e dg k = pr_expr.pr_fun "top" e dg k; +value patt e dg k = pr_patt.pr_fun "top" e dg k; + +(* Utilities *) + +value rec list elem el k = + match el with + [ [] -> k + | [x] -> [: `elem x k :] + | [x :: l] -> [: `elem x [: :]; list elem l k :] ] +; + +value rec listws elem sep el k = + match el with + [ [] -> k + | [x] -> [: `elem x k :] + | [x :: l] -> [: `elem x [: `sep :]; listws elem sep l k :] ] +; + +value rec listwbws elem b sep el dg k = + match el with + [ [] -> [: b; k :] + | [x] -> [: `elem b x dg k :] + | [x :: l] -> + let sdg = + match sep with + [ S _ x -> x + | _ -> "" ] + in + [: `elem b x sdg [: :]; listwbws elem [: `sep :] sep l dg k :] ] +; + +(* Extracting *) + +value rec get_globals = + fun + [ [(<:patt< _ >>, <:expr< ($e$ : $uid:gmod1$.Entry.e '$_$) >>) :: pel] -> + let (gmod, gl) = get_globals pel in + if gmod = "" || gmod = gmod1 then (gmod1, [e :: gl]) + else raise Not_found + | [] -> ("", []) + | _ -> raise Not_found ] +; + +value rec get_locals = + fun + [ [(<:patt< $_$ >>, + <:expr< (grammar_entry_create $_$ : $_$) >>) :: pel] -> + get_locals pel + | [] -> () + | _ -> raise Not_found ] +; + +value unposition = + fun + [ <:expr< None >> -> None + | <:expr< Some Gramext.First >> -> Some Gramext.First + | <:expr< Some Gramext.Last >> -> Some Gramext.Last + | <:expr< Some (Gramext.Before $str:s$) >> -> Some (Gramext.Before s) + | <:expr< Some (Gramext.After $str:s$) >> -> Some (Gramext.After s) + | <:expr< Some (Gramext.Level $str:s$) >> -> Some (Gramext.Level s) + | _ -> raise Not_found ] +; + +value unlabel = + fun + [ <:expr< None >> -> None + | <:expr< Some $str:s$ >> -> Some s + | _ -> raise Not_found ] +; + +value unassoc = + fun + [ <:expr< None >> -> None + | <:expr< Some Gramext.NonA >> -> Some Gramext.NonA + | <:expr< Some Gramext.LeftA >> -> Some Gramext.LeftA + | <:expr< Some Gramext.RightA >> -> Some Gramext.RightA + | _ -> raise Not_found ] +; + +value rec unaction = + fun + [ <:expr< fun ($lid:locp$ : Loc.t) -> ($a$ : $_$) >> + when locp = Stdpp.loc_name.val -> + let ao = + match a with + [ <:expr< () >> -> None + | _ -> Some a ] + in + ([], ao) + | <:expr< fun ($p$ : $_$) -> $e$ >> -> + let (pl, a) = unaction e in ([p :: pl], a) + | <:expr@_loc< fun _ -> $e$ >> -> + let (pl, a) = unaction e in ([ <:patt< _ >> :: pl ], a) + | _ -> raise Not_found ] +; + +value untoken = + fun + [ <:expr< ($str:x$, $str:y$) >> -> (x, y) + | _ -> raise Not_found ] +; + +type symbol = + [ Snterm of MLast.expr + | Snterml of MLast.expr and string + | Slist0 of symbol + | Slist0sep of symbol and symbol + | Slist1 of symbol + | Slist1sep of symbol and symbol + | Sopt of symbol + | Sself + | Snext + | Stoken of Token.pattern + | Srules of list (list (option MLast.patt * symbol) * option MLast.expr) ] +; + +value rec unsymbol = + fun + [ <:expr< Gramext.Snterm ($uid:_$.Entry.obj ($e$ : $_$)) >> -> Snterm e + | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$)) $str:s$ >> -> + Snterml e s + | <:expr< Gramext.Snterml ($uid:_$.Entry.obj ($e$ : $_$), $str:s$) >> -> + Snterml e s + | <:expr< Gramext.Slist0 $e$ >> -> Slist0 (unsymbol e) + | <:expr< Gramext.Slist0sep $e1$ $e2$ >> -> + Slist0sep (unsymbol e1) (unsymbol e2) + | <:expr< Gramext.Slist0sep ($e1$, $e2$) >> -> + Slist0sep (unsymbol e1) (unsymbol e2) + | <:expr< Gramext.Slist1 $e$ >> -> Slist1 (unsymbol e) + | <:expr< Gramext.Slist1sep $e1$ $e2$ >> -> + Slist1sep (unsymbol e1) (unsymbol e2) + | <:expr< Gramext.Slist1sep ($e1$, $e2$) >> -> + Slist1sep (unsymbol e1) (unsymbol e2) + | <:expr< Gramext.Sopt $e$ >> -> Sopt (unsymbol e) + | <:expr< Gramext.Sself >> -> Sself + | <:expr< Gramext.Snext >> -> Snext + | <:expr< Gramext.Stoken $e$ >> -> Stoken (untoken e) + | <:expr< Gramext.srules $e$ >> -> Srules (unrule_list [] e) + | _ -> raise Not_found ] +and unpsymbol_list pl e = + match (pl, e) with + [ ([], <:expr< [] >>) -> [] + | ([p :: pl], <:expr< [$e$ :: $el$] >>) -> + let op = + match p with + [ <:patt< _ >> -> None + | _ -> Some p ] + in + [(op, unsymbol e) :: unpsymbol_list pl el] + | _ -> raise Not_found ] +and unrule = + fun + [ <:expr@_loc< ($e1$, Gramext.action $e2$) >> -> + let (pl, a) = + match unaction e2 with + [ ([], None) -> ([], Some <:expr< () >>) + | x -> x ] + in + let sl = unpsymbol_list (List.rev pl) e1 in + (sl, a) + | _ -> raise Not_found ] +and unrule_list rl = + fun + [ <:expr< [$e$ :: $el$] >> -> unrule_list [unrule e :: rl] el + | <:expr< [] >> -> rl + | _ -> raise Not_found ] +; + +value unlevel = + fun + [ <:expr< ($e1$, $e2$, $e3$) >> -> + (unlabel e1, unassoc e2, unrule_list [] e3) + | _ -> raise Not_found ] +; + +value rec unlevel_list = + fun + [ <:expr< [$e$ :: $el$] >> -> [unlevel e :: unlevel_list el] + | <:expr< [] >> -> [] + | _ -> raise Not_found ] +; + +value unentry = + fun + [ <:expr< (Grammar.Entry.obj ($e$ : Grammar.Entry.e '$_$), $pos$, $ll$) >> -> + (e, unposition pos, unlevel_list ll) + | _ -> raise Not_found ] +; + +value rec unentry_list = + fun + [ <:expr< [$e$ :: $el$] >> -> [unentry e :: unentry_list el] + | <:expr< [] >> -> [] + | _ -> raise Not_found ] +; + +value unextend_body e = + let ((_, globals), e) = + match e with + [ <:expr< let $list:pel$ in $e1$ >> -> + try (get_globals pel, e1) with + [ Not_found -> (("", []), e) ] + | _ -> (("", []), e) ] + in + let e = + match e with + [ <:expr< + let grammar_entry_create s = + Grammar.Entry.create (Grammar.of_entry $_$) s + in + $e$ >> -> + let e = + match e with + [ <:expr< let $list:pel$ in $e1$ >> -> + try let _ = get_locals pel in e1 with + [ Not_found -> e ] + | _ -> e ] + in + e + | _ -> e ] + in + let el = unentry_list e in + (globals, el) +; + +value ungextend_body e = + let e = + match e with + [ <:expr< + let grammar_entry_create = Gram.Entry.create in + let $list:ll$ in $e$ + >> -> + let _ = get_locals ll in e + | _ -> e ] + in + match e with + [ <:expr< do { $list:el$ } >> -> + List.map + (fun + [ <:expr< $uid:_$.extend ($e$ : $uid:_$.Entry.e '$_$) $pos$ $ll$ >> -> + (e, unposition pos, unlevel_list ll) + | _ -> raise Not_found ]) + el + | _ -> raise Not_found ] +; + +(* Printing *) + +value ident s k = HVbox [: `S LR s; k :]; +value string s k = HVbox [: `S LR ("\"" ^ s ^ "\""); k :]; + +value position = + fun + [ None -> [: :] + | Some Gramext.First -> [: `S LR "FIRST" :] + | Some Gramext.Last -> [: `S LR "LAST" :] + | Some (Gramext.Before s) -> [: `S LR "BEFORE"; `string s [: :] :] + | Some (Gramext.After s) -> [: `S LR "AFTER"; `string s [: :] :] + | Some (Gramext.Level s) -> [: `S LR "LEVEL"; `string s [: :] :] ] +; + +value action expr a dg k = + expr a dg k +; + +value token (con, prm) k = + if con = "" then string prm k + else if prm = "" then HVbox [: `S LR con; k :] + else HVbox [: `S LR con; `string prm k :] +; + +value simplify_rules rl = + try + List.map + (fun + [ ([(Some <:patt< $lid:x$ >>, s)], Some <:expr< $lid:y$ >>) -> + if x = y then ([(None, s)], None) else raise Exit + | ([], _) as r -> r + | _ -> raise Exit ]) + rl + with + [ Exit -> rl ] +; + +value rec symbol s k = + match s with + [ Snterm e -> expr e "" k + | Snterml e s -> HVbox [: `expr e "" [: :]; `S LR "LEVEL"; `string s k :] + | Slist0 s -> HVbox [: `S LR "LIST0"; `symbol s k :] + | Slist0sep s sep -> + HVbox + [: `S LR "LIST0"; `symbol s [: :]; `S LR "SEP"; + `symbol sep k :] + | Slist1 s -> HVbox [: `S LR "LIST1"; `symbol s k :] + | Slist1sep s sep -> + HVbox + [: `S LR "LIST1"; `symbol s [: :]; `S LR "SEP"; + `symbol sep k :] + | Sopt s -> HVbox [: `S LR "OPT"; `symbol s k :] + | Sself -> HVbox [: `S LR "SELF"; k :] + | Snext -> HVbox [: `S LR "NEXT"; k :] + | Stoken tok -> token tok k + | Srules + [([(Some <:patt< a >>, Snterm <:expr< a_list >>)], Some <:expr< a >>); + ([(Some <:patt< a >>, + ((Slist0 _ | Slist1 _ | Slist0sep _ _ | Slist1sep _ _) as s))], + Some <:expr< Qast.List a >>)] + when not no_slist.val + -> + match s with + [ Slist0 s -> HVbox [: `S LR "SLIST0"; `simple_symbol s k :] + | Slist1 s -> HVbox [: `S LR "SLIST1"; `simple_symbol s k :] + | Slist0sep s sep -> + HVbox + [: `S LR "SLIST0"; `simple_symbol s [: :]; `S LR "SEP"; + `symbol sep k :] + | Slist1sep s sep -> + HVbox + [: `S LR "SLIST1"; `simple_symbol s [: :]; `S LR "SEP"; + `simple_symbol sep k :] + | _ -> assert False ] + | Srules + [([(Some <:patt< a >>, Snterm <:expr< a_opt >>)], Some <:expr< a >>); + ([(Some <:patt< a >>, Sopt s)], Some <:expr< Qast.Option a >>)] + when not no_slist.val + -> + let s = + match s with + [ Srules + [([(Some <:patt< x >>, Stoken ("", str))], + Some <:expr< Qast.Str x >>)] -> + Stoken ("", str) + | s -> s ] + in + HVbox [: `S LR "SOPT"; `simple_symbol s k :] + | Srules rl -> + let rl = simplify_rules rl in + HVbox [: `HVbox [: :]; rule_list rl k :] ] +and simple_symbol s k = + match s with + [ Snterml _ _ -> HVbox [: `S LO "("; `symbol s [: `S RO ")"; k :] :] + | s -> symbol s k ] +and psymbol (p, s) k = + match p with + [ None -> symbol s k + | Some p -> HVbox [: `patt p "" [: `S LR "=" :]; `symbol s k :] ] +and psymbol_list sl k = + listws psymbol (S RO ";") sl k +and rule b (sl, a) dg k = + match a with + [ None -> HVbox [: b; `HOVbox [: psymbol_list sl k :] :] + | Some a -> + HVbox + [: b; + `HOVbox + [: `HOVbox + [: `HVbox [: :]; + psymbol_list sl [: `S LR "->" :] :]; + `action expr a dg k :] :] ] +and rule_list ll k = + listwbws rule [: `S LR "[" :] (S LR "|") ll "" + [: `S LR "]"; k :] +; + +value label = + fun + [ Some s -> [: `S LR ("\"" ^ s ^ "\"") :] + | None -> [: :] ] +; + +value intloc loc = ((Loc.start_off loc), (Loc.stop_off loc)); + +value intloc2 (bp, ep) = (bp.Lexing.pos_cnum, ep.Lexing.pos_cnum); + + +value assoc = + fun + [ Some Gramext.NonA -> [: `S LR "NONA" :] + | Some Gramext.LeftA -> [: `S LR "LEFTA" :] + | Some Gramext.RightA -> [: `S LR "RIGHTA" :] + | None -> [: :] ] +; + +value level b (lab, ass, rl) _ k = + let s = + if rl = [] then [: `S LR "[ ]"; k :] + else [: `Vbox [: `HVbox [: :]; rule_list rl k :] :] + in + match (lab, ass) with + [ (None, None) -> HVbox [: b; s :] + | _ -> + Vbox + [: `HVbox [: b; label lab; assoc ass :]; + `HVbox [: `HVbox [: :]; s :] :] ] +; + +value level_list ll k = + Vbox + [: `HVbox [: :]; + listwbws level [: `S LR "[" :] (S LR "|") ll "" + [: `S LR "]"; k :] :] +; + +value entry (e, pos, ll) k = + BEbox + [: `LocInfo (intloc(MLast.loc_of_expr e)) + (HVbox [: `expr e "" [: `S RO ":" :]; position pos :]); + `level_list ll [: :]; + `HVbox [: `S RO ";"; k :] :] +; + +value entry_list el k = + Vbox [: `HVbox [: :]; list entry el k :] +; + +value extend_body (globals, e) k = + let s = entry_list e k in + match globals with + [ [] -> s + | sl -> + HVbox + [: `HVbox [: :]; + `HOVbox + [: `S LR "GLOBAL"; `S RO ":"; + list (fun e k -> HVbox [: `expr e "" k :]) sl + [: `S RO ";" :] :]; + `s :] ] +; + +value extend e _ k = + match e with + [ <:expr< Grammar.extend $e$ >> -> + try + let ex = unextend_body e in + BEbox + [: `S LR "EXTEND"; `extend_body ex [: :]; + `HVbox [: `S LR "END"; k :] :] + with + [ Not_found -> + HVbox + [: `S LR "Grammar.extend"; + `HOVbox + [: `S LO "("; + `expr e "" [: `HVbox [: `S RO ")"; k :] :] :] :] ] + | _ -> expr e "" k ] +; + +value get_gextend = + fun + [ <:expr< let $list:gl$ in $e$ >> -> + try + let (gmod, gl) = get_globals gl in + let el = ungextend_body e in + Some (gmod, gl, el) + with + [ Not_found -> None ] + | _ -> None ] +; + +value gextend e _ k = + match get_gextend e with + [ Some (gmod, gl, el) -> + BEbox + [: `HVbox [: `S LR "GEXTEND"; `S LR gmod :]; + `extend_body (gl, el) [: :]; + `HVbox [: `S LR "END"; k :] :] + | None -> expr e "" k ] +; + +value is_gextend e = get_gextend e <> None; + +(* Printer extensions *) + +let lev = + try find_pr_level "expr1" pr_expr.pr_levels with + [ Failure _ -> find_pr_level "top" pr_expr.pr_levels ] +in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< let $list:_$ in $_$ >> as e when is_gextend e -> + fun _ next _ k -> [: `next e "" k :] ]; + +let lev = find_pr_level "apply" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Grammar.extend $_$ >> as e -> + fun _ next _ k -> [: `next e "" k :] ]; + +let lev = find_pr_level "simple" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Grammar.extend $_$ >> as e -> + fun _ _ _ k -> [: `extend e "" k :] + | <:expr< let $list:_$ in $_$ >> as e when is_gextend e -> + fun _ _ _ k -> [: `gextend e "" k :] ]; + +Pcaml.add_option "-no_slist" (Arg.Set no_slist) + "Don't reconstruct SLIST and SOPT"; diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/pr_extfun.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_extfun.ml new file mode 100644 index 0000000000..4479bb407c --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_extfun.ml @@ -0,0 +1,92 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) + + +open Pcaml; +open Spretty; + +value _loc = Loc.mk "FIXME pr_extfun.ml"; + +value expr e dg k = pr_expr.pr_fun "top" e dg k; +value patt e dg k = pr_patt.pr_fun "top" e dg k; + +value rec un_extfun rpel = + fun + [ <:expr< [ ($_$, $_$, fun [ $list:pel$ ]) :: $el$ ] >> -> + let (p, wo, e) = + match pel with + [ [(p, wo, <:expr< Some $e$ >>); + (<:patt< _ >>, None, <:expr< None >>)] -> + (p, wo, e) + | [(p, wo, <:expr< Some $e$ >>)] -> (p, wo, e) + | _ -> raise Not_found ] + in + let rpel = + match rpel with + [ [(p1, wo1, e1) :: pel] -> + if wo1 = wo && e1 = e then + let p = + match (p1, p) with + [ (<:patt< ($x1$ as $x2$) >>, <:patt< ($y1$ as $y2$) >>) -> + if x2 = y2 then <:patt< ($x1$ | $y1$ as $x2$) >> + else <:patt< $p1$ | $p$ >> + | _ -> <:patt< $p1$ | $p$ >> ] + in + [(p, wo, e) :: pel] + else [(p, wo, e) :: rpel] + | [] -> [(p, wo, e)] ] + in + un_extfun rpel el + | <:expr< [] >> -> List.rev rpel + | _ -> raise Not_found ] +; + +value rec listwbws elem b sep el k = + match el with + [ [] -> [: b; k :] + | [x] -> [: `elem b x k :] + | [x :: l] -> [: `elem b x [: :]; listwbws elem [: `sep :] sep l k :] ] +; + +value rec match_assoc_list pwel k = + match pwel with + [ [pwe] -> match_assoc [: `S LR "[" :] pwe [: `S LR "]"; k :] + | pel -> + Vbox + [: `HVbox [: :]; + listwbws match_assoc [: `S LR "[" :] (S LR "|") pel + [: `S LR "]"; k :] :] ] +and match_assoc b (p, w, e) k = + let s = + let (p, k) = + match p with + [ <:patt< ($p$ as $p2$) >> -> (p, [: `S LR "as"; `patt p2 "" [: :] :]) + | _ -> (p, [: :]) ] + in + match w with + [ Some e1 -> + [: `HVbox + [: `HVbox [: :]; `patt p "" k; + `HVbox [: `S LR "when"; `expr e1 "" [: `S LR "->" :] :] :] :] + | _ -> [: `patt p "" [: k; `S LR "->" :] :] ] + in + HVbox [: b; `HVbox [: `HVbox s; `expr e "" k :] :] +; + +let lev = find_pr_level "top" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Extfun.extend $e$ $list$ >> as ge -> + fun _ next dg k -> + try + let pel = un_extfun [] list in + [: `HVbox [: :]; + `BEbox [: `S LR "extfun"; `expr e "" [: :]; `S LR "with" :]; + `match_assoc_list pel k :] + with + [ Not_found -> [: `next ge dg k :] ] ]; + +let lev = find_pr_level "apply" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Extfun.extend $_$ $_$ >> as ge -> + fun _ next dg k -> [: `next ge dg k :] ]; diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/pr_null.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_null.ml new file mode 100644 index 0000000000..22f3cb74fd --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_null.ml @@ -0,0 +1,16 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + + + +Pcaml.print_interf.val := fun _ -> (); +Pcaml.print_implem.val := fun _ -> (); diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/pr_op.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_op.ml new file mode 100644 index 0000000000..9b2aebcfa4 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_op.ml @@ -0,0 +1,210 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + + + +open Pcaml; +open Spretty; + +value expr e dg k = pr_expr.pr_fun "top" e dg k; +value patt e dg k = pr_patt.pr_fun "top" e dg k; + +value spatt p dg k = + match p with + [ <:patt< $lid:s$ >> -> + if String.length s >= 2 && s.[1] == ''' then + HVbox [: `S LR (" " ^ s); k :] + else patt p dg k + | _ -> patt p dg k ] +; + +(* Streams *) + +value stream e _ k = + let rec get = + fun + [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] + | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] + | <:expr< Stream.ising $x$ >> -> [(True, x)] + | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] + | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] + | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] + | <:expr< Stream.sempty >> -> [] + | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] + | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] + | e -> [(False, e)] ] + in + let elem e dg k = + match e with + [ (True, e) -> [: `HOVbox [: `S LO "'"; `expr e dg k :] :] + | (False, e) -> [: `expr e dg k :] ] + in + let rec glop e k = + match e with + [ [] -> k + | [e] -> [: elem e "" k :] + | [e :: el] -> [: elem e ";" [: `S RO ";" :]; glop el k :] ] + in + HOVbox [: `S LR "[<"; glop (get e) [: `S LR ">]"; k :] :] +; + +(* Parsers *) + +value parser_cases b spel dg k = + let rec parser_cases b spel dg k = + match spel with + [ [] -> [: `HVbox [: b; k :] :] + | [(sp, epo, e)] -> [: `parser_case b sp epo e dg k :] + | [(sp, epo, e) :: spel] -> + [: `parser_case b sp epo e "|" [: :]; + parser_cases [: `S LR "|" :] spel dg k :] ] + and parser_case b sp epo e dg k = + let epo = + match epo with + [ Some p -> [: `patt p "" [: `S LR "->" :] :] + | _ -> [: `S LR "->" :] ] + in + HVbox + [: b; + `HOVbox + [: `HOVbox + [: `S LR "[<"; + stream_patt [: :] sp [: `S LR ">]"; epo :] :]; + `expr e dg k :] :] + and stream_patt b sp k = + match sp with + [ [] -> [: `HVbox [: b; k :] :] + | [(spc, None)] -> [: `stream_patt_comp b spc "" k :] + | [(spc, Some e)] -> + [: `HVbox + [: `stream_patt_comp b spc "" [: :]; + `HVbox [: `S LR "??"; `expr e "" k :] :] :] + | [(spc, None) :: spcl] -> + [: `stream_patt_comp b spc ";" [: `S RO ";" :]; + stream_patt [: :] spcl k :] + | [(spc, Some e) :: spcl] -> + [: `HVbox + [: `stream_patt_comp b spc "" [: :]; + `HVbox [: `S LR "??"; `expr e ";" [: `S RO ";" :] :] :]; + stream_patt [: :] spcl k :] ] + and stream_patt_comp b spc dg k = + match spc with + [ SPCterm (p, w) -> + HVbox [: b; `S LO "'"; `spatt p "" (when_opt w k) :] + | SPCnterm p e -> + HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e dg k :] :] + | SPCsterm p -> HVbox [: b; `patt p "" k :] ] + and when_opt wo k = + match wo with + [ Some e -> [: `S LR "when"; `expr e "" k :] + | _ -> k ] + in + parser_cases b spel dg k +; + +value parser_body e dg k = + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + match Parserify.parser_of_expr e with + [ [] -> + let spe = ([], None, <:expr< raise Stream.Failure >>) in + HVbox + [: `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: :] [spe] dg k :] + | spel -> + BEVbox + [: `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: :] spel dg k :] ] +; + +value pmatch e dg k = + let (me, e) = + match e with + [ <:expr< let (__strm : Stream.t _) = $me$ in $e$ >> -> (me, e) + | _ -> failwith "Pr_op.pmatch" ] + in + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + let spel = Parser_of_expr.parser_of_expr e in + Vbox + [: `HVbox [: :]; + `HVbox + [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + `BEbox [: `HVbox [: :]; parser_cases [: :] spel dg k :] :] +; + +(* Printer extensions *) + +pr_expr_fun_args.val := + extfun pr_expr_fun_args.val with + [ <:expr< fun __strm -> $_$ >> as ge -> ([], ge) + | <:expr< fun [(__strm : $_$) -> $_$] >> as ge -> ([], ge) ]; + +let lev = find_pr_level "expr1" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< let (__strm : Stream.t _) = $_$ in $_$ >> as e -> + fun curr next dg k -> + if not (List.mem dg ["|"; ";"]) then [: `pmatch e dg k :] + else [: `S LO "("; `pmatch e "" [: `S RO ")"; k :] :] + | <:expr< fun __strm -> $x$ >> -> + fun curr next dg k -> + if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] + else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] + | <:expr< fun [ (__strm : $_$) -> $x$ ] >> -> + fun curr next dg k -> + if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] + else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] ]; + +let lev = find_pr_level "apply" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | + <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | + <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | + <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | + <:expr< Stream.slazy $_$ >> as e -> + fun curr next dg k -> [: `next e "" k :] ]; + +let lev = find_pr_level "dot" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.sempty >> as e -> + fun curr next dg k -> [: `next e "" k :] ]; + +let lev = find_pr_level "simple" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | + <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | + <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | + <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | + <:expr< Stream.slazy $_$ >> as e -> + fun curr next dg k -> + [: `stream e "" k :] ]; diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/pr_op_main.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_op_main.ml new file mode 100644 index 0000000000..3ea53ba40f --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_op_main.ml @@ -0,0 +1,214 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + + + +open Pcaml; +open Spretty; + +value _loc = Loc.mk "FIXME pr_op_main.ml"; + +value expr e dg k = pr_expr.pr_fun "top" e dg k; +value patt e dg k = pr_patt.pr_fun "top" e dg k; + +value spatt p dg k = + match p with + [ <:patt< $lid:s$ >> -> + if String.length s >= 2 && s.[1] == ''' then + HVbox [: `S LR (" " ^ s); k :] + else patt p dg k + | _ -> patt p dg k ] +; + +(* Streams *) + +value stream e _ k = + let rec get = + fun + [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] + | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] + | <:expr< Stream.ising $x$ >> -> [(True, x)] + | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] + | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] + | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] + | <:expr< Stream.sempty >> -> [] + | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] + | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] + | e -> [(False, e)] ] + in + let elem e dg k = + match e with + [ (True, e) -> [: `HOVbox [: `S LO "'"; `expr e dg k :] :] + | (False, e) -> [: `expr e dg k :] ] + in + let rec glop e k = + match e with + [ [] -> k + | [e] -> [: elem e "" k :] + | [e :: el] -> [: elem e ";" [: `S RO ";" :]; glop el k :] ] + in + HOVbox [: `S LR "[<"; glop (get e) [: `S LR ">]"; k :] :] +; + +(* Parsers *) + +open Parserify; + +value parser_cases b spel dg k = + let rec parser_cases b spel dg k = + match spel with + [ [] -> [: `HVbox [: b; k :] :] + | [(sp, epo, e)] -> [: `parser_case b sp epo e dg k :] + | [(sp, epo, e) :: spel] -> + [: `parser_case b sp epo e "|" [: :]; + parser_cases [: `S LR "|" :] spel dg k :] ] + and parser_case b sp epo e dg k = + let epo = + match epo with + [ Some p -> [: `patt p "" [: `S LR "->" :] :] + | _ -> [: `S LR "->" :] ] + in + HVbox + [: b; + `HOVbox + [: `HOVbox + [: `S LR "[<"; + stream_patt [: :] sp [: `S LR ">]"; epo :] :]; + `expr e dg k :] :] + and stream_patt b sp k = + match sp with + [ [] -> [: `HVbox [: b; k :] :] + | [(spc, None)] -> [: `stream_patt_comp b spc "" k :] + | [(spc, Some e)] -> + [: `HVbox + [: `stream_patt_comp b spc "" [: :]; + `HVbox [: `S LR "??"; `expr e "" k :] :] :] + | [(spc, None) :: spcl] -> + [: `stream_patt_comp b spc ";" [: `S RO ";" :]; + stream_patt [: :] spcl k :] + | [(spc, Some e) :: spcl] -> + [: `HVbox + [: `stream_patt_comp b spc "" [: :]; + `HVbox [: `S LR "??"; `expr e ";" [: `S RO ";" :] :] :]; + stream_patt [: :] spcl k :] ] + and stream_patt_comp b spc dg k = + match spc with + [ SPCterm (p, w) -> + HVbox [: b; `S LO "'"; `spatt p "" (when_opt w k) :] + | SPCnterm p e -> + HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e dg k :] :] + | SPCsterm p -> HVbox [: b; `patt p "" k :] ] + and when_opt wo k = + match wo with + [ Some e -> [: `S LR "when"; `expr e "" k :] + | _ -> k ] + in + parser_cases b spel dg k +; + +value parser_body e dg k = + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + match parser_of_expr e with + [ [] -> + let spe = ([], None, <:expr< raise Stream.Failure >>) in + HVbox + [: `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: :] [spe] dg k :] + | spel -> + BEVbox + [: `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: :] spel dg k :] ] +; + +value pmatch e dg k = + let (me, e) = + match e with + [ <:expr< let (__strm : Stream.t _) = $me$ in $e$ >> -> (me, e) + | _ -> failwith "Pr_op.pmatch" ] + in + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + let spel = parser_of_expr e in + Vbox + [: `HVbox [: :]; + `HVbox + [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + `BEbox [: `HVbox [: :]; parser_cases [: :] spel dg k :] :] +; + +(* Printer extensions *) + +pr_expr_fun_args.val := + extfun pr_expr_fun_args.val with + [ <:expr< fun __strm -> $_$ >> as ge -> ([], ge) + | <:expr< fun [(__strm : $_$) -> $_$] >> as ge -> ([], ge) ]; + +let lev = find_pr_level "expr1" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< let (__strm : Stream.t _) = $_$ in $_$ >> as e -> + fun _ _ dg k -> + if not (List.mem dg ["|"; ";"]) then [: `pmatch e dg k :] + else [: `S LO "("; `pmatch e "" [: `S RO ")"; k :] :] + | <:expr< fun __strm -> $x$ >> -> + fun _ _ dg k -> + if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] + else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] + | <:expr< fun [ (__strm : $_$) -> $x$ ] >> -> + fun _ _ dg k -> + if not (List.mem dg ["|"; ";"]) then [: `parser_body x dg k :] + else [: `S LO "("; `parser_body x "" [: `S RO ")"; k :] :] ]; + +let lev = find_pr_level "apply" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | + <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | + <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | + <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | + <:expr< Stream.slazy $_$ >> as e -> + fun _ next _ k -> [: `next e "" k :] ]; + +let lev = find_pr_level "dot" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.sempty >> as e -> + fun _ next _ k -> [: `next e "" k :] ]; + +let lev = find_pr_level "simple" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | + <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | + <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | + <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | + <:expr< Stream.slazy $_$ >> as e -> + fun _ _ _ k -> + [: `stream e "" k :] ]; diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/pr_rp.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_rp.ml new file mode 100644 index 0000000000..0604b463f5 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_rp.ml @@ -0,0 +1,207 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + + + +open Pcaml; +open Spretty; + +value _loc = (Token.nowhere, Token.nowhere); + +value expr e dg k = pr_expr.pr_fun "top" e dg k; +value patt e dg k = pr_patt.pr_fun "top" e dg k; + +(* Streams *) + +value stream e dg k = + let rec get = + fun + [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] + | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] + | <:expr< Stream.ising $x$ >> -> [(True, x)] + | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] + | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] + | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] + | <:expr< Stream.sempty >> -> [] + | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] + | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] + | e -> [(False, e)] ] + in + let elem e k = + match e with + [ (True, e) -> [: `HOVbox [: `S LO "`"; `expr e "" k :] :] + | (False, e) -> [: `expr e "" k :] ] + in + let rec glop e k = + match e with + [ [] -> k + | [e] -> [: elem e k :] + | [e :: el] -> [: elem e [: `S RO ";" :]; glop el k :] ] + in + HOVbox [: `S LR "[:"; glop (get e) [: `S LR ":]"; k :] :] +; + +(* Parsers *) + +value parser_cases b spel k = + let rec parser_cases b spel k = + match spel with + [ [] -> [: `HVbox [: b; k :] :] + | [(sp, epo, e)] -> [: `parser_case b sp epo e k :] + | [(sp, epo, e) :: spel] -> + [: `parser_case b sp epo e [: :]; + parser_cases [: `S LR "|" :] spel k :] ] + and parser_case b sp epo e k = + let epo = + match epo with + [ Some p -> [: `patt p "" [: `S LR "->" :] :] + | _ -> [: `S LR "->" :] ] + in + HVbox + [: b; + `HOVbox + [: `HOVbox + [: `S LR "[:"; + stream_patt [: :] sp [: `S LR ":]"; epo :] :]; + `expr e "" k :] :] + and stream_patt b sp k = + match sp with + [ [] -> [: `HVbox [: b; k :] :] + | [(spc, None)] -> [: `stream_patt_comp b spc k :] + | [(spc, Some e)] -> + [: `HVbox + [: `stream_patt_comp b spc [: :]; + `HVbox [: `S LR "?"; `expr e "" k :] :] :] + | [(spc, None) :: spcl] -> + [: `stream_patt_comp b spc [: `S RO ";" :]; + stream_patt [: :] spcl k :] + | [(spc, Some e) :: spcl] -> + [: `HVbox + [: `stream_patt_comp b spc [: :]; + `HVbox [: `S LR "?"; `expr e "" [: `S RO ";" :] :] :]; + stream_patt [: :] spcl k :] ] + and stream_patt_comp b spc k = + match spc with + [ SPCterm (p, w) -> + HVbox [: b; `S LO "`"; `patt p "" [: :]; `HVbox [: when_opt w k :] :] + | SPCnterm p e -> + HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e "" k :] :] + | SPCsterm p -> HVbox [: b; `patt p "" k :] ] + and when_opt wo k = + match wo with + [ Some e -> [: `S LR "when"; `expr e "" k :] + | _ -> k ] + in + parser_cases b spel k +; + +value parser_body e dg k = + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + match Parserify.parser_of_expr e with + [ [] -> + HVbox + [: `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + `HVbox [: `S LR "[]"; k :] :] + | [spe] -> + HVbox + [: `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: :] [spe] k :] + | spel -> + Vbox + [: `HVbox [: :]; + `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ] +; + +value pmatch e dg k = + let (me, e) = + match e with + [ <:expr< let (__strm : Stream.t _) = $me$ in $e$ >> -> (me, e) + | <:expr< match $_$ __strm with [ $list:_$ ] >> -> (<:expr< __strm >>, e) + | _ -> failwith "Pr_rp.pmatch" ] + in + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + let spel = Parserify.parser_of_expr e in + Vbox + [: `HVbox [: :]; + `HVbox + [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] +; + +(* Printer extensions *) + +pr_expr_fun_args.val := + extfun pr_expr_fun_args.val with + [ <:expr< fun __strm -> $_$ >> as ge -> ([], ge) + | <:expr< fun [(__strm : $_$) -> $_$] >> as ge -> ([], ge) ]; + +let lev = find_pr_level "top" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< let (__strm : Stream.t _) = $_$ in $_$ >> as e -> + fun curr next _ k -> [: `pmatch e "" k :] + | <:expr< match $_$ __strm with [ $list:_$ ] >> as e -> + fun curr next _ k -> [: `pmatch e "" k :] + | <:expr< fun __strm -> $x$ >> -> + fun curr next _ k -> [: `parser_body x "" k :] + | <:expr< fun (__strm : $_$) -> $x$ >> -> + fun curr next _ k -> [: `parser_body x "" k :] ]; + +let lev = find_pr_level "apply" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | + <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | + <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | + <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | + <:expr< Stream.slazy $_$ >> as e -> + fun curr next _ k -> [: `next e "" k :] ]; + +let lev = find_pr_level "dot" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.sempty >> as e -> + fun curr next _ k -> [: `next e "" k :] ]; + +let lev = find_pr_level "simple" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | + <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | + <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | + <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | + <:expr< Stream.slazy $_$ >> as e -> + fun curr next _ k -> [: `stream e "" k :] ]; diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/pr_rp_main.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_rp_main.ml new file mode 100644 index 0000000000..534d407323 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/pr_rp_main.ml @@ -0,0 +1,206 @@ +(* camlp4r q_MLast.cmo ./pa_extfun.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1998 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + + + +open Pcaml; +open Spretty; + +value _loc = Loc.mk "FIXME pr_rp_main.ml"; + +value expr e dg k = pr_expr.pr_fun "top" e dg k; +value patt e dg k = pr_patt.pr_fun "top" e dg k; + +(* Streams *) + +value stream e _ k = + let rec get = + fun + [ <:expr< Stream.iapp $x$ $y$ >> -> [(False, x) :: get y] + | <:expr< Stream.icons $x$ $y$ >> -> [(True, x) :: get y] + | <:expr< Stream.ising $x$ >> -> [(True, x)] + | <:expr< Stream.lapp (fun _ -> $x$) $y$ >> -> [(False, x) :: get y] + | <:expr< Stream.lcons (fun _ -> $x$) $y$ >> -> [(True, x) :: get y] + | <:expr< Stream.lsing (fun _ -> $x$) >> -> [(True, x)] + | <:expr< Stream.sempty >> -> [] + | <:expr< Stream.slazy (fun _ -> $x$) >> -> [(False, x)] + | <:expr< Stream.slazy $x$ >> -> [(False, <:expr< $x$ () >>)] + | e -> [(False, e)] ] + in + let elem e k = + match e with + [ (True, e) -> [: `HOVbox [: `S LO "`"; `expr e "" k :] :] + | (False, e) -> [: `expr e "" k :] ] + in + let rec glop e k = + match e with + [ [] -> k + | [e] -> [: elem e k :] + | [e :: el] -> [: elem e [: `S RO ";" :]; glop el k :] ] + in + HOVbox [: `S LR "[:"; glop (get e) [: `S LR ":]"; k :] :] +; + +(* Parsers *) + +open Parserify; + +value parser_cases b spel k = + let rec parser_cases b spel k = + match spel with + [ [] -> [: `HVbox [: b; k :] :] + | [(sp, epo, e)] -> [: `parser_case b sp epo e k :] + | [(sp, epo, e) :: spel] -> + [: `parser_case b sp epo e [: :]; + parser_cases [: `S LR "|" :] spel k :] ] + and parser_case b sp epo e k = + let epo = + match epo with + [ Some p -> [: `patt p "" [: `S LR "->" :] :] + | _ -> [: `S LR "->" :] ] + in + HVbox + [: b; + `HOVbox + [: `HOVbox + [: `S LR "[:"; + stream_patt [: :] sp [: `S LR ":]"; epo :] :]; + `expr e "" k :] :] + and stream_patt b sp k = + match sp with + [ [] -> [: `HVbox [: b; k :] :] + | [(spc, None)] -> [: `stream_patt_comp b spc k :] + | [(spc, Some e)] -> + [: `HVbox + [: `stream_patt_comp b spc [: :]; + `HVbox [: `S LR "?"; `expr e "" k :] :] :] + | [(spc, None) :: spcl] -> + [: `stream_patt_comp b spc [: `S RO ";" :]; + stream_patt [: :] spcl k :] + | [(spc, Some e) :: spcl] -> + [: `HVbox + [: `stream_patt_comp b spc [: :]; + `HVbox [: `S LR "?"; `expr e "" [: `S RO ";" :] :] :]; + stream_patt [: :] spcl k :] ] + and stream_patt_comp b spc k = + match spc with + [ SPCterm (p, w) -> + HVbox [: b; `S LO "`"; `patt p "" [: :]; `HVbox [: when_opt w k :] :] + | SPCnterm p e -> + HVbox [: b; `HVbox [: `patt p "" [: `S LR "=" :]; `expr e "" k :] :] + | SPCsterm p -> HVbox [: b; `patt p "" k :] ] + and when_opt wo k = + match wo with + [ Some e -> [: `S LR "when"; `expr e "" k :] + | _ -> k ] + in + parser_cases b spel k +; + +value parser_body e _ k = + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + match parser_of_expr e with + [ [] -> + HVbox + [: `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + `HVbox [: `S LR "[]"; k :] :] + | [spe] -> + HVbox + [: `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: :] [spe] k :] + | spel -> + Vbox + [: `HVbox [: :]; + `HVbox + [: `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] ] +; + +value pmatch e _ k = + let (me, e) = + match e with + [ <:expr< let (__strm : Stream.t _) = $me$ in $e$ >> -> (me, e) + | _ -> failwith "Pr_rp.pmatch" ] + in + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + let spel = parser_of_expr e in + Vbox + [: `HVbox [: :]; + `HVbox + [: `S LR "match"; `expr me "" [: `S LR "with" :]; `S LR "parser"; + match bp with + [ Some p -> [: `patt p "" [: :] :] + | _ -> [: :] ] :]; + parser_cases [: `S LR "[" :] spel [: `S LR "]"; k :] :] +; + +(* Printer extensions *) + +pr_expr_fun_args.val := + extfun pr_expr_fun_args.val with + [ <:expr< fun __strm -> $_$ >> as ge -> ([], ge) + | <:expr< fun [(__strm : $_$) -> $_$] >> as ge -> ([], ge) ]; + +let lev = find_pr_level "top" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< let (__strm : Stream.t _) = $_$ in $_$ >> as e -> + fun _ _ _ k -> [: `pmatch e "" k :] + | <:expr< fun __strm -> $x$ >> -> + fun _ _ _ k -> [: `parser_body x "" k :] + | <:expr< fun (__strm : $_$) -> $x$ >> -> + fun _ _ _ k -> [: `parser_body x "" k :] ]; + +let lev = find_pr_level "apply" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | + <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | + <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | + <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | + <:expr< Stream.slazy $_$ >> as e -> + fun _ next _ k -> [: `next e "" k :] ]; + +let lev = find_pr_level "dot" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.sempty >> as e -> + fun _ next _ k -> [: `next e "" k :] ]; + +let lev = find_pr_level "simple" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< Stream.iapp $_$ $_$ >> | <:expr< Stream.icons $_$ $_$ >> | + <:expr< Stream.ising $_$ >> | <:expr< Stream.lapp (fun _ -> $_$) $_$ >> | + <:expr< Stream.lcons (fun _ -> $_$) $_$ >> | + <:expr< Stream.lsing (fun _ -> $_$) >> | <:expr< Stream.sempty >> | + <:expr< Stream.slazy $_$ >> as e -> + fun _ _ _ k -> [: `stream e "" k :] ]; diff --git a/ocaml-binary-annot/camlp4/unmaintained/etc/q_phony.ml b/ocaml-binary-annot/camlp4/unmaintained/etc/q_phony.ml new file mode 100644 index 0000000000..e490808152 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/etc/q_phony.ml @@ -0,0 +1,38 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + + + +open Pcaml; + +value t = ref ""; + +Quotation.add "" + (Quotation.ExAst + (fun c s -> + let _loc = c.Quotation.loc in + let t = + if t.val = "" then "<<" ^ s ^ ">>" + else "<:" ^ t.val ^ "<" ^ s ^ ">>" + in + <:expr< $uid:t$ >>, + fun c s -> + let _loc = c.Quotation.loc in + let t = + if t.val = "" then "<<" ^ s ^ ">>" + else "<:" ^ t.val ^ "<" ^ s ^ ">>" + in + <:patt< $uid:t$ >>)) +; + +Quotation.default.val := ""; +Quotation.translate.val := fun s -> do { t.val := s; "" }; diff --git a/ocaml-binary-annot/camlp4/unmaintained/extfold/README b/ocaml-binary-annot/camlp4/unmaintained/extfold/README new file mode 100644 index 0000000000..2a09ff0988 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/extfold/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + Nicolas Pouillard diff --git a/ocaml-binary-annot/camlp4/unmaintained/extfold/pa_extfold.ml b/ocaml-binary-annot/camlp4/unmaintained/extfold/pa_extfold.ml new file mode 100644 index 0000000000..aa8e922b14 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/extfold/pa_extfold.ml @@ -0,0 +1,42 @@ +(* camlp4r pa_extend.cmo q_MLast.cmo *) + + +open Pcaml; +open Pa_extend; + +value sfold _loc n foldfun f e s = + let styp = STquo _loc (new_type_var ()) in + let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in + let t = STapp _loc (STapp _loc (STtyp <:ctyp< Extfold.t _ >>) s.styp) styp in + {used = s.used; text = TXmeta _loc n [s.text] e t; styp = styp} +; + +value sfoldsep _loc n foldfun f e s sep = + let styp = STquo _loc (new_type_var ()) in + let e = <:expr< Extfold.$lid:foldfun$ $f$ $e$ >> in + let t = + STapp _loc (STapp _loc (STtyp <:ctyp< Extfold.tsep _ >>) s.styp) styp + in + {used = s.used @ sep.used; text = TXmeta _loc n [s.text; sep.text] e t; + styp = styp} +; + +EXTEND + GLOBAL: symbol; + symbol: LEVEL "top" + [ [ UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF -> + sfold _loc "FOLD0" "sfold0" f e s + | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF -> + sfold _loc "FOLD1" "sfold1" f e s + | UIDENT "FOLD0"; f = simple_expr; e = simple_expr; s = SELF; + UIDENT "SEP"; sep = symbol -> + sfoldsep _loc "FOLD0 SEP" "sfold0sep" f e s sep + | UIDENT "FOLD1"; f = simple_expr; e = simple_expr; s = SELF; + UIDENT "SEP"; sep = symbol -> + sfoldsep _loc "FOLD1 SEP" "sfold1sep" f e s sep ] ] + ; + simple_expr: + [ [ i = LIDENT -> <:expr< $lid:i$ >> + | "("; e = expr; ")" -> e ] ] + ; +END; diff --git a/ocaml-binary-annot/camlp4/unmaintained/format/.depend b/ocaml-binary-annot/camlp4/unmaintained/format/.depend new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/format/.depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/format/Makefile b/ocaml-binary-annot/camlp4/unmaintained/format/Makefile new file mode 100644 index 0000000000..c388720974 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/format/Makefile @@ -0,0 +1,61 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# Makefile for pa_format +# M.Mauny +# + +include ../../config/Makefile.cnf + +OCAMLTOP=../../.. +CAMLP4=../../camlp4/camlp4$(EXE) + +OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) +OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) + +P4INCLUDES= -nolib -I ../../lib -I ../../meta -I ../../etc +OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../lib -I ../../camlp4 +OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) + +SRC=pa_format.ml +OBJS=$(SRC:.ml=.cmo) +OBJSX=$(SRC:.ml=.cmx) + +all: $(OBJS) + +opt: $(OBJSX) + +depend: + cp .depend .depend.bak + > .depend + for file in $(SRC); do \ + $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ + sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ + done + +clean: + rm -f *.cm* *.$(O) *.bak .*.bak + + +.SUFFIXES: .cmx .cmo .cmi .ml .mli + +.mli.cmi: + $(OCAMLC) $(OCAMLCFLAGS) -c $< + + +.ml.cmo: + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +include .depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/format/README b/ocaml-binary-annot/camlp4/unmaintained/format/README new file mode 100644 index 0000000000..809d42f2a8 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/format/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + diff --git a/ocaml-binary-annot/camlp4/unmaintained/format/pa_format.ml b/ocaml-binary-annot/camlp4/unmaintained/format/pa_format.ml new file mode 100644 index 0000000000..640a75031c --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/format/pa_format.ml @@ -0,0 +1,52 @@ +(* pa_r.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file *) +(* ../../../LICENSE. *) +(* *) +(***********************************************************************) + + +open Pcaml; + +EXTEND + GLOBAL: expr; + expr: LEVEL "top" + [ [ n = box_type; d = SELF; "begin"; + el = LIST0 [ e = box_expr; ";" -> e ]; "end" -> + let el = [<:expr< Format.$lid:"open_" ^ n$ $d$ >> :: el] in + let el = el @ [<:expr< Format.close_box () >>] in + <:expr< do { $list:el$ } >> + | "hbox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" -> + let el = [<:expr< Format.open_hbox () >> :: el] in + let el = el @ [<:expr< Format.close_box () >>] in + <:expr< do { $list:el$ } >> + | "nobox"; "begin"; el = LIST0 [ e = box_expr; ";" -> e ]; "end" -> + match el with + [ [e] -> e + | _ -> <:expr< do { $list:el$ } >> ] ] ] + ; + box_type: + [ [ n = "hovbox" -> n + | n = "hvbox" -> n + | n = "vbox" -> n + | n = "box" -> n ] ] + ; + box_expr: + [ [ s = STRING -> <:expr< Format.print_string $str:s$ >> + | UIDENT "STRING"; e = expr -> <:expr< Format.print_string $e$ >> + | UIDENT "INT"; e = expr -> <:expr< Format.print_int $e$ >> + | "/-" -> <:expr< Format.print_space () >> + | "//" -> <:expr< Format.print_cut () >> + | "!/" -> <:expr< Format.force_newline () >> + | "?/" -> <:expr< Format.print_if_newline () >> + | e = expr -> e ] ] + ; +END; diff --git a/ocaml-binary-annot/camlp4/unmaintained/lefteval/.depend b/ocaml-binary-annot/camlp4/unmaintained/lefteval/.depend new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/lefteval/.depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/lefteval/Makefile b/ocaml-binary-annot/camlp4/unmaintained/lefteval/Makefile new file mode 100644 index 0000000000..7e5cdd02e6 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/lefteval/Makefile @@ -0,0 +1,61 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# Makefile for pa_lefteval +# M.Mauny +# + +include ../../config/Makefile.cnf + +OCAMLTOP=../../.. +CAMLP4=../../camlp4/camlp4$(EXE) + +OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) +OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) + +P4INCLUDES= -nolib -I ../../meta -I ../../etc +OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 +OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) + +SRC=pa_lefteval.ml +OBJS=$(SRC:.ml=.cmo) +OBJSX=$(SRC:.ml=.cmx) + +all: $(OBJS) + +opt: $(OBJSX) + +depend: + cp .depend .depend.bak + > .depend + for file in $(SRC); do \ + $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ + sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ + done + +clean: + rm -f *.cm* *.$(O) *.bak .*.bak + + +.SUFFIXES: .cmx .cmo .cmi .ml .mli + +.mli.cmi: + $(OCAMLC) $(OCAMLCFLAGS) -c $< + + +.ml.cmo: + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +include .depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/lefteval/README b/ocaml-binary-annot/camlp4/unmaintained/lefteval/README new file mode 100644 index 0000000000..809d42f2a8 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/lefteval/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + diff --git a/ocaml-binary-annot/camlp4/unmaintained/lefteval/pa_lefteval.ml b/ocaml-binary-annot/camlp4/unmaintained/lefteval/pa_lefteval.ml new file mode 100644 index 0000000000..56ad297941 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/lefteval/pa_lefteval.ml @@ -0,0 +1,241 @@ +(* pa_r.cmo q_MLast.cmo pr_dump.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file *) +(* ../../../LICENSE. *) +(* *) +(***********************************************************************) + + +value not_impl name x = + let desc = + if Obj.is_block (Obj.repr x) then + "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) + else "int_val = " ^ string_of_int (Obj.magic x) + in + failwith ("pa_lefteval: not impl: " ^ name ^ "; " ^ desc ^ ">") +; + +value rec expr_fa al = + fun + [ <:expr< $f$ $a$ >> -> expr_fa [a :: al] f + | f -> (f, al) ] +; + +(* generating let..in before functions calls which evaluates + several (more than one) of their arguments *) + +value no_side_effects_ht = + let ht = Hashtbl.create 73 in + do { + List.iter (fun s -> Hashtbl.add ht s True) + ["<"; "="; "@"; "^"; "+"; "-"; "ref"]; + ht + } +; + +value no_side_effects = + fun + [ <:expr< $uid:_$ >> -> True + | <:expr< $uid:_$ . $uid:_$ >> -> True + | <:expr< $lid:s$ >> -> + try Hashtbl.find no_side_effects_ht s with [ Not_found -> False ] + | _ -> False ] +; + +value rec may_side_effect = + fun + [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $str:_$ >> | + <:expr< $chr:_$ >> | <:expr< $int:_$ >> | <:expr< $flo:_$ >> | + <:expr< $_$ . $_$ >> | <:expr< fun [ $list:_$ ] >> -> + False + | <:expr< ($list:el$) >> -> List.exists may_side_effect el + | <:expr< $_$ $_$ >> as e -> + let (f, el) = expr_fa [] e in + not (no_side_effects f) || List.exists may_side_effect el + | _ -> True ] +; + +value rec may_be_side_effect_victim = + fun + [ <:expr< $lid:_$ . $_$ >> -> True + | <:expr< $uid:_$ . $e$ >> -> may_be_side_effect_victim e + | _ -> False ] +; + +value rec may_depend_on_order el = + loop False False el where rec loop + side_effect_found side_effect_victim_found = + fun + [ [e :: el] -> + if may_side_effect e then + if side_effect_found || side_effect_victim_found then True + else loop True True el + else if may_be_side_effect_victim e then + if side_effect_found then True else loop False True el + else loop side_effect_found side_effect_victim_found el + | [] -> False ] +; + +value gen_let_in loc expr el = + let (pel, el) = + loop 0 (List.rev el) where rec loop n = + fun + [ [e :: el] -> + if may_side_effect e || may_be_side_effect_victim e then + if n = 0 then + let (pel, el) = loop 1 el in + (pel, [expr e :: el]) + else + let id = "xxx" ^ string_of_int n in + let (pel, el) = loop (n + 1) el in + ([(<:patt< $lid:id$ >>, expr e) :: pel], + [<:expr< $lid:id$ >> :: el]) + else + let (pel, el) = loop n el in + (pel, [expr e :: el]) + | [] -> ([], []) ] + in + match List.rev el with + [ [e :: el] -> (pel, e, el) + | _ -> assert False ] +; + +value left_eval_apply loc expr e1 e2 = + let (f, el) = expr_fa [] <:expr< $e1$ $e2$ >> in + if not (may_depend_on_order [f :: el]) then <:expr< $expr e1$ $expr e2$ >> + else + let (pel, e, el) = gen_let_in loc expr [f :: el] in + let e = List.fold_left (fun e e1 -> <:expr< $e$ $e1$ >>) e el in + List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel +; + +value left_eval_tuple loc expr el = + if not (may_depend_on_order el) then <:expr< ($list:List.map expr el$) >> + else + let (pel, e, el) = gen_let_in loc expr el in + List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) + <:expr< ($list:[e :: el]$) >> pel +; + +value left_eval_record loc expr lel = + let el = List.map snd lel in + if not (may_depend_on_order el) then + let lel = List.map (fun (p, e) -> (p, expr e)) lel in + <:expr< { $list:lel$ } >> + else + let (pel, e, el) = gen_let_in loc expr el in + let e = + let lel = List.combine (List.map fst lel) [e :: el] in + <:expr< { $list:lel$ } >> + in + List.fold_left (fun e (p1, e1) -> <:expr< let $p1$ = $e1$ in $e$ >>) e pel +; + +value left_eval_assign loc expr e1 e2 = <:expr< $e1$ := $expr e2$ >>; + +(* scanning the input tree, calling "left_eval_*" functions if necessary *) + +value map_option f = + fun + [ Some x -> Some (f x) + | None -> None ] +; + +value class_infos f ci = + {MLast.ciLoc = ci.MLast.ciLoc; MLast.ciVir = ci.MLast.ciVir; + MLast.ciPrm = ci.MLast.ciPrm; MLast.ciNam = ci.MLast.ciNam; + MLast.ciExp = f ci.MLast.ciExp} +; + +value rec expr x = + let loc = MLast.loc_of_expr x in + match x with + [ <:expr< fun [ $list:pwel$ ] >> -> + <:expr< fun [ $list:List.map match_assoc pwel$ ] >> + | <:expr< match $e$ with [ $list:pwel$ ] >> -> + <:expr< match $expr e$ with [ $list:List.map match_assoc pwel$ ] >> + | <:expr< try $e$ with [ $list:pwel$ ] >> -> + <:expr< try $expr e$ with [ $list:List.map match_assoc pwel$ ] >> + | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> + <:expr< let $opt:rf$ $list:List.map let_binding pel$ in $expr e$ >> + | <:expr< let module $s$ = $me$ in $e$ >> -> + <:expr< let module $s$ = $module_expr me$ in $expr e$ >> + | <:expr< if $e1$ then $e2$ else $e3$ >> -> + <:expr< if $expr e1$ then $expr e2$ else $expr e3$ >> + | <:expr< while $e$ do { $list:el$ } >> -> + <:expr< while $expr e$ do { $list:List.map expr el$ } >> + | <:expr< do { $list:el$ } >> -> <:expr< do { $list:List.map expr el$ } >> + | <:expr< $e$ # $s$ >> -> <:expr< $expr e$ # $s$ >> + | <:expr< ($e$ : $t$) >> -> <:expr< ($expr e$ : $t$) >> + | <:expr< $e1$ || $e2$ >> -> <:expr< $expr e1$ || $expr e2$ >> + | <:expr< $e1$ && $e2$ >> -> <:expr< $expr e1$ && $expr e2$ >> + | <:expr< $e1$ $e2$ >> -> left_eval_apply loc expr e1 e2 + | <:expr< ($list:el$) >> -> left_eval_tuple loc expr el + | <:expr< { $list:lel$ } >> -> left_eval_record loc expr lel + | <:expr< $e1$ := $e2$ >> -> left_eval_assign loc expr e1 e2 + | <:expr< $_$ . $_$ >> | <:expr< $uid:_$ >> | <:expr< $lid:_$ >> | + <:expr< $str:_$ >> | <:expr< $chr:_$ >> | <:expr< $int:_$ >> | + <:expr< $flo:_$ >> | <:expr< new $list:_$ >> -> + x + | x -> not_impl "expr" x ] +and let_binding (p, e) = (p, expr e) +and match_assoc (p, eo, e) = (p, map_option expr eo, expr e) +and module_expr x = + let loc = MLast.loc_of_module_expr x in + match x with + [ <:module_expr< functor ($s$ : $mt$) -> $me$ >> -> + <:module_expr< functor ($s$ : $mt$) -> $module_expr me$ >> + | <:module_expr< ($me$ : $mt$) >> -> + <:module_expr< ($module_expr me$ : $mt$) >> + | <:module_expr< struct $list:sil$ end >> -> + <:module_expr< struct $list:List.map str_item sil$ end >> + | <:module_expr< $_$ . $_$ >> | <:module_expr< $_$ $_$ >> | + <:module_expr< $uid:_$ >> -> + x ] +and str_item x = + let loc = MLast.loc_of_str_item x in + match x with + [ <:str_item< module $s$ = $me$ >> -> + <:str_item< module $s$ = $module_expr me$ >> + | <:str_item< value $opt:rf$ $list:pel$ >> -> + <:str_item< value $opt:rf$ $list:List.map let_binding pel$ >> + | <:str_item< declare $list:sil$ end >> -> + <:str_item< declare $list:List.map str_item sil$ end >> + | <:str_item< class $list:ce$ >> -> + <:str_item< class $list:List.map (class_infos class_expr) ce$ >> + | <:str_item< $exp:e$ >> -> <:str_item< $exp:expr e$ >> + | <:str_item< open $_$ >> | <:str_item< type $list:_$ >> | + <:str_item< exception $_$ of $list:_$ = $_$ >> | + <:str_item< module type $_$ = $_$ >> | <:str_item< # $_$ $opt:_$ >> -> + x + | x -> not_impl "str_item" x ] +and class_expr x = + let loc = MLast.loc_of_class_expr x in + match x with + [ <:class_expr< object $opt:p$ $list:csil$ end >> -> + <:class_expr< object $opt:p$ $list:List.map class_str_item csil$ end >> + | x -> not_impl "class_expr" x ] +and class_str_item x = + let loc = MLast.loc_of_class_str_item x in + match x with + [ <:class_str_item< value $opt:mf$ $s$ = $e$ >> -> + <:class_str_item< value $opt:mf$ $s$ = $expr e$ >> + | <:class_str_item< method $s$ = $e$ >> -> + <:class_str_item< method $s$ = $expr e$ >> + | x -> not_impl "class_str_item" x ] +; + +value parse_implem = Pcaml.parse_implem.val; +value parse_implem_with_left_eval strm = + let (r, b) = parse_implem strm in + (List.map (fun (si, loc) -> (str_item si, loc)) r, b) +; +Pcaml.parse_implem.val := parse_implem_with_left_eval; diff --git a/ocaml-binary-annot/camlp4/unmaintained/lib/.cvsignore b/ocaml-binary-annot/camlp4/unmaintained/lib/.cvsignore new file mode 100644 index 0000000000..c77a681dd6 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/lib/.cvsignore @@ -0,0 +1,3 @@ +*.cm[oiax] +*.cmxa +*.lib diff --git a/ocaml-binary-annot/camlp4/unmaintained/lib/.depend b/ocaml-binary-annot/camlp4/unmaintained/lib/.depend new file mode 100644 index 0000000000..a779396987 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/lib/.depend @@ -0,0 +1,14 @@ +debug.cmo: debug.cmi +debug.cmx: debug.cmi +extfun.cmo: extfun.cmi +extfun.cmx: extfun.cmi +fstream.cmo: fstream.cmi +fstream.cmx: fstream.cmi +grammar.cmo: token.cmi plexer.cmi loc.cmi +grammar.cmx: token.cmx plexer.cmi loc.cmx +loc.cmo: loc.cmi +loc.cmx: loc.cmi +token.cmo: loc.cmi token.cmi +token.cmx: loc.cmx token.cmi +plexer.cmi: token.cmi loc.cmi +token.cmi: loc.cmi diff --git a/ocaml-binary-annot/camlp4/unmaintained/lib/Makefile b/ocaml-binary-annot/camlp4/unmaintained/lib/Makefile new file mode 100644 index 0000000000..3d5be9b45a --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/lib/Makefile @@ -0,0 +1,52 @@ + + +include ../config/Makefile.cnf + +INCLUDES=-I $(OTOP)/parsing -I $(OTOP)/utils +LIBRARIES=gramlib.cma +OBJS=$(OTOP)/utils/misc.cmo $(OTOP)/parsing/linenum.cmo \ + $(OTOP)/utils/warnings.cmo $(OTOP)/parsing/location.cmo \ + $(OTOP)/utils/config.cmo debug.cmo loc.cmo \ + token.cmo lexer_token.cmo lexer_error.cmo \ + plexer.cmo grammar.cmo extfun.cmo \ + fstream.cmo +CLEANFILES=plexer.ml + +include ../config/Makefile.base + +debug.cmo: debug.cmi +debug.cmo: debug.ml + $(OCAMLC) -pp '$(CAMLP4BOOT)' -rectypes $(OCAMLCFLAGS) $< -c -o $@ + +plexer.cmo: plexer.ml plexer.cmi + $(OCAMLC) $(OCAMLCFLAGS) $< -c -o $@ + +plexer.cmx: plexer.ml plexer.cmi + $(OCAMLOPT) $(OCAMLCFLAGS) $< -c -o $@ + +$(LIBRARIES): $(OBJS) + $(OCAMLC) -linkall $(OBJS) -a -o $(LIBRARIES) + +$(LIBRARIESX): $(OBJSX) + $(OCAMLOPT) -linkall $(OBJSX) -a -o $(LIBRARIESX) + +$(LIBRARIESP): $(OBJSP) + $(OCAMLOPT) -linkall $(OBJSP) -a -o $(LIBRARIESP) + +install-local: + -$(MKDIR) "$(LIBDIR)/camlp4" + cp $(LIBRARIES) *.mli "$(LIBDIR)/camlp4/." + cp *.cmi "$(LIBDIR)/camlp4/." + test -f $(LIBRARIESX) && $(MAKE) installopt LIBDIR="$(LIBDIR)" || true + +installopt: + for f in $(LIBRARIESX) $(LIBRARIESP) *.cmx ; do \ + test -f $$f && cp $$f "$(LIBDIR)/camlp4/." || true ; \ + done + # Special treatment for this one: some versions of make don't like $(A) in $(TARGET:.cma=.$(A)) + target="`echo $(LIBRARIES) | sed -e 's/\.cma$$/.$(A)/'`" ; \ + if test -f $$target ; then \ + cp $$target "$(LIBDIR)/camlp4/." && ( cd "$(LIBDIR)/camlp4/." && $(RANLIB) $$target ) \ + fi + +include .depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/lib/extfun.ml b/ocaml-binary-annot/camlp4/unmaintained/lib/extfun.ml new file mode 100644 index 0000000000..4f4cbbd93a --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/lib/extfun.ml @@ -0,0 +1,107 @@ +(* camlp4r *) + +(* Copyright 2001 INRIA *) + +(* Extensible Functions *) + +type t 'a 'b = list (matching 'a 'b) +and matching 'a 'b = { patt : patt; has_when : bool; expr : expr 'a 'b } +and patt = + [ Eapp of list patt + | Eacc of list patt + | Econ of string + | Estr of string + | Eint of string + | Etup of list patt + | Evar of unit ] +and expr 'a 'b = 'a -> option 'b +; + +exception Failure; + +value empty = []; + +(*** Apply ***) + +value rec apply_matchings a = + fun + [ [m :: ml] -> + match m.expr a with + [ None -> apply_matchings a ml + | x -> x ] + | [] -> None ] +; + +value apply ef a = + match apply_matchings a ef with + [ Some x -> x + | None -> raise Failure ] +; + +(*** Trace ***) + +value rec list_iter_sep f s = + fun + [ [] -> () + | [x] -> f x + | [x :: l] -> do { f x; s (); list_iter_sep f s l } ] +; + +value rec print_patt = + fun + [ Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl + | p -> print_patt2 p ] +and print_patt2 = + fun + [ Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl + | p -> print_patt1 p ] +and print_patt1 = + fun + [ Econ s -> print_string s + | Estr s -> do { print_string "\""; print_string s; print_string "\"" } + | Eint s -> print_string s + | Evar () -> print_string "_" + | Etup pl -> + do { + print_string "("; + list_iter_sep print_patt (fun () -> print_string ", ") pl; + print_string ")" + } + | Eapp _ | Eacc _ as p -> + do { print_string "("; print_patt p; print_string ")" } ] +; + +value print ef = + List.iter + (fun m -> + do { + print_patt m.patt; + if m.has_when then print_string " when ..." else (); + print_newline () + }) + ef +; + +(*** Extension ***) + +value insert_matching matchings (patt, has_when, expr) = + let m1 = {patt = patt; has_when = has_when; expr = expr} in + let rec loop = + fun + [ [m :: ml] as gml -> + if m1.has_when && not m.has_when then [m1 :: gml] else + if not m1.has_when && m.has_when then [m :: loop ml] else + (* either both or none have a when clause *) + if compare m1.patt m.patt = 0 then + if not m1.has_when then [m1 :: ml] else [m1 :: gml] + else [m :: loop ml] + | [] -> [m1] ] + in + loop matchings +; + +(* available extension function *) + +value extend ef matchings_def = + List.fold_left insert_matching ef matchings_def +; diff --git a/ocaml-binary-annot/camlp4/unmaintained/lib/extfun.mli b/ocaml-binary-annot/camlp4/unmaintained/lib/extfun.mli new file mode 100644 index 0000000000..6d71fc11f0 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/lib/extfun.mli @@ -0,0 +1,35 @@ +(* camlp4r *) + + +(** Extensible functions. + + This module implements pattern matching extensible functions. + To extend, use syntax [pa_extfun.cmo]: + + [extfun e with [ pattern_matching ]] *) + +type t 'a 'b = 'x; + (** The type of the extensible functions of type ['a -> 'b] *) +value empty : t 'a 'b; + (** Empty extensible function *) +value apply : t 'a 'b -> 'a -> 'b; + (** Apply an extensible function *) +exception Failure; + (** Match failure while applying an extensible function *) +value print : t 'a 'b -> unit; + (** Print patterns in the order they are recorded *) + +(**/**) + +type patt = + [ Eapp of list patt + | Eacc of list patt + | Econ of string + | Estr of string + | Eint of string + | Etup of list patt + | Evar of unit ] +and expr 'a 'b = 'a -> option 'b +; + +value extend : t 'a 'b -> list (patt * bool * expr 'a 'b) -> t 'a 'b; diff --git a/ocaml-binary-annot/camlp4/unmaintained/lib/fstream.ml b/ocaml-binary-annot/camlp4/unmaintained/lib/fstream.ml new file mode 100644 index 0000000000..8c3171a877 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/lib/fstream.ml @@ -0,0 +1,77 @@ +(* camlp4r *) + +(* Copyright 2001 INRIA *) + +type t 'a = { count : int; data : Lazy.t (data 'a) } +and data 'a = + [ Nil + | Cons of 'a and t 'a + | App of t 'a and t 'a ] +; + +value from f = + loop 0 where rec loop i = + {count = 0; + data = + lazy + (match f i with + [ Some x -> Cons x (loop (i + 1)) + | None -> Nil ])} +; + +value rec next s = + let count = s.count + 1 in + match Lazy.force s.data with + [ Nil -> None + | Cons a s -> Some (a, {count = count; data = s.data}) + | App s1 s2 -> + match next s1 with + [ Some (a, s1) -> Some (a, {count = count; data = lazy (App s1 s2)}) + | None -> + match next s2 with + [ Some (a, s2) -> Some (a, {count = count; data = s2.data}) + | None -> None ] ] ] +; + +value empty s = + match next s with + [ Some _ -> None + | None -> Some ((), s) ] +; + +value nil = {count = 0; data = lazy Nil}; +value cons a s = Cons a s; +value app s1 s2 = App s1 s2; +value flazy f = {count = 0; data = Lazy.lazy_from_fun f}; + +value of_list l = + List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil +; + +value of_string s = + from (fun c -> if c < String.length s then Some s.[c] else None) +; + +value of_channel ic = + from (fun _ -> try Some (input_char ic) with [ End_of_file -> None ]) +; + +value iter f = + do_rec where rec do_rec strm = + match next strm with + [ Some (a, strm) -> + let _ = f a in + do_rec strm + | None -> () ] +; + +value count s = s.count; + +value count_unfrozen s = + loop 0 s where rec loop cnt s = + if Lazy.lazy_is_val s.data then + match Lazy.force s.data with + [ Cons _ s -> loop (cnt + 1) s + | _ -> cnt ] + else cnt +; diff --git a/ocaml-binary-annot/camlp4/unmaintained/lib/fstream.mli b/ocaml-binary-annot/camlp4/unmaintained/lib/fstream.mli new file mode 100644 index 0000000000..723389ac03 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/lib/fstream.mli @@ -0,0 +1,60 @@ +(* camlp4r *) + + +(* Module [Fstream]: functional streams *) + +(* This module implement functional streams. + To be used with syntax [pa_fstream.cmo]. The syntax is: +- stream: [fstream [: ... :]] +- parser: [parser [ [: ... :] -> ... | ... ]] + + Functional parsers are of type: [Fstream.t 'a -> option ('a * Fstream.t 'a)] + + They have limited backtrack, i.e if a rule fails, the next rule is tested + with the initial stream; limited because when in case of a rule with two + consecutive symbols [a] and [b], if [b] fails, the rule fails: there is + no try with the next rule of [a]. +*) + +type t 'a = 'x; + (* The type of 'a functional streams *) +value from : (int -> option 'a) -> t 'a; + (* [Fstream.from f] returns a stream built from the function [f]. + To create a new stream element, the function [f] is called with + the current stream count. The user function [f] must return either + [Some <value>] for a value or [None] to specify the end of the + stream. *) + +value of_list : list 'a -> t 'a; + (* Return the stream holding the elements of the list in the same + order. *) +value of_string : string -> t char; + (* Return the stream of the characters of the string parameter. *) +value of_channel : in_channel -> t char; + (* Return the stream of the characters read from the input channel. *) + +value iter : ('a -> unit) -> t 'a -> unit; + (* [Fstream.iter f s] scans the whole stream s, applying function [f] + in turn to each stream element encountered. *) + +value next : t 'a -> option ('a * t 'a); + (* Return [Some (a, s)] where [a] is the first element of the stream + and [s] the remaining stream, or [None] if the stream is empty. *) +value empty : t 'a -> option (unit * t 'a); + (* Return [Some ((), s)] if the stream is empty where [s] is itself, + else [None] *) +value count : t 'a -> int; + (* Return the current count of the stream elements, i.e. the number + of the stream elements discarded. *) +value count_unfrozen : t 'a -> int; + (* Return the number of unfrozen elements in the beginning of the + stream; useful to determine the position of a parsing error (longuest + path). *) + +(*--*) + +value nil : t 'a; +type data 'a = 'x; +value cons : 'a -> t 'a -> data 'a; +value app : t 'a -> t 'a -> data 'a; +value flazy : (unit -> data 'a) -> t 'a; diff --git a/ocaml-binary-annot/camlp4/unmaintained/ocamllex/Makefile b/ocaml-binary-annot/camlp4/unmaintained/ocamllex/Makefile new file mode 100644 index 0000000000..b232023e58 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/ocamllex/Makefile @@ -0,0 +1,59 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# Makefile for pa_ocamllex +# M.Mauny +# + +include ../../config/Makefile.cnf + +OCAMLTOP=../../.. + +CAMLP4=../../camlp4/camlp4$(EXE) + +OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) +OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) + +P4INCLUDES= -nolib -I ../../etc -I ../../meta +OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 -I ../../lib -I $(OCAMLTOP)/lex +OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) + +SRC=pa_ocamllex.ml +OBJS=pa_ocamllex.cmo +OBJSX=$(OBJS:.cmo=.cmx) + +all: $(OBJS) pa_ocamllex.cma + +opt: $(OBJSX) pa_ocamllex.cmxa + +pa_ocamllex.cma: pa_ocamllex.cmo + $(OCAMLC) $(OCAMLCFLAGS) cset.cmo syntax.cmo table.cmo lexgen.cmo compact.cmo pa_ocamllex.cmo -a -o pa_ocamllex.cma + +pa_ocamllex.cmxa: pa_ocamllex.cmo + $(OCAMLOPT) $(OCAMLCFLAGS) cset.cmx syntax.cmx table.cmx lexgen.cmx compact.cmx pa_ocamllex.cmx -a -o pa_ocamllex.cmxa + +clean: + rm -f *.cm* *.$(O) *.$(A) *.bak .*.bak + +depend: + +.SUFFIXES: .cmx .cmo .cmi .ml .mli + +.mli.cmi: + $(OCAMLC) $(OCAMLCFLAGS) -c $< + + +.ml.cmo: + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< diff --git a/ocaml-binary-annot/camlp4/unmaintained/ocamllex/README b/ocaml-binary-annot/camlp4/unmaintained/ocamllex/README new file mode 100644 index 0000000000..809d42f2a8 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/ocamllex/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + diff --git a/ocaml-binary-annot/camlp4/unmaintained/ocamllex/pa_ocamllex.ml b/ocaml-binary-annot/camlp4/unmaintained/ocamllex/pa_ocamllex.ml new file mode 100644 index 0000000000..e1d4a8ef0d --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/ocamllex/pa_ocamllex.ml @@ -0,0 +1,356 @@ +(* pa_o.cmo q_MLast.cmo pa_extend.cmo pr_dump.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Alain Frisch, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file *) +(* ../../../LICENSE. *) +(* *) +(***********************************************************************) + + +open Syntax +open Lexgen +open Compact + +(* Adapted from output.ml *) +(**************************) + +(* Output the DFA tables and its entry points *) + +(* To output an array of short ints, encoded as a string *) + +let output_byte buf b = + Buffer.add_char buf '\\'; + Buffer.add_char buf (Char.chr(48 + b / 100)); + Buffer.add_char buf (Char.chr(48 + (b / 10) mod 10)); + Buffer.add_char buf (Char.chr(48 + b mod 10)) + +let loc = (Lexing.dummy_pos,Lexing.dummy_pos) + +let output_array v = + let b = Buffer.create (Array.length v * 3) in + for i = 0 to Array.length v - 1 do + output_byte b (v.(i) land 0xFF); + output_byte b ((v.(i) asr 8) land 0xFF); + if i land 7 = 7 then Buffer.add_string b "\\\n " + done; + let s = Buffer.contents b in + <:expr< $str:s$ >> + +let output_byte_array v = + let b = Buffer.create (Array.length v * 2) in + for i = 0 to Array.length v - 1 do + output_byte b (v.(i) land 0xFF); + if i land 15 = 15 then Buffer.add_string b "\\\n " + done; + let s = Buffer.contents b in + <:expr< $str:s$ >> + + + +(* Output the tables *) + +let output_tables tbl = + <:str_item< value lex_tables = { + Lexing.lex_base = $output_array tbl.tbl_base$; + Lexing.lex_backtrk = $output_array tbl.tbl_backtrk$; + Lexing.lex_default = $output_array tbl.tbl_default$; + Lexing.lex_trans = $output_array tbl.tbl_trans$; + Lexing.lex_check = $output_array tbl.tbl_check$; + Lexing.lex_base_code = $output_array tbl.tbl_base_code$; + Lexing.lex_backtrk_code = $output_array tbl.tbl_backtrk_code$; + Lexing.lex_default_code = $output_array tbl.tbl_default_code$; + Lexing.lex_trans_code = $output_array tbl.tbl_trans_code$; + Lexing.lex_check_code = $output_array tbl.tbl_check_code$; + Lexing.lex_code = $output_byte_array tbl.tbl_code$ + } >> + +(* Output the entries *) + +let rec make_alias n = function + | [] -> [] + | h::t -> + (h, "__ocaml_lex_arg_" ^ (string_of_int n)) :: (make_alias (succ n) t) + +let abstraction = + List.fold_right (fun (p,a) e -> <:expr< fun ($p$ as $lid:a$) -> $e$ >>) + + +let application = + List.fold_left (fun f (_,a) -> <:expr< $f$ $lid:a$ >>) + +let int i = <:expr< $int:string_of_int i$ >> + +let output_memory_actions acts = + let aux = function + | Copy (tgt, src) -> + <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := + lexbuf.Lexing.lex_mem.($int src$) >> + | Set tgt -> + <:expr< lexbuf.Lexing.lex_mem.($int tgt$) := + lexbuf.Lexing.lex_curr_pos >> + in + <:expr< do { $list:List.map aux acts$ } >> + +let output_base_mem = function + | Mem i -> <:expr< lexbuf.Lexing.lex_mem.($int i$) >> + | Start -> <:expr< lexbuf.Lexing.lex_start_pos >> + | End -> <:expr< lexbuf.Lexing.lex_curr_pos >> + +let output_tag_access = function + | Sum (a,0) -> output_base_mem a + | Sum (a,i) -> <:expr< $output_base_mem a$ + $int i$ >> + +let rec output_env e = function + | [] -> e + | (x, Ident_string (o,nstart,nend)) :: rem -> + <:expr< + let $lid:x$ = + Lexing.$lid:if o then "sub_lexeme_opt" else "sub_lexeme"$ + lexbuf $output_tag_access nstart$ $output_tag_access nend$ + in $output_env e rem$ + >> + | (x, Ident_char (o,nstart)) :: rem -> + <:expr< + let $lid:x$ = + Lexing.$lid: if o then "sub_lexeme_char_opt" else "sub_lexeme_char"$ + lexbuf $output_tag_access nstart$ + in $output_env e rem$ + >> + +let output_entry e = + let init_num, init_moves = e.auto_initial_state in + let args = make_alias 0 (e.auto_args @ [ <:patt< lexbuf >> ]) in + let f = "__ocaml_lex_rec_" ^ e.auto_name ^ "_rec" in + let call_f = application <:expr< $lid:f$ >> args in + let body_wrapper = + <:expr< + do { + lexbuf.Lexing.lex_mem := Array.create $int e.auto_mem_size$ (-1) ; + $output_memory_actions init_moves$; + $call_f$ $int init_num$ + } >> in + let cases = + List.map + (fun (num, env, (loc,e)) -> + <:patt< $int:string_of_int num$ >>, + None, + output_env <:expr< $e$ >> env + (* Note: the <:expr<...>> above is there to set the location *) + ) e.auto_actions @ + [ <:patt< __ocaml_lex_n >>, + None, + <:expr< do + { lexbuf.Lexing.refill_buff lexbuf; $call_f$ __ocaml_lex_n }>> ] + in + let engine = + if e.auto_mem_size = 0 + then <:expr< Lexing.engine >> + else <:expr< Lexing.new_engine >> in + let body = + <:expr< fun state -> + match $engine$ lex_tables state lexbuf with [ $list:cases$ ] >> in + [ + <:patt< $lid:e.auto_name$ >>, (abstraction args body_wrapper); + <:patt< $lid:f$ >>, (abstraction args body) + ] + +(* Main output function *) + +exception Table_overflow + +let output_lexdef tables entry_points = + Printf.eprintf + "pa_ocamllex: lexer found; %d states, %d transitions, table size %d bytes\n" + (Array.length tables.tbl_base) + (Array.length tables.tbl_trans) + (2 * (Array.length tables.tbl_base + Array.length tables.tbl_backtrk + + Array.length tables.tbl_default + Array.length tables.tbl_trans + + Array.length tables.tbl_check)); + let size_groups = + (2 * (Array.length tables.tbl_base_code + + Array.length tables.tbl_backtrk_code + + Array.length tables.tbl_default_code + + Array.length tables.tbl_trans_code + + Array.length tables.tbl_check_code) + + Array.length tables.tbl_code) in + if size_groups > 0 then + Printf.eprintf "pa_ocamllex: %d additional bytes used for bindings\n" + size_groups ; + flush stderr; + if Array.length tables.tbl_trans > 0x8000 then raise Table_overflow; + + let entries = List.map output_entry entry_points in + [output_tables tables; <:str_item< value rec $list:List.flatten entries$ >> ] + + +(* Adapted from parser.mly and main.ml *) +(***************************************) + +(* Auxiliaries for the parser. *) + +let char s = Char.code (Token.eval_char s) + +let named_regexps = + (Hashtbl.create 13 : (string, regular_expression) Hashtbl.t) + +let regexp_for_string s = + let rec re_string n = + if n >= String.length s then Epsilon + else if succ n = String.length s then + Characters (Cset.singleton (Char.code s.[n])) + else + Sequence + (Characters(Cset.singleton (Char.code s.[n])), + re_string (succ n)) + in re_string 0 + +let char_class c1 c2 = Cset.interval c1 c2 + +let all_chars = Cset.all_chars + +let rec remove_as = function + | Bind (e,_) -> remove_as e + | Epsilon|Eof|Characters _ as e -> e + | Sequence (e1, e2) -> Sequence (remove_as e1, remove_as e2) + | Alternative (e1, e2) -> Alternative (remove_as e1, remove_as e2) + | Repetition e -> Repetition (remove_as e) + +let () = + Hashtbl.add named_regexps "eof" (Characters Cset.eof) + +(* The parser *) + +let let_regexp = Grammar.Entry.create Pcaml.gram "pa_ocamllex let" +let header = Grammar.Entry.create Pcaml.gram "pa_ocamllex header" +let lexer_def = Grammar.Entry.create Pcaml.gram "pa_ocaml lexerdef" + +EXTEND + GLOBAL: Pcaml.str_item let_regexp header lexer_def; + + let_regexp: [ + [ x = LIDENT; "="; r = regexp -> + if Hashtbl.mem named_regexps x then + Printf.eprintf + "pa_ocamllex (warning): multiple definition of named regexp '%s'\n" + x; + Hashtbl.add named_regexps x r; + ] + ]; + + lexer_def: [ + [ def = LIST0 definition SEP "and" -> + (try + let (entries, transitions) = make_dfa def in + let tables = compact_tables transitions in + let output = output_lexdef tables entries in + <:str_item< declare $list: output$ end >> + with + |Table_overflow -> + failwith "Transition table overflow in lexer, automaton is too big" + | Lexgen.Memory_overflow -> + failwith "Position memory overflow in lexer, too many as variables") + ] + ]; + + + Pcaml.str_item: [ + [ "pa_ocamllex"; LIDENT "rule"; d = lexer_def -> d + | "pa_ocamllex"; "let"; let_regexp -> + <:str_item< declare $list: []$ end >> + ] + ]; + + definition: [ + [ x=LIDENT; pl = LIST0 Pcaml.patt LEVEL "simple"; "="; + short=[ LIDENT "parse" -> false | LIDENT "shortest" -> true ]; + OPT "|"; l = LIST0 [ r=regexp; a=action -> (r,a) ] SEP "|" -> + { name=x ; shortest=short ; args=pl ; clauses = l } ] + ]; + + action: [ + [ "{"; e = OPT Pcaml.expr; "}" -> + let e = match e with + | Some e -> e + | None -> <:expr< () >> + in + (loc,e) + ] + ]; + + header: [ + [ "{"; e = LIST0 [ si = Pcaml.str_item; OPT ";;" -> si ]; "}" -> + [<:str_item< declare $list:e$ end>>, loc] ] + | [ -> [] ] + ]; + + regexp: [ + [ r = regexp; "as"; i = LIDENT -> Bind (r,i) ] + | [ r1 = regexp; "|"; r2 = regexp -> Alternative(r1,r2) ] + | [ r1 = regexp; r2 = regexp -> Sequence(r1,r2) ] + | [ r = regexp; "*" -> Repetition r + | r = regexp; "+" -> Sequence(Repetition (remove_as r), r) + | r = regexp; "?" -> Alternative(Epsilon, r) + | "("; r = regexp; ")" -> r + | "_" -> Characters all_chars + | c = CHAR -> Characters (Cset.singleton (char c)) + | s = STRING -> regexp_for_string (Token.eval_string loc s) + | "["; cc = ch_class; "]" -> Characters cc + | x = LIDENT -> + try Hashtbl.find named_regexps x + with Not_found -> + failwith + ("pa_ocamllex (error): reference to unbound regexp name `"^x^"'") + ] + ]; + + ch_class: [ + [ "^"; cc = ch_class -> Cset.complement cc] + | [ c1 = CHAR; "-"; c2 = CHAR -> Cset.interval (char c1) (char c2) + | c = CHAR -> Cset.singleton (char c) + | cc1 = ch_class; cc2 = ch_class -> Cset.union cc1 cc2 + ] + ]; +END + +(* We have to be careful about "rule"; in standalone mode, + it is used as a keyword (otherwise, there is a conflict + with named regexp); in normal mode, it is used as LIDENT + (we do not want to reserve such an useful identifier). + + Plexer does not like identifiers used as keyword _and_ + as LIDENT ... +*) + +let standalone = + let already = ref false in + fun () -> + if not (!already) then + begin + already := true; + Printf.eprintf "pa_ocamllex: stand-alone mode\n"; + + DELETE_RULE Pcaml.str_item: "pa_ocamllex"; LIDENT "rule";lexer_def END; + DELETE_RULE Pcaml.str_item: "pa_ocamllex"; "let"; let_regexp END; + let ocamllex = Grammar.Entry.create Pcaml.gram "pa_ocamllex" in + EXTEND GLOBAL: ocamllex let_regexp header lexer_def; + ocamllex: [ + [ h = header; + l = [LIST0 ["let"; let_regexp]; "rule"; d = lexer_def -> (d,loc)]; + t = header; EOI -> h @ (l :: t) ,false + ] + ]; + END; + Pcaml.parse_implem := Grammar.Entry.parse ocamllex + end + +let () = + Pcaml.add_option "-ocamllex" (Arg.Unit standalone) + "Activate (standalone) ocamllex emulation mode." + diff --git a/ocaml-binary-annot/camlp4/unmaintained/ocpp/.cvsignore b/ocaml-binary-annot/camlp4/unmaintained/ocpp/.cvsignore new file mode 100644 index 0000000000..baef26c63b --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/ocpp/.cvsignore @@ -0,0 +1,3 @@ +*.cm[oia] +ocpp +crc.ml diff --git a/ocaml-binary-annot/camlp4/unmaintained/ocpp/.depend b/ocaml-binary-annot/camlp4/unmaintained/ocpp/.depend new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/ocpp/.depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/ocpp/Makefile b/ocaml-binary-annot/camlp4/unmaintained/ocpp/Makefile new file mode 100644 index 0000000000..b92fa3c580 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/ocpp/Makefile @@ -0,0 +1,24 @@ + + +include ../config/Makefile.cnf + +EXECUTABLES=ocpp +OBJS=ocpp.cmo +INCLUDES=-I ../camlp4 -I ../lib -I ../odyl -I $(OTOP)/otherlibs/dynlink +OCPPM=../lib/debug.cmo ../lib/loc.cmo ../lib/stdpp.cmo ../camlp4/quotation.cmo + +include ../config/Makefile.base + +ocpp$(EXE): $(OBJS) + $(OCAMLC) $(LINKFLAGS) $(OCPPM) ../odyl/odyl.cma $(OBJS) ../odyl/odyl.cmo -linkall -o $@ + +ocpp.opt: $(OBJSX) + $(OCAMLOPT) $(LINKFLAGS) $(OCPPM:.cmo=.cmx) ../odyl/odyl.cmxa $(OBJSX) ../odyl/odyl.cmx -linkall -o $@ + +install-local: + -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" + cp $(OBJS) "$(LIBDIR)/camlp4/." + cp ocpp$(EXE) "$(BINDIR)/." + if test -f ocpp.opt ; then \ + cp ocpp.opt "$(LIBDIR)/camlp4/." ; \ + fi diff --git a/ocaml-binary-annot/camlp4/unmaintained/ocpp/ocpp.ml b/ocaml-binary-annot/camlp4/unmaintained/ocpp/ocpp.ml new file mode 100644 index 0000000000..eb2ccdf597 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/ocpp/ocpp.ml @@ -0,0 +1,129 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + + + + +value buff = ref (String.create 80); +value store len x = + do { + if len >= String.length buff.val then + buff.val := buff.val ^ String.create (String.length buff.val) + else (); + buff.val.[len] := x; + succ len + } +; +value get_buff len = String.sub buff.val 0 len; + +value rec copy_strip_locate cs = + match cs with parser + [ [: `'$' :] -> maybe_locate cs + | [: `c :] -> do { print_char c; copy_strip_locate cs } + | [: :] -> () ] +and maybe_locate cs = + match cs with parser + [ [: `'1'..'9' :] -> locate cs + | [: :] -> do { print_char '$'; copy_strip_locate cs } ] +and locate cs = + match cs with parser + [ [: `'0'..'9' :] -> locate cs + | [: `':' :] -> inside_locate cs + | [: :] -> raise (Stream.Error "colon char expected") ] +and inside_locate cs = + match cs with parser + [ [: `'$' :] -> copy_strip_locate cs + | [: `'\\'; `c :] -> do { print_char c; inside_locate cs } + | [: `c :] -> do { print_char c; inside_locate cs } + | [: :] -> raise (Stream.Error "end of file in locate directive") ] +; + +value file = ref ""; + +value quot name loc str = + let loc = Loc.move `stop (String.length str) loc in + let exp = + try + match Quotation.find name with + [ Quotation.ExStr f -> f + | _ -> raise Not_found ] + with + [ Not_found -> Stdpp.raise_with_loc loc Not_found ] + in + let new_str = + try exp True { Quotation.loc = Loc.mk file.val ; loc_name_opt = None } str with + [ Loc.Exc_located loc exc -> Stdpp.raise_with_loc loc exc + | exc -> Stdpp.raise_with_loc loc exc ] + in + let cs = Stream.of_string new_str in copy_strip_locate cs +; + +value rec ident len = + parser + [ [: `('A'..'Z' | 'a'..'z' | '0'..'9' | '_' | ''' as c); s :] -> + ident (store len c) s + | [: :] -> get_buff len ] +; + +value loc_of_ep ep = + Loc.set_all `start 1 0 ep (Loc.mk file.val); + +value rec copy cs = + match cs with parser + [ [: `'<' :] -> maybe_quot cs + | [: `'"' :] -> do { print_char '"'; inside_string cs } + | [: `c :] -> do { print_char c; copy cs } + | [: :] -> () ] +and maybe_quot cs = + match cs with parser + [ [: `'<' :] ep -> inside_quot "" (loc_of_ep ep) 0 cs + | [: `':'; i = ident 0; `'<' ?? "less char expected" :] ep -> + inside_quot i (loc_of_ep ep) 0 cs + | [: :] -> do { print_char '<'; copy cs } ] +and inside_quot name loc len cs = + match cs with parser + [ [: `'>' :] -> maybe_end_quot name loc len cs + | [: `c :] -> inside_quot name loc (store len c) cs + | [: :] -> raise (Stream.Error "end of file in quotation") ] +and maybe_end_quot name loc len cs = + match cs with parser + [ [: `'>' :] -> do { quot name loc (get_buff len); copy cs } + | [: :] -> inside_quot name loc (store len '>') cs ] +and inside_string cs = + match cs with parser + [ [: `'"' :] -> do { print_char '"'; copy cs } + | [: `c :] -> do { print_char c; inside_string cs } + | [: :] -> raise (Stream.Error "end of file in string") ] +; + +value copy_quot cs = do { copy cs; flush stdout; }; + +Arg.parse [] (fun x -> file.val := x) "ocpp <objects> <file>"; + +value main () = + try + if file.val <> "" then + copy_quot (Stream.of_channel (open_in_bin file.val)) + else () + with exc -> + do { + Format.printf "@."; + raise + (match exc with + [ Loc.Exc_located loc exc -> + do { Format.eprintf "%a@." Loc.print loc; exc } + | exc -> exc ]) + } +; + +Odyl_main.name.val := "ocpp"; +Odyl_main.go.val := main; diff --git a/ocaml-binary-annot/camlp4/unmaintained/odyl/.cvsignore b/ocaml-binary-annot/camlp4/unmaintained/odyl/.cvsignore new file mode 100644 index 0000000000..8ae0ebb068 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/odyl/.cvsignore @@ -0,0 +1,4 @@ +*.cm[oia] +odyl +*.lib +odyl_config.ml diff --git a/ocaml-binary-annot/camlp4/unmaintained/odyl/.depend b/ocaml-binary-annot/camlp4/unmaintained/odyl/.depend new file mode 100644 index 0000000000..a26294403e --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/odyl/.depend @@ -0,0 +1,4 @@ +odyl.cmo: odyl_main.cmi odyl_config.cmo +odyl.cmx: odyl_main.cmx odyl_config.cmx +odyl_main.cmo: odyl_config.cmo odyl_main.cmi +odyl_main.cmx: odyl_config.cmx odyl_main.cmi diff --git a/ocaml-binary-annot/camlp4/unmaintained/odyl/Makefile b/ocaml-binary-annot/camlp4/unmaintained/odyl/Makefile new file mode 100644 index 0000000000..f4f5d8709d --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/odyl/Makefile @@ -0,0 +1,61 @@ + + +include ../config/Makefile.cnf + +EXECUTABLES=odyl +INCLUDES=-I $(OTOP)/otherlibs/dynlink +OBJS=odyl_config.cmo odyl_main.cmo +OBJSX=odyl.cmx odyl.cmxa +CLEANFILES=odyl_config.ml + +include ../config/Makefile.base + +odyl$(EXE): odyl.cma odyl.cmo + $(OCAMLC) odyl.cma odyl.cmo -o $@ + +odyl.opt: odyl.cmxa odyl.cmx + $(OCAMLOPT) odyl.cmxa odyl.cmx -o $@ + +odyl.cma: $(OBJS) + $(OCAMLC) $(LINKFLAGS) dynlink.cma $(OBJS) -a -o $@ + +odyl.cmxa: $(OBJSX) + $(OCAMLOPT) $(LINKFLAGS) $(OBJSX) -a -o $@ + +odyl.p.cmxa: $(OBJSP) + $(OCAMLOPT) $(LINKFLAGS) $(OBJSP) -a -o $@ + +odyl_main.cmx: odyl_main.ml + $(CAMLP4BOOT) -nolib -DOPT -o odyl_main.ppo odyl_main.ml + $(OCAMLOPT) -c -impl odyl_main.ppo + rm -f odyl_main.ppo + +odyl_main.p.cmx: odyl_main.ml + $(CAMLP4BOOT) -nolib -DOPT -o odyl_main.ppo odyl_main.ml + $(OCAMLOPT) -p -c -o $@ -impl odyl_main.ppo + rm -f odyl_main.ppo + +odyl_config.ml: + (echo '(* camlp4r *)'; \ + echo 'value standard_library ='; \ + echo ' try Sys.getenv "CAMLP4LIB" with [ Not_found -> '; \ + echo ' try Sys.getenv "OCAMLLIB" ^ "/camlp4" with [ Not_found -> '; \ + echo ' try Sys.getenv "CAMLLIB" ^ "/camlp4" with [ Not_found -> '; \ + echo ' "$(LIBDIR)/camlp4"]]];') \ + | sed -e 's|\\|/|g' > odyl_config.ml + +install-local: + -$(MKDIR) "$(LIBDIR)/camlp4" "$(BINDIR)" + cp odyl.cmo odyl.cma odyl_main.cmi $(LIBDIR)/camlp4/. + for f in odyl.$(A) odyl.p.$(A) ; do \ + if test -f $$f ; then \ + cp $$f "$(LIBDIR)/camlp4/." && ( cd "$(LIBDIR)/camlp4/." && $(RANLIB) $$f ) ; \ + fi ; \ + done + for f in odyl.cmx odyl.o odyl.p.cmx odyl.p.o odyl.cmxa odyl.p.cmxa ; do \ + if test -f $$f ; then \ + cp $$f "$(LIBDIR)/camlp4/." ; \ + fi ; \ + done + +include .depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/odyl/odyl.ml b/ocaml-binary-annot/camlp4/unmaintained/odyl/odyl.ml new file mode 100644 index 0000000000..23b7136c97 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/odyl/odyl.ml @@ -0,0 +1,57 @@ +(* camlp4r *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2001 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + + + +value apply_load () = + let i = ref 1 in + let stop = ref False in + while not stop.val && i.val < Array.length Sys.argv do { + let s = Sys.argv.(i.val) in + if s = "-I" && i.val + 1 < Array.length Sys.argv then do { + Odyl_main.directory Sys.argv.(i.val + 1); + i.val := i.val + 2 + } + else if s = "-nolib" then do { Odyl_main.nolib.val := True; incr i } + else if s = "-where" then do { + print_string Odyl_config.standard_library; + print_newline (); + flush stdout; + exit 0 + } + else if s = "-version" then do { + print_string Sys.ocaml_version; + print_newline (); + flush stdout; + exit 0 + } + else if s = "--" then do { incr i; stop.val := True; () } + else if String.length s > 0 && s.[0] == '-' then stop.val := True + else if Filename.check_suffix s ".cmo" || Filename.check_suffix s ".cma" + then do { Odyl_main.loadfile s; incr i } + else stop.val := True + } +; + +value main () = + try do { apply_load () ; Odyl_main.go.val () } with + [ Odyl_main.Error fname str -> + do { + flush stdout; + Printf.eprintf "Error while loading \"%s\": " fname; + Printf.eprintf "%s.\n" str; + flush stderr; + exit 2 + } ] +; + +Printexc.catch main (); diff --git a/ocaml-binary-annot/camlp4/unmaintained/odyl/odyl_main.mli b/ocaml-binary-annot/camlp4/unmaintained/odyl/odyl_main.mli new file mode 100644 index 0000000000..122c9335a8 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/odyl/odyl_main.mli @@ -0,0 +1,13 @@ +(* camlp4r *) + + +exception Error of string and string; + +value nolib : ref bool; +value initialized : ref bool; +value path : ref (list string); +value loadfile : string -> unit; +value directory : string -> unit; + +value go : ref (unit -> unit); +value name : ref string; diff --git a/ocaml-binary-annot/camlp4/unmaintained/olabl/.depend b/ocaml-binary-annot/camlp4/unmaintained/olabl/.depend new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/olabl/.depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/olabl/Makefile b/ocaml-binary-annot/camlp4/unmaintained/olabl/Makefile new file mode 100644 index 0000000000..f928d4589f --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/olabl/Makefile @@ -0,0 +1,61 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# Makefile for pa_lefteval +# M.Mauny +# + +include ../../config/Makefile.cnf + +OCAMLTOP=../../.. +CAMLP4=../../camlp4/camlp4$(EXE) + +OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) +OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) + +P4INCLUDES= -nolib -I ../../meta -I ../../lib -I ../../etc +OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../lib -I ../../camlp4 +OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) + +SRC=pa_olabl.ml +OBJS=$(SRC:.ml=.cmo) +OBJSX=$(SRC:.ml=.cmx) + +all: $(OBJS) + +opt: $(OBJSX) + +depend: + cp .depend .depend.bak + > .depend + for file in $(SRC); do \ + $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ + sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ + done + +clean: + rm -f *.cm* *.$(O) *.bak .*.bak + + +.SUFFIXES: .cmx .cmo .cmi .ml .mli + +.mli.cmi: + $(OCAMLC) $(OCAMLCFLAGS) -c $< + + +.ml.cmo: + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +include .depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/olabl/README b/ocaml-binary-annot/camlp4/unmaintained/olabl/README new file mode 100644 index 0000000000..809d42f2a8 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/olabl/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + diff --git a/ocaml-binary-annot/camlp4/unmaintained/olabl/pa_olabl.ml b/ocaml-binary-annot/camlp4/unmaintained/olabl/pa_olabl.ml new file mode 100644 index 0000000000..285902a144 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/olabl/pa_olabl.ml @@ -0,0 +1,2022 @@ +(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file *) +(* ../../../LICENSE. *) +(* *) +(***********************************************************************) + + + +module Plexer = + struct + open Stdpp; + open Token; + value buff = ref (String.create 80); + value store len x = + do { + if len >= String.length buff.val then + buff.val := buff.val ^ String.create (String.length buff.val) + else (); + buff.val.[len] := x; + succ len + } + ; + value mstore len s = + add_rec len 0 where rec add_rec len i = + if i == String.length s then len + else add_rec (store len s.[i]) (succ i) + ; + value get_buff len = String.sub buff.val 0 len; + value rec ident len = + parser + [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | + '\248'..'\255' | '0'..'9' | '_' | ''' as + c) + ; + s :] -> + ident (store len c) s + | [: :] -> len ] + and ident2 len = + parser + [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | + '%' | '.' | ':' | '<' | '>' | '|' as + c) + ; + s :] -> + ident2 (store len c) s + | [: :] -> len ] + and ident3 len = + parser + [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | + '\216'..'\246' | '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | + '+' | '-' | '.' | '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | + '|' | '~' | ''' | '$' as + c) + ; + s :] -> + ident3 (store len c) s + | [: :] -> len ] + and ident4 len = + parser + [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | + '%' | '.' | '<' | '>' | '|' as + c) + ; + s :] -> + ident4 (store len c) s + | [: :] -> len ] + and base_number len = + parser + [ [: `'o' | 'O'; s :] -> octal_digits (store len 'o') s + | [: `'x' | 'X'; s :] -> hexa_digits (store len 'x') s + | [: `'b' | 'B'; s :] -> binary_digits (store len 'b') s + | [: a = number len :] -> a ] + and octal_digits len = + parser + [ [: `('0'..'7' as d); s :] -> octal_digits (store len d) s + | [: :] -> ("INT", get_buff len) ] + and hexa_digits len = + parser + [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d); s :] -> + hexa_digits (store len d) s + | [: :] -> ("INT", get_buff len) ] + and binary_digits len = + parser + [ [: `('0'..'1' as d); s :] -> binary_digits (store len d) s + | [: :] -> ("INT", get_buff len) ] + and number len = + parser + [ [: `('0'..'9' as c); s :] -> number (store len c) s + | [: `'.'; s :] -> decimal_part (store len '.') s + | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s + | [: :] -> ("INT", get_buff len) ] + and decimal_part len = + parser + [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s + | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s + | [: :] -> ("FLOAT", get_buff len) ] + and exponent_part len = + parser + [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s + | [: a = end_exponent_part len :] -> a ] + and end_exponent_part len = + parser + [ [: `('0'..'9' as c); s :] -> end_exponent_part (store len c) s + | [: :] -> ("FLOAT", get_buff len) ] + ; + value valch x = Char.code x - Char.code '0'; + value rec backslash s i = + if i = String.length s then raise Not_found + else + match s.[i] with + [ 'n' -> ('\n', i + 1) + | 'r' -> ('\r', i + 1) + | 't' -> ('\t', i + 1) + | 'b' -> ('\b', i + 1) + | '\\' -> ('\\', i + 1) + | '0'..'9' as c -> backslash1 (valch c) s (i + 1) + | _ -> raise Not_found ] + and backslash1 cod s i = + if i = String.length s then (Char.chr cod, i) + else + match s.[i] with + [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1) + | _ -> (Char.chr cod, i) ] + and backslash2 cod s i = + if i = String.length s then (Char.chr cod, i) + else + match s.[i] with + [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1) + | _ -> (Char.chr cod, i) ] + ; + value rec skip_indent s i = + if i = String.length s then i + else + match s.[i] with + [ ' ' | '\t' -> skip_indent s (i + 1) + | _ -> i ] + ; + value skip_opt_linefeed s i = + if i = String.length s then i else if s.[i] = '\010' then i + 1 else i + ; + value char_of_char_token s = + if String.length s = 1 then s.[0] + else if String.length s = 0 then failwith "invalid char token" + else if s.[0] = '\\' then + if String.length s = 2 && s.[1] = ''' then ''' + else + try + let (c, i) = backslash s 1 in + if i = String.length s then c else raise Not_found + with + [ Not_found -> failwith "invalid char token" ] + else failwith "invalid char token" + ; + value string_of_string_token s = + loop 0 0 where rec loop len i = + if i = String.length s then get_buff len + else + let (len, i) = + if s.[i] = '\\' then + let i = i + 1 in + if i = String.length s then failwith "invalid string token" + else if s.[i] = '"' then (store len '"', i + 1) + else + match s.[i] with + [ '\010' -> (len, skip_indent s (i + 1)) + | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1))) + | c -> + try + let (c, i) = backslash s i in + (store len c, i) + with + [ Not_found -> (store (store len '\\') c, i + 1) ] ] + else (store len s.[i], i + 1) + in + loop len i + ; + value rec skip_spaces = + parser + [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> skip_spaces s + | [: :] -> () ] + ; + value error_on_unknown_keywords = ref False; + value next_token_fun find_id_kwd find_spe_kwd fname lnum bolpos = + let make_pos p = + {Lexing.pos_fname = fname.val; Lexing.pos_lnum = lnum.val; + Lexing.pos_bol = bolpos.val; Lexing.pos_cnum = p} in + let mkloc (bp, ep) = (make_pos bp, make_pos ep) in + + let err loc msg = raise_with_loc loc (Token.Error msg) in + let keyword_or_error (bp,ep) s = + try ("", find_spe_kwd s) with + [ Not_found -> + if error_on_unknown_keywords.val then + err (mkloc (bp, ep)) ("illegal token: " ^ s) + else ("", s) ] + in + let rec next_token = + parser bp + [ [: `('A'..'Z' | 'À'..'Ö' | 'Ø'..'Þ' as c); s :] -> + let id = get_buff (ident (store 0 c) s) in + try ("", find_id_kwd id) with [ Not_found -> ("UIDENT", id) ] + | [: `('a'..'z' | 'ß'..'ö' | 'ø'..'ÿ' | '_' as c); s :] -> + let id = get_buff (ident (store 0 c) s) in + let is_label = + match Stream.peek s with + [ Some ':' -> + match Stream.npeek 2 s with + [ [_; ':' | '=' | '>'] -> False + | _ -> True ] + | _ -> False ] + in + if is_label then do { Stream.junk s; ("LABEL", id) } + else try ("", find_id_kwd id) with [ Not_found -> ("LIDENT", id) ] + | [: `('1'..'9' as c); s :] -> number (store 0 c) s + | [: `'0'; s :] -> base_number (store 0 '0') s + | [: `'''; s :] ep -> + match Stream.npeek 2 s with + [ [_; '''] | ['\\'; _] -> ("CHAR", char bp 0 s) + | _ -> keyword_or_error (bp, ep) "'" ] + | [: `'"'; s :] -> ("STRING", string bp 0 s) + | [: `'$'; s :] -> locate_or_antiquot bp 0 s + | [: `('!' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | + '%' as + c) + ; + s :] -> + let id = get_buff (ident2 (store 0 c) s) in + keyword_or_error (bp, Stream.count s) id + | [: `('?' as c); s :] -> + let id = get_buff (ident4 (store 0 c) s) in + keyword_or_error (bp, Stream.count s) id + | [: `'<'; s :] -> less bp s + | [: `(':' as c1); + (is_label, len) = + parser + [ [: `(']' | ':' | '=' | '>' as c2) :] -> + (False, store (store 0 c1) c2) + | [: `('a'..'z' | 'ß'..'ö' | 'ø'..'ÿ' | '_' as c); s :] -> + (True, ident (store 0 c) s) + | [: :] -> (False, store 0 c1) ] :] ep -> + let id = get_buff len in + if is_label then ("ELABEL", id) else keyword_or_error (bp, ep) id + | [: `('>' | '|' as c1); + len = + parser + [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2 + | [: a = ident2 (store 0 c1) :] -> a ] :] ep -> + let id = get_buff len in + keyword_or_error (bp, ep) id + | [: `('[' | '{' as c1); s :] -> + let len = + match Stream.npeek 2 s with + [ ['<'; '<' | ':'] -> store 0 c1 + | _ -> + match s with parser + [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2 + | [: :] -> store 0 c1 ] ] + in + let ep = Stream.count s in + let id = get_buff len in + keyword_or_error (bp, ep) id + | [: `'.'; id = parser [ [: `'.' :] -> ".." | [: :] -> "." ] :] ep -> + keyword_or_error (bp, ep) id + | [: `';'; id = parser [ [: `';' :] -> ";;" | [: :] -> ";" ] :] ep -> + keyword_or_error (bp, ep) id + | [: `'\\'; s :] -> ("LIDENT", get_buff (ident3 0 s)) + | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c) ] + and less bp = + parser + [ [: `'<'; s :] -> ("QUOTATION", ":" ^ get_buff (quotation bp 0 s)) + | [: `':'; i = parser [: len = ident 0 :] -> get_buff len; + `'<' ? "character '<' expected"; s :] -> + ("QUOTATION", i ^ ":" ^ get_buff (quotation bp 0 s)) + | [: s :] ep -> + let id = get_buff (ident2 (store 0 '<') s) in + keyword_or_error (bp, ep) id ] + and string bp len = + parser + [ [: `'"' :] -> get_buff len + | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s + | [: `c; s :] -> string bp (store len c) s + | [: :] ep -> err (mkloc (bp, ep)) "string not terminated" ] + and char bp len = + parser + [ [: `'''; s :] -> + if len = 0 then char bp (store len ''') s else get_buff len + | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s + | [: `c; s :] -> char bp (store len c) s + | [: :] ep -> err (mkloc(bp,ep)) "char not terminated" ] + and locate_or_antiquot bp len = + parser + [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) + | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s + | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s + | [: `':'; s :] -> + let k = get_buff len in + ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) + | [: `'\\'; `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] + and maybe_locate bp len = + parser + [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) + | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s + | [: `':'; s :] -> + ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s) + | [: `'\\'; `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] + and antiquot bp len = + parser + [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len) + | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] -> + antiquot bp (store len c) s + | [: `':'; s :] -> + let k = get_buff len in + ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s) + | [: `'\\'; `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: `c; s :] -> + ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s) + | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] + and locate_or_antiquot_rest bp len = + parser + [ [: `'$' :] -> get_buff len + | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s + | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s + | [: :] ep -> err (mkloc(bp,ep)) "antiquotation not terminated" ] + and quotation bp len = + parser + [ [: `'>'; s :] -> maybe_end_quotation bp len s + | [: `'<'; s :] -> + quotation bp (maybe_nested_quotation bp (store len '<') __strm) s + | [: `'\\'; + len = + parser + [ [: `('>' | '<' | '\\' as c) :] -> store len c + | [: :] -> store len '\\' ]; + s :] -> + quotation bp len s + | [: `c; s :] -> quotation bp (store len c) s + | [: :] ep -> err (mkloc(bp,ep)) "quotation not terminated" ] + and maybe_nested_quotation bp len = + parser + [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" + | [: `':'; len = ident (store len ':'); + a = + parser + [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>" + | [: :] -> len ] :] -> + a + | [: :] -> len ] + and maybe_end_quotation bp len = + parser + [ [: `'>' :] -> len + | [: a = quotation bp (store len '>') :] -> a ] + in + let rec next_token_loc = + parser bp + [ [: `' ' | '\n' | '\r' | '\t' | '\026' | '\012'; s :] -> + next_token_loc s + | [: `'('; s :] -> maybe_comment bp s + | [: `'#'; _ = spaces_tabs; a = linenum bp :] -> a + | [: tok = next_token :] ep -> (tok, mkloc(bp, ep)) + | [: _ = Stream.empty :] -> (("EOI", ""), mkloc(bp, succ bp)) ] + and maybe_comment bp = + parser + [ [: `'*'; s :] -> do { comment bp s; next_token_loc s } + | [: :] ep -> + let tok = keyword_or_error (bp, ep) "(" in + (tok, mkloc(bp, ep)) ] + and comment bp = + parser + [ [: `'('; s :] -> maybe_nested_comment bp s + | [: `'*'; s :] -> maybe_end_comment bp s + | [: `c; s :] -> comment bp s + | [: :] ep -> err (mkloc(bp,ep)) "comment not terminated" ] + and maybe_nested_comment bp = + parser + [ [: `'*'; s :] -> do { comment bp s; comment bp s } + | [: a = comment bp :] -> a ] + and maybe_end_comment bp = + parser [ [: `')' :] -> () | [: a = comment bp :] -> a ] + and linenum bp = + parser + [ [: `'0'..'9'; _ = digits; _ = spaces_tabs; `'"'; _ = any_to_nl; + s :] -> + next_token_loc s + | [: :] -> (keyword_or_error (bp, bp + 1) "#", mkloc(bp, bp + 1)) ] + and spaces_tabs = + parser [ [: `' ' | '\t'; s :] -> spaces_tabs s | [: :] -> () ] + and digits = parser [ [: `'0'..'9'; s :] -> digits s | [: :] -> () ] + and any_to_nl = + parser + [ [: `'\r' | '\n' :] -> () + | [: `_; s :] -> any_to_nl s + | [: :] -> () ] + in + fun cstrm -> + try next_token_loc cstrm with + [ Stream.Error str -> + err (mkloc(Stream.count cstrm, Stream.count cstrm + 1)) str ] + ; + value locerr () = invalid_arg "Lexer: location function"; + value loct_create () = ref (Array.create 1024 None); + value loct_func loct i = + match + if i < 0 || i >= Array.length loct.val then None + else Array.unsafe_get loct.val i + with + [ Some loc -> loc + | _ -> locerr () ] + ; + value loct_add loct i loc = + do { + if i >= Array.length loct.val then do { + let new_tmax = Array.length loct.val * 2 in + let new_loct = Array.create new_tmax None in + Array.blit loct.val 0 new_loct 0 (Array.length loct.val); + loct.val := new_loct + } + else (); + loct.val.(i) := Some loc + } + ; + value func kwd_table = + let bolpos = ref 0 in + let lnum = ref 0 in + let fname = ref "" in + let find = Hashtbl.find kwd_table in + let lex cstrm = + let next_token_loc = next_token_fun find find fname lnum bolpos in + let loct = loct_create () in + let ts = + Stream.from + (fun i -> + let (tok, loc) = next_token_loc cstrm in + do { loct_add loct i loc; Some tok }) + in + let locf = loct_func loct in + (ts, locf) + in + lex + ; + value rec check_keyword_stream = + parser [: _ = check; _ = Stream.empty :] -> True + and check = + parser + [ [: `'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ'; s :] -> + check_ident s + | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | + '%' | '.' + ; + s :] -> + check_ident2 s + | [: `'<'; s :] -> + match Stream.npeek 1 s with + [ [':' | '<'] -> () + | _ -> check_ident2 s ] + | [: `':'; + _ = + parser + [ [: `']' | ':' | '=' | '>' :] -> () + | [: :] -> () ] :] ep -> + () + | [: `'>' | '|'; + _ = + parser + [ [: `']' | '}' :] -> () + | [: a = check_ident2 :] -> a ] :] -> + () + | [: `'[' | '{'; s :] -> + match Stream.npeek 2 s with + [ ['<'; '<' | ':'] -> () + | _ -> + match s with parser + [ [: :] -> + match Stream.peek __strm with + [ Some ('|' | '<' | ':') -> Stream.junk __strm + | _ -> () ] ] ] + | [: `';'; _ = parser [ [: `';' :] -> () | [: :] -> () ] :] -> () + | [: `_ :] -> () ] + and check_ident = + parser + [ [: `'A'..'Z' | 'a'..'z' | 'À'..'Ö' | 'Ø'..'ö' | 'ø'..'ÿ' | '0'..'9' | + '_' | ''' + ; + s :] -> + check_ident s + | [: :] -> () ] + and check_ident2 = + parser + [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | + '%' | '.' | ':' | '<' | '>' | '|' + ; + s :] -> + check_ident2 s + | [: :] -> () ] + ; + value check_keyword s = + try check_keyword_stream (Stream.of_string s) with _ -> False + ; + value using_token kwd_table (p_con, p_prm) = + match p_con with + [ "" -> + try + let _ = Hashtbl.find kwd_table p_prm in + () + with + [ Not_found -> + if check_keyword p_prm then Hashtbl.add kwd_table p_prm p_prm + else + raise + (Token.Error + ("the token \"" ^ p_prm ^ + "\" does not respect Plexer rules")) ] + | "LIDENT" | "UIDENT" | "INT" | "FLOAT" | "CHAR" | "STRING" | + "QUOTATION" | "ANTIQUOT" | "LOCATE" | "LABEL" | "ELABEL" | "EOI" -> + () + | _ -> + raise + (Token.Error + ("the constructor \"" ^ p_con ^ + "\" is not recognized by Llexer")) ] + ; + value removing_token kwd_table (p_con, p_prm) = + if p_con = "" then Hashtbl.remove kwd_table p_prm else () + ; + value text = + fun + [ ("", t) -> "'" ^ t ^ "'" + | ("LIDENT", "") -> "lowercase identifier" + | ("LIDENT", t) -> "'" ^ t ^ "'" + | ("UIDENT", "") -> "uppercase identifier" + | ("UIDENT", t) -> "'" ^ t ^ "'" + | ("INT", "") -> "integer" + | ("INT", s) -> "'" ^ s ^ "'" + | ("FLOAT", "") -> "float" + | ("STRING", "") -> "string" + | ("CHAR", "") -> "char" + | ("QUOTATION", "") -> "quotation" + | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\"" + | ("LOCATE", "") -> "locate" + | ("LABEL", "") -> "label" + | ("ELABEL", "") -> "elabel" + | ("EOI", "") -> "end of input" + | (con, "") -> con + | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ] + ; + value eq_before_colon p e = + loop 0 where rec loop i = + if i == String.length e then + failwith "Internal error in Plexer: incorrect ANTIQUOT" + else if i == String.length p then e.[i] == ':' + else if p.[i] == e.[i] then loop (i + 1) + else False + ; + value after_colon e = + try + let i = String.index e ':' in + String.sub e (i + 1) (String.length e - i - 1) + with + [ Not_found -> "" ] + ; + value gmake () = + let kwd_table = Hashtbl.create 301 in + {tok_func = func kwd_table; tok_using = using_token kwd_table; + tok_removing = removing_token kwd_table; + tok_match = Token.default_match; tok_text = text; tok_comm = None} + ; + end +; + +open Stdpp; +open Pcaml; + +Pcaml.no_constructors_arity.val := True; + +do { + Grammar.Unsafe.gram_reinit gram (Plexer.gmake ()); + Grammar.Unsafe.clear_entry interf; + Grammar.Unsafe.clear_entry implem; + Grammar.Unsafe.clear_entry top_phrase; + Grammar.Unsafe.clear_entry use_file; + Grammar.Unsafe.clear_entry module_type; + Grammar.Unsafe.clear_entry module_expr; + Grammar.Unsafe.clear_entry sig_item; + Grammar.Unsafe.clear_entry str_item; + Grammar.Unsafe.clear_entry expr; + Grammar.Unsafe.clear_entry patt; + Grammar.Unsafe.clear_entry ctyp; + Grammar.Unsafe.clear_entry let_binding; + Grammar.Unsafe.clear_entry class_type; + Grammar.Unsafe.clear_entry class_expr; + Grammar.Unsafe.clear_entry class_sig_item; + Grammar.Unsafe.clear_entry class_str_item +}; + +Pcaml.parse_interf.val := Grammar.Entry.parse interf; +Pcaml.parse_implem.val := Grammar.Entry.parse implem; + +value o2b = + fun + [ Some _ -> True + | None -> False ] +; + +value mkumin loc f arg = + match arg with + [ <:expr< $int:n$ >> when int_of_string n > 0 -> + let n = "-" ^ n in + <:expr< $int:n$ >> + | <:expr< $flo:n$ >> when float_of_string n > 0.0 -> + let n = "-" ^ n in + <:expr< $flo:n$ >> + | _ -> + let f = "~" ^ f in + <:expr< $lid:f$ $arg$ >> ] +; + +external loc_of_node : 'a -> Loc.t = "%field0"; + +value mklistexp loc last = + loop True where rec loop top = + fun + [ [] -> + match last with + [ Some e -> e + | None -> <:expr< [] >> ] + | [e1 :: el] -> + let loc = if top then loc else (fst (loc_of_node e1), snd loc) in + <:expr< [$e1$ :: $loop False el$] >> ] +; + +value mklistpat loc last = + loop True where rec loop top = + fun + [ [] -> + match last with + [ Some p -> p + | None -> <:patt< [] >> ] + | [p1 :: pl] -> + let loc = if top then loc else (fst (loc_of_node p1), snd loc) in + <:patt< [$p1$ :: $loop False pl$] >> ] +; + +value neg s = string_of_int (- int_of_string s); + +value is_operator = + let ht = Hashtbl.create 73 in + let ct = Hashtbl.create 73 in + do { + List.iter (fun x -> Hashtbl.add ht x True) + ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"]; + List.iter (fun x -> Hashtbl.add ct x True) + ['!'; '&'; '*'; '+'; '-'; '/'; ':'; '<'; '='; '>'; '@'; '^'; '|'; '~'; + '?'; '%'; '.']; + fun x -> + try Hashtbl.find ht x with + [ Not_found -> try Hashtbl.find ct x.[0] with _ -> False ] + } +; + +(* +value p_operator strm = + match Stream.peek strm with + [ Some (Token.Tterm "(") -> + match Stream.npeek 3 strm with + [ [_; Token.Tterm x; Token.Tterm ")"] when is_operator x -> + do { Stream.junk strm; Stream.junk strm; Stream.junk strm; x } + | _ -> raise Stream.Failure ] + | _ -> raise Stream.Failure ] +; + +value operator = Grammar.Entry.of_parser gram "operator" p_operator; +*) + +value operator = + Grammar.Entry.of_parser gram "operator" + (parser [: `("", x) when is_operator x :] -> x) +; + +value symbolchar = + let list = + ['!'; '$'; '%'; '&'; '*'; '+'; '-'; '.'; '/'; ':'; '<'; '='; '>'; '?'; + '@'; '^'; '|'; '~'] + in + let rec loop s i = + if i == String.length s then True + else if List.mem s.[i] list then loop s (i + 1) + else False + in + loop +; + +value prefixop = + let list = ['!'; '?'; '~'] in + let excl = ["!="] in + Grammar.Entry.of_parser gram "prefixop" + (parser + [: `("", x) + when + not (List.mem x excl) && String.length x >= 2 && + List.mem x.[0] list && symbolchar x 1 :] -> + x) +; + +value infixop0 = + let list = ['='; '<'; '>'; '|'; '&'; '$'] in + let excl = ["<-"; "||"; "&&"] in + Grammar.Entry.of_parser gram "infixop0" + (parser + [: `("", x) + when + not (List.mem x excl) && String.length x >= 2 && + List.mem x.[0] list && symbolchar x 1 :] -> + x) +; + +value infixop1 = + let list = ['@'; '^'] in + Grammar.Entry.of_parser gram "infixop1" + (parser + [: `("", x) + when + String.length x >= 2 && List.mem x.[0] list && + symbolchar x 1 :] -> + x) +; + +value infixop2 = + let list = ['+'; '-'] in + Grammar.Entry.of_parser gram "infixop2" + (parser + [: `("", x) + when + x <> "->" && String.length x >= 2 && List.mem x.[0] list && + symbolchar x 1 :] -> + x) +; + +value infixop3 = + let list = ['*'; '/'; '%'] in + Grammar.Entry.of_parser gram "infixop3" + (parser + [: `("", x) + when + String.length x >= 2 && List.mem x.[0] list && + symbolchar x 1 :] -> + x) +; + +value infixop4 = + Grammar.Entry.of_parser gram "infixop4" + (parser + [: `("", x) + when + String.length x >= 3 && x.[0] == '*' && x.[1] == '*' && + symbolchar x 2 :] -> + x) +; + +value test_constr_decl = + Grammar.Entry.of_parser gram "test_constr_decl" + (fun strm -> + match Stream.npeek 1 strm with + [ [("UIDENT", _)] -> + match Stream.npeek 2 strm with + [ [_; ("", ".")] -> raise Stream.Failure + | [_; ("", "(")] -> raise Stream.Failure + | [_ :: _] -> () + | _ -> raise Stream.Failure ] + | [("", "|")] -> () + | _ -> raise Stream.Failure ]) +; + +value stream_peek_nth n strm = + loop n (Stream.npeek n strm) where rec loop n = + fun + [ [] -> None + | [x] -> if n == 1 then Some x else None + | [_ :: l] -> loop (n - 1) l ] +; + +value test_label_eq = + let rec test lev strm = + match stream_peek_nth lev strm with + [ Some (("UIDENT", _) | ("LIDENT", _) | ("", ".")) -> test (lev + 1) strm + | Some ("", "=") -> () + | _ -> raise Stream.Failure ] + in + Grammar.Entry.of_parser gram "test_label_eq" (test 1) +; + +value constr_arity = ref [("Some", 1); ("Match_Failure", 1)]; + +value rec constr_expr_arity = + fun + [ <:expr< $uid:c$ >> -> + try List.assoc c constr_arity.val with [ Not_found -> 0 ] + | <:expr< $uid:_$.$e$ >> -> constr_expr_arity e + | _ -> 1 ] +; + +value rec constr_patt_arity = + fun + [ <:patt< $uid:c$ >> -> + try List.assoc c constr_arity.val with [ Not_found -> 0 ] + | <:patt< $uid:_$.$p$ >> -> constr_patt_arity p + | _ -> 1 ] +; + +value rec get_seq = + fun + [ <:expr< do { $list:el$ } >> -> el + | e -> [e] ] +; + +value choose_tvar tpl = + let rec find_alpha v = + let s = String.make 1 v in + if List.mem_assoc s tpl then + if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1)) + else Some (String.make 1 v) + in + let rec make_n n = + let v = "a" ^ string_of_int n in + if List.mem_assoc v tpl then make_n (succ n) else v + in + match find_alpha 'a' with + [ Some x -> x + | None -> make_n 1 ] +; + +value rec patt_lid = + fun + [ <:patt< $lid:i$ $p$ >> -> Some (i, [p]) + | <:patt< $p1$ $p2$ >> -> + match patt_lid p1 with + [ Some (i, pl) -> Some (i, [p2 :: pl]) + | None -> None ] + | _ -> None ] +; + +value type_parameter = Grammar.Entry.create gram "type_parameter"; +value fun_def = Grammar.Entry.create gram "fun_def"; +value fun_binding = Grammar.Entry.create gram "fun_binding"; + +EXTEND + GLOBAL: interf implem top_phrase use_file sig_item str_item ctyp patt expr + module_type module_expr let_binding type_parameter fun_def fun_binding; + (* Main entry points *) + interf: + [ [ st = LIST0 [ s = sig_item; OPT ";;" -> (s, loc) ]; EOI -> + (st, False) ] ] + ; + implem: + [ [ st = LIST0 [ s = str_item; OPT ";;" -> (s, loc) ]; EOI -> + (st, False) ] ] + ; + top_phrase: + [ [ ph = phrase; ";;" -> Some ph + | EOI -> None ] ] + ; + use_file: + [ [ l = LIST0 [ ph = phrase; OPT ";;" -> ph ]; EOI -> (l, False) ] ] + ; + phrase: + [ [ sti = str_item -> sti + | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ] + ; + dir_param: + [ [ -> None + | e = expr -> Some e ] ] + ; + (* Module expressions *) + module_expr: + [ [ "functor"; "("; i = UIDENT; ":"; t = module_type; ")"; "->"; + me = SELF -> + <:module_expr< functor ( $i$ : $t$ ) -> $me$ >> + | "struct"; st = LIST0 [ s = str_item; OPT ";;" -> s ]; "end" -> + <:module_expr< struct $list:st$ end >> ] + | [ me1 = SELF; me2 = SELF -> <:module_expr< $me1$ $me2$ >> ] + | [ i = mod_expr_ident -> i + | "("; me = SELF; ":"; mt = module_type; ")" -> + <:module_expr< ( $me$ : $mt$ ) >> + | "("; me = SELF; ")" -> <:module_expr< $me$ >> ] ] + ; + mod_expr_ident: + [ LEFTA + [ m1 = SELF; "."; m2 = SELF -> <:module_expr< $m1$ . $m2$ >> ] + | [ m = UIDENT -> <:module_expr< $uid:m$ >> ] ] + ; + str_item: + [ "top" + [ "exception"; (_, c, tl) = constructor_declaration -> + <:str_item< exception $c$ of $list:tl$ >> + | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> + <:str_item< external $i$ : $t$ = $list:pd$ >> + | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING -> + <:str_item< external $i$ : $t$ = $list:pd$ >> + | "external"; "("; i = operator; ")"; ":"; t = ctyp; "="; + pd = LIST1 STRING -> + <:str_item< external $i$ : $t$ = $list:pd$ >> + | "module"; i = UIDENT; mb = module_binding -> + <:str_item< module $i$ = $mb$ >> + | "module"; "type"; i = UIDENT; "="; mt = module_type -> + <:str_item< module type $i$ = $mt$ >> + | "open"; i = mod_ident -> <:str_item< open $i$ >> + | "type"; tdl = LIST1 type_declaration SEP "and" -> + <:str_item< type $list:tdl$ >> + | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; + x = expr -> + let e = <:expr< let $opt:o2b r$ $list:l$ in $x$ >> in + <:str_item< $exp:e$ >> + | "let"; r = OPT "rec"; l = LIST1 let_binding SEP "and" -> + match l with + [ [(<:patt< _ >>, e)] -> <:str_item< $exp:e$ >> + | _ -> <:str_item< value $opt:o2b r$ $list:l$ >> ] + | "let"; "module"; m = UIDENT; mb = module_binding; "in"; e = expr -> + <:str_item< let module $m$ = $mb$ in $e$ >> + | e = expr -> <:str_item< $exp:e$ >> ] ] + ; + module_binding: + [ RIGHTA + [ "("; m = UIDENT; ":"; mt = module_type; ")"; mb = SELF -> + <:module_expr< functor ( $m$ : $mt$ ) -> $mb$ >> + | ":"; mt = module_type; "="; me = module_expr -> + <:module_expr< ( $me$ : $mt$ ) >> + | "="; me = module_expr -> <:module_expr< $me$ >> ] ] + ; + (* Module types *) + module_type: + [ [ "functor"; "("; i = UIDENT; ":"; t = SELF; ")"; "->"; mt = SELF -> + <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] + | [ mt = SELF; "with"; wcl = LIST1 with_constr SEP "and" -> + <:module_type< $mt$ with $list:wcl$ >> ] + | [ "sig"; sg = LIST0 [ s = sig_item; OPT ";;" -> s ]; "end" -> + <:module_type< sig $list:sg$ end >> + | i = mod_type_ident -> i + | "("; mt = SELF; ")" -> <:module_type< $mt$ >> ] ] + ; + mod_type_ident: + [ LEFTA + [ m1 = SELF; "."; m2 = SELF -> <:module_type< $m1$ . $m2$ >> + | m1 = SELF; "("; m2 = SELF; ")" -> <:module_type< $m1$ $m2$ >> ] + | [ m = UIDENT -> <:module_type< $uid:m$ >> + | m = LIDENT -> <:module_type< $lid:m$ >> ] ] + ; + sig_item: + [ "top" + [ "exception"; (_, c, tl) = constructor_declaration -> + <:sig_item< exception $c$ of $list:tl$ >> + | "external"; i = LIDENT; ":"; t = ctyp; "="; pd = LIST1 STRING -> + <:sig_item< external $i$ : $t$ = $list:pd$ >> + | "external"; i = LABEL; t = ctyp; "="; pd = LIST1 STRING -> + <:sig_item< external $i$ : $t$ = $list:pd$ >> + | "external"; "("; i = operator; ")"; ":"; t = ctyp; "="; + pd = LIST1 STRING -> + <:sig_item< external $i$ : $t$ = $list:pd$ >> + | "include"; mt = module_type -> <:sig_item< include $mt$ >> + | "module"; i = UIDENT; mt = module_declaration -> + <:sig_item< module $i$ : $mt$ >> + | "module"; "type"; i = UIDENT; "="; mt = module_type -> + <:sig_item< module type $i$ = $mt$ >> + | "open"; i = mod_ident -> <:sig_item< open $i$ >> + | "type"; tdl = LIST1 type_declaration SEP "and" -> + <:sig_item< type $list:tdl$ >> + | "val"; i = LIDENT; ":"; t = ctyp -> <:sig_item< value $i$ : $t$ >> + | "val"; i = LABEL; t = ctyp -> <:sig_item< value $i$ : $t$ >> + | "val"; "("; i = operator; ")"; ":"; t = ctyp -> + <:sig_item< value $i$ : $t$ >> ] ] + ; + module_declaration: + [ RIGHTA + [ ":"; mt = module_type -> <:module_type< $mt$ >> + | "("; i = UIDENT; ":"; t = module_type; ")"; mt = SELF -> + <:module_type< functor ( $i$ : $t$ ) -> $mt$ >> ] ] + ; + (* "with" constraints (additional type equations over signature + components) *) + with_constr: + [ [ "type"; tp = type_parameters; i = mod_ident; "="; t = ctyp -> + MLast.WcTyp loc i tp t + | "module"; i = mod_ident; "="; me = module_expr -> + MLast.WcMod loc i me ] ] + ; + (* Core expressions *) + expr: + [ "top" LEFTA + [ e1 = SELF; ";"; e2 = SELF -> + <:expr< do { $list:[e1 :: get_seq e2]$ } >> + | e1 = SELF; ";" -> e1 ] + | "expr1" + [ "let"; o = OPT "rec"; l = LIST1 let_binding SEP "and"; "in"; + x = expr LEVEL "top" -> + <:expr< let $opt:o2b o$ $list:l$ in $x$ >> + | "let"; "module"; m = UIDENT; mb = module_binding; "in"; + e = expr LEVEL "top" -> + <:expr< let module $m$ = $mb$ in $e$ >> + | "function"; OPT "|"; l = LIST1 match_case SEP "|" -> + <:expr< fun [ $list:l$ ] >> + | "fun"; p = patt LEVEL "simple"; e = fun_def -> + <:expr< fun [$p$ -> $e$] >> + | "match"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> + <:expr< match $x$ with [ $list:l$ ] >> + | "try"; x = SELF; "with"; OPT "|"; l = LIST1 match_case SEP "|" -> + <:expr< try $x$ with [ $list:l$ ] >> + | "if"; e1 = SELF; "then"; e2 = expr LEVEL "expr1"; + e3 = [ "else"; e = expr LEVEL "expr1" -> e | -> <:expr< () >> ] -> + <:expr< if $e1$ then $e2$ else $e3$ >> + | "for"; i = LIDENT; "="; e1 = SELF; df = direction_flag; e2 = SELF; + "do"; e = SELF; "done" -> + <:expr< for $i$ = $e1$ $to:df$ $e2$ do { $list:get_seq e$ } >> + | "while"; e1 = SELF; "do"; e2 = SELF; "done" -> + <:expr< while $e1$ do { $list:get_seq e2$ } >> ] + | [ e = SELF; ","; el = LIST1 NEXT SEP "," -> + <:expr< ( $list:[e :: el]$ ) >> ] + | ":=" NONA + [ e1 = SELF; ":="; e2 = expr LEVEL "expr1" -> + <:expr< $e1$.val := $e2$ >> + | e1 = SELF; "<-"; e2 = expr LEVEL "expr1" -> <:expr< $e1$ := $e2$ >> ] + | "||" RIGHTA + [ e1 = SELF; f = [ op = "or" -> op | op = "||" -> op ]; e2 = SELF -> + <:expr< $lid:f$ $e1$ $e2$ >> ] + | "&&" RIGHTA + [ e1 = SELF; f = [ op = "&" -> op | op = "&&" -> op ]; e2 = SELF -> + <:expr< $lid:f$ $e1$ $e2$ >> ] + | "<" LEFTA + [ e1 = SELF; + f = + [ op = "<" -> op + | op = ">" -> op + | op = "<=" -> op + | op = ">=" -> op + | op = "=" -> op + | op = "<>" -> op + | op = "==" -> op + | op = "!=" -> op + | op = infixop0 -> op ]; + e2 = SELF -> + <:expr< $lid:f$ $e1$ $e2$ >> ] + | "^" RIGHTA + [ e1 = SELF; + f = [ op = "^" -> op | op = "@" -> op | op = infixop1 -> op ]; + e2 = SELF -> + <:expr< $lid:f$ $e1$ $e2$ >> ] + | RIGHTA + [ e1 = SELF; "::"; e2 = SELF -> <:expr< [$e1$ :: $e2$] >> ] + | "+" LEFTA + [ e1 = SELF; + f = + [ op = "+" -> op + | op = "-" -> op + | op = "+." -> op + | op = "-." -> op + | op = infixop2 -> op ]; + e2 = SELF -> + <:expr< $lid:f$ $e1$ $e2$ >> ] + | "*" LEFTA + [ e1 = SELF; + f = + [ op = "*" -> op + | op = "/" -> op + | op = "*." -> op + | op = "/." -> op + | op = "land" -> op + | op = "lor" -> op + | op = "lxor" -> op + | op = "mod" -> op + | op = infixop3 -> op ]; + e2 = SELF -> + <:expr< $lid:f$ $e1$ $e2$ >> ] + | "**" RIGHTA + [ e1 = SELF; + f = + [ op = "**" -> op + | op = "asr" -> op + | op = "lsl" -> op + | op = "lsr" -> op + | op = infixop4 -> op ]; + e2 = SELF -> + <:expr< $lid:f$ $e1$ $e2$ >> ] + | "unary minus" NONA + [ f = [ op = "-" -> op | op = "-." -> op ]; e = SELF -> + <:expr< $mkumin loc f e$ >> ] + | "apply" LEFTA + [ e1 = SELF; e2 = SELF -> + match constr_expr_arity e1 with + [ 1 -> <:expr< $e1$ $e2$ >> + | _ -> + match e2 with + [ <:expr< ( $list:el$ ) >> -> + List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) e1 el + | _ -> <:expr< $e1$ $e2$ >> ] ] + | "assert"; e = expr LEVEL "simple" -> + match e with + [ <:expr< False >> -> MLast.ExAsf loc + | _ -> MLast.ExAsr loc e ] + | "lazy"; e = SELF -> + <:expr< lazy ($e$) >> ] + | "simple" LEFTA + [ e1 = SELF; "."; "("; e2 = SELF; ")" -> <:expr< $e1$ .( $e2$ ) >> + | e1 = SELF; "."; "["; e2 = SELF; "]" -> <:expr< $e1$ .[ $e2$ ] >> + | e1 = SELF; "."; e2 = SELF -> <:expr< $e1$ . $e2$ >> + | "!"; e = SELF -> <:expr< $e$ . val>> + | f = + [ op = "~-" -> op + | op = "~-." -> op + | op = "~" -> op + | op = prefixop -> op ]; + e = SELF -> + <:expr< $lid:f$ $e$ >> + | s = INT -> <:expr< $int:s$ >> + | s = FLOAT -> <:expr< $flo:s$ >> + | s = STRING -> <:expr< $str:s$ >> + | c = CHAR -> <:expr< $chr:c$ >> + | i = expr_ident -> i + | s = "false" -> <:expr< False >> + | s = "true" -> <:expr< True >> + | "["; "]" -> <:expr< [] >> + | "["; el = expr1_semi_list; "]" -> <:expr< $mklistexp loc None el$ >> + | "[|"; "|]" -> <:expr< [| |] >> + | "[|"; el = expr1_semi_list; "|]" -> <:expr< [| $list:el$ |] >> + | "{"; test_label_eq; lel = lbl_expr_list; "}" -> + <:expr< { $list:lel$ } >> + | "{"; e = expr LEVEL "simple"; "with"; lel = lbl_expr_list; "}" -> + <:expr< { ($e$) with $list:lel$ } >> + | "("; ")" -> <:expr< () >> + | "("; e = SELF; ":"; t = ctyp; ")" -> <:expr< ($e$ : $t$) >> + | "("; e = SELF; ")" -> <:expr< $e$ >> + | "("; "-"; ")" -> <:expr< $lid:"-"$ >> + | "("; "-."; ")" -> <:expr< $lid:"-."$ >> + | "("; op = operator; ")" -> <:expr< $lid:op$ >> + | "begin"; e = SELF; "end" -> <:expr< $e$ >> + | x = LOCATE -> + let x = + try + let i = String.index x ':' in + ({Lexing.pos_fname = ""; + Lexing.pos_lnum = 0; + Lexing.pos_bol = 0; + Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, + String.sub x (i + 1) (String.length x - i - 1)) + with + [ Not_found | Failure _ -> (Token.nowhere, x) ] + in + Pcaml.handle_expr_locate loc x + | x = QUOTATION -> + let x = + try + let i = String.index x ':' in + (String.sub x 0 i, + String.sub x (i + 1) (String.length x - i - 1)) + with + [ Not_found -> ("", x) ] + in + Pcaml.handle_expr_quotation loc x ] ] + ; + let_binding: + [ [ p = patt; e = fun_binding -> + match patt_lid p with + [ Some (i, pl) -> + let e = + List.fold_left (fun e p -> <:expr< fun $p$ -> $e$ >>) e pl + in + (<:patt< $lid:i$ >>, e) + | None -> (p, e) ] ] ] + ; + fun_binding: + [ RIGHTA + [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> + | "="; e = expr -> <:expr< $e$ >> + | ":"; t = ctyp; "="; e = expr -> <:expr< ($e$ : $t$) >> ] ] + ; + match_case: + [ [ x1 = patt; w = OPT [ "when"; e = expr -> e ]; "->"; x2 = expr -> + (x1, w, x2) ] ] + ; + lbl_expr_list: + [ [ le = lbl_expr; ";"; lel = SELF -> [le :: lel] + | le = lbl_expr; ";" -> [le] + | le = lbl_expr -> [le] ] ] + ; + lbl_expr: + [ [ i = patt_label_ident; "="; e = expr LEVEL "expr1" -> (i, e) ] ] + ; + expr1_semi_list: + [ [ e = expr LEVEL "expr1"; ";"; el = SELF -> [e :: el] + | e = expr LEVEL "expr1"; ";" -> [e] + | e = expr LEVEL "expr1" -> [e] ] ] + ; + fun_def: + [ RIGHTA + [ p = patt LEVEL "simple"; e = SELF -> <:expr< fun $p$ -> $e$ >> + | "->"; e = expr -> <:expr< $e$ >> ] ] + ; + expr_ident: + [ RIGHTA + [ i = LIDENT -> <:expr< $lid:i$ >> + | i = UIDENT -> <:expr< $uid:i$ >> + | m = UIDENT; "."; i = SELF -> + let rec loop m = + fun + [ <:expr< $x$ . $y$ >> -> loop <:expr< $m$ . $x$ >> y + | e -> <:expr< $m$ . $e$ >> ] + in + loop <:expr< $uid:m$ >> i + | m = UIDENT; "."; "("; i = operator; ")" -> + <:expr< $uid:m$ . $lid:i$ >> ] ] + ; + (* Patterns *) + patt: + [ LEFTA + [ p1 = SELF; "as"; i = LIDENT -> <:patt< ($p1$ as $lid:i$) >> ] + | LEFTA + [ p1 = SELF; "|"; p2 = SELF -> <:patt< $p1$ | $p2$ >> ] + | [ p = SELF; ","; pl = LIST1 NEXT SEP "," -> + <:patt< ( $list:[p :: pl]$) >> ] + | NONA + [ p1 = SELF; ".."; p2 = SELF -> <:patt< $p1$ .. $p2$ >> ] + | RIGHTA + [ p1 = SELF; "::"; p2 = SELF -> <:patt< [$p1$ :: $p2$] >> ] + | LEFTA + [ p1 = SELF; p2 = SELF -> + match constr_patt_arity p1 with + [ 1 -> <:patt< $p1$ $p2$ >> + | n -> + let p2 = + match p2 with + [ <:patt< _ >> when n > 1 -> + let pl = + loop n where rec loop n = + if n = 0 then [] else [<:patt< _ >> :: loop (n - 1)] + in + <:patt< ( $list:pl$ ) >> + | _ -> p2 ] + in + match p2 with + [ <:patt< ( $list:pl$ ) >> -> + List.fold_left (fun p1 p2 -> <:patt< $p1$ $p2$ >>) p1 pl + | _ -> <:patt< $p1$ $p2$ >> ] ] ] + | LEFTA + [ p1 = SELF; "."; p2 = SELF -> <:patt< $p1$ . $p2$ >> ] + | "simple" + [ s = LIDENT -> <:patt< $lid:s$ >> + | s = UIDENT -> <:patt< $uid:s$ >> + | s = INT -> <:patt< $int:s$ >> + | "-"; s = INT -> <:patt< $int:neg s$ >> + | s = STRING -> <:patt< $str:s$ >> + | s = CHAR -> <:patt< $chr:s$ >> + | s = "false" -> <:patt< False >> + | s = "true" -> <:patt< True >> + | "["; "]" -> <:patt< [] >> + | "["; pl = patt_semi_list; "]" -> <:patt< $mklistpat loc None pl$ >> + | "[|"; "|]" -> <:patt< [| |] >> + | "[|"; pl = patt_semi_list; "|]" -> <:patt< [| $list:pl$ |] >> + | "{"; lpl = lbl_patt_list; "}" -> <:patt< { $list:lpl$ } >> + | "("; ")" -> <:patt< () >> + | "("; p = SELF; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> + | "("; p = SELF; ")" -> <:patt< $p$ >> + | "("; "-"; ")" -> <:patt< $lid:"-"$ >> + | "("; op = operator; ")" -> <:patt< $lid:op$ >> + | "_" -> <:patt< _ >> + | x = LOCATE -> + let x = + try + let i = String.index x ':' in + ({Lexing.pos_fname = ""; + Lexing.pos_lnum = 0; + Lexing.pos_bol = 0; + Lexing.pos_cnum = int_of_string (String.sub x 0 i)}, + String.sub x (i + 1) (String.length x - i - 1)) + with + [ Not_found | Failure _ -> (Token.nowhere, x) ] + in + Pcaml.handle_patt_locate loc x + | x = QUOTATION -> + let x = + try + let i = String.index x ':' in + (String.sub x 0 i, + String.sub x (i + 1) (String.length x - i - 1)) + with + [ Not_found -> ("", x) ] + in + Pcaml.handle_patt_quotation loc x ] ] + ; + patt_semi_list: + [ [ p = patt; ";"; pl = SELF -> [p :: pl] + | p = patt; ";" -> [p] + | p = patt -> [p] ] ] + ; + lbl_patt_list: + [ [ le = lbl_patt; ";"; lel = SELF -> [le :: lel] + | le = lbl_patt; ";" -> [le] + | le = lbl_patt -> [le] ] ] + ; + lbl_patt: + [ [ i = patt_label_ident; "="; p = patt -> (i, p) ] ] + ; + patt_label_ident: + [ RIGHTA + [ i = UIDENT -> <:patt< $uid:i$ >> + | i = LIDENT -> <:patt< $lid:i$ >> + | m = UIDENT; "."; i = SELF -> <:patt< $uid:m$ . $i$ >> ] ] + ; + (* Type declaration *) + type_declaration: + [ [ tpl = type_parameters; n = type_patt; "="; tk = type_kind; + cl = LIST0 constrain -> + (n, tpl, tk, cl) + | tpl = type_parameters; n = type_patt; cl = LIST0 constrain -> + (n, tpl, <:ctyp< '$choose_tvar tpl$ >>, cl) ] ] + ; + type_patt: + [ [ n = LIDENT -> (loc, n) ] ] + ; + constrain: + [ [ "constraint"; t1 = ctyp; "="; t2 = ctyp -> (t1, t2) ] ] + ; + type_kind: + [ [ test_constr_decl; OPT "|"; + cdl = LIST1 constructor_declaration SEP "|" -> + <:ctyp< [ $list:cdl$ ] >> + | t = ctyp -> <:ctyp< $t$ >> + | t = ctyp; "="; "{"; ldl = label_declarations; "}" -> + <:ctyp< $t$ == { $list:ldl$ } >> + | t = ctyp; "="; OPT "|"; cdl = LIST1 constructor_declaration SEP "|" -> + <:ctyp< $t$ == [ $list:cdl$ ] >> + | "{"; ldl = label_declarations; "}" -> <:ctyp< { $list:ldl$ } >> ] ] + ; + type_parameters: + [ [ -> (* empty *) [] + | tp = type_parameter -> [tp] + | "("; tpl = LIST1 type_parameter SEP ","; ")" -> tpl ] ] + ; + type_parameter: + [ [ "'"; i = ident -> (i, (False, False)) ] ] + ; + constructor_declaration: + [ [ ci = UIDENT; "of"; cal = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> + (loc, ci, cal) + | ci = UIDENT -> (loc, ci, []) ] ] + ; + label_declarations: + [ [ ld = label_declaration; ";"; ldl = SELF -> [ld :: ldl] + | ld = label_declaration; ";" -> [ld] + | ld = label_declaration -> [ld] ] ] + ; + label_declaration: + [ [ i = LIDENT; ":"; t = ctyp -> (loc, i, False, t) + | i = LABEL; t = ctyp -> (loc, i, False, t) + | "mutable"; i = LIDENT; ":"; t = ctyp -> (loc, i, True, t) + | "mutable"; i = LABEL; t = ctyp -> (loc, i, True, t) ] ] + ; + (* Core types *) + ctyp: + [ [ t1 = SELF; "as"; "'"; i = ident -> <:ctyp< $t1$ as '$i$ >> ] + | "arrow" RIGHTA + [ t1 = SELF; "->"; t2 = SELF -> <:ctyp< $t1$ -> $t2$ >> ] + | [ t = SELF; "*"; tl = LIST1 ctyp LEVEL "ctyp1" SEP "*" -> + <:ctyp< ( $list:[t :: tl]$ ) >> ] + | "ctyp1" + [ t1 = SELF; t2 = SELF -> <:ctyp< $t2$ $t1$ >> ] + | "ctyp2" + [ t1 = SELF; "."; t2 = SELF -> <:ctyp< $t1$ . $t2$ >> + | t1 = SELF; "("; t2 = SELF; ")" -> <:ctyp< $t1$ $t2$ >> ] + | "simple" + [ "'"; i = ident -> <:ctyp< '$i$ >> + | "_" -> <:ctyp< _ >> + | i = LIDENT -> <:ctyp< $lid:i$ >> + | i = UIDENT -> <:ctyp< $uid:i$ >> + | "("; t = SELF; ","; tl = LIST1 ctyp SEP ","; ")"; + i = ctyp LEVEL "ctyp2" -> + List.fold_left (fun c a -> <:ctyp< $c$ $a$ >>) i [t :: tl] + | "("; t = SELF; ")" -> <:ctyp< $t$ >> ] ] + ; + (* Identifiers *) + ident: + [ [ i = LIDENT -> i + | i = UIDENT -> i ] ] + ; + mod_ident: + [ RIGHTA + [ i = UIDENT -> [i] + | i = LIDENT -> [i] + | m = UIDENT; "."; i = SELF -> [m :: i] ] ] + ; + (* Miscellaneous *) + direction_flag: + [ [ "to" -> True + | "downto" -> False ] ] + ; +END; + +(* Objects and Classes *) + +value rec class_type_of_ctyp loc t = + match t with + [ <:ctyp< $lid:i$ >> -> <:class_type< $list:[i]$ >> + | <:ctyp< $uid:m$.$t$ >> -> <:class_type< $list:[m :: type_id_list t]$ >> + | _ -> raise_with_loc loc (Stream.Error "lowercase identifier expected") ] +and type_id_list = + fun + [ <:ctyp< $uid:m$.$t$ >> -> [m :: type_id_list t] + | <:ctyp< $lid:i$ >> -> [i] + | t -> + raise_with_loc (loc_of_node t) + (Stream.Error "lowercase identifier expected") ] +; + +value class_fun_binding = Grammar.Entry.create gram "class_fun_binding"; + +EXTEND + GLOBAL: str_item sig_item expr ctyp class_sig_item class_str_item class_type + class_expr class_fun_binding; + str_item: + [ [ "class"; cd = LIST1 class_declaration SEP "and" -> + <:str_item< class $list:cd$ >> + | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> + <:str_item< class type $list:ctd$ >> ] ] + ; + sig_item: + [ [ "class"; cd = LIST1 class_description SEP "and" -> + <:sig_item< class $list:cd$ >> + | "class"; "type"; ctd = LIST1 class_type_declaration SEP "and" -> + <:sig_item< class type $list:ctd$ >> ] ] + ; + (* Class expressions *) + class_declaration: + [ [ vf = OPT "virtual"; ctp = class_type_parameters; i = LIDENT; + cfb = class_fun_binding -> + {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; + MLast.ciNam = i; MLast.ciExp = cfb} ] ] + ; + class_fun_binding: + [ [ "="; ce = class_expr -> ce + | ":"; ct = class_type; "="; ce = class_expr -> + <:class_expr< ($ce$ : $ct$) >> + | p = patt LEVEL "simple"; cfb = SELF -> + <:class_expr< fun $p$ -> $cfb$ >> ] ] + ; + class_type_parameters: + [ [ -> (loc, []) + | "["; tpl = LIST1 type_parameter SEP ","; "]" -> (loc, tpl) ] ] + ; + class_fun_def: + [ [ p = patt LEVEL "simple"; "->"; ce = class_expr -> + <:class_expr< fun $p$ -> $ce$ >> + | p = patt LEVEL "simple"; cfd = SELF -> + <:class_expr< fun $p$ -> $cfd$ >> ] ] + ; + class_expr: + [ "top" + [ "fun"; cfd = class_fun_def -> cfd + | "let"; rf = OPT "rec"; lb = LIST1 let_binding SEP "and"; "in"; + ce = SELF -> + <:class_expr< let $opt:o2b rf$ $list:lb$ in $ce$ >> ] + | "apply" NONA + [ ce = SELF; e = expr LEVEL "label" -> + <:class_expr< $ce$ $e$ >> ] + | "simple" + [ "["; ct = ctyp; ","; ctcl = LIST1 ctyp SEP ","; "]"; + ci = class_longident -> + <:class_expr< $list:ci$ [ $list:[ct :: ctcl]$ ] >> + | "["; ct = ctyp; "]"; ci = class_longident -> + <:class_expr< $list:ci$ [ $ct$ ] >> + | ci = class_longident -> <:class_expr< $list:ci$ >> + | "object"; cspo = OPT class_self_patt; cf = class_structure; "end" -> + <:class_expr< object $opt:cspo$ $list:cf$ end >> + | "("; ce = SELF; ":"; ct = class_type; ")" -> + <:class_expr< ($ce$ : $ct$) >> + | "("; ce = SELF; ")" -> ce ] ] + ; + class_structure: + [ [ cf = LIST0 class_str_item -> cf ] ] + ; + class_self_patt: + [ [ "("; p = patt; ")" -> p + | "("; p = patt; ":"; t = ctyp; ")" -> <:patt< ($p$ : $t$) >> ] ] + ; + class_str_item: + [ [ "inherit"; ce = class_expr; pb = OPT [ "as"; i = LIDENT -> i ] -> + <:class_str_item< inherit $ce$ $opt:pb$ >> + | "val"; (lab, mf, e) = cvalue -> + <:class_str_item< value $opt:mf$ $lab$ = $e$ >> + | "method"; "private"; "virtual"; l = label; ":"; t = ctyp -> + <:class_str_item< method virtual private $l$ : $t$ >> + | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> + <:class_str_item< method virtual private $l$ : $t$ >> + | "method"; "virtual"; l = label; ":"; t = ctyp -> + <:class_str_item< method virtual $l$ : $t$ >> + | "method"; "private"; l = label; fb = fun_binding -> + <:class_str_item< method private $l$ = $fb$ >> + | "method"; l = label; fb = fun_binding -> + <:class_str_item< method $l$ = $fb$ >> + | "constraint"; t1 = ctyp; "="; t2 = ctyp -> + <:class_str_item< type $t1$ = $t2$ >> + | "initializer"; se = expr -> <:class_str_item< initializer $se$ >> ] ] + ; + cvalue: + [ [ mf = OPT "mutable"; l = label; "="; e = expr -> (l, o2b mf, e) + | mf = OPT "mutable"; l = label; ":"; t = ctyp; "="; e = expr -> + (l, o2b mf, <:expr< ($e$ : $t$) >>) + | mf = OPT "mutable"; l = label; ":"; t1 = ctyp; ":>"; t2 = ctyp; "="; + e = expr -> + (l, o2b mf, <:expr< ($e$ : $t1$ :> $t2$) >>) + | mf = OPT "mutable"; l = label; ":>"; t = ctyp; "="; e = expr -> + (l, o2b mf, <:expr< ($e$ :> $t$) >>) ] ] + ; + label: + [ [ i = LIDENT -> i ] ] + ; + (* Class types *) + class_type: + [ [ t = ctyp LEVEL "ctyp1" -> class_type_of_ctyp loc t + | t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> + <:class_type< [ $t$ ] -> $ct$ >> + | t = ctyp LEVEL "ctyp1"; "*"; tl = LIST1 ctyp LEVEL "simple" SEP "*"; + "->"; ct = SELF -> + <:class_type< [ ($t$ * $list:tl$) ] -> $ct$ >> + | cs = class_signature -> cs ] ] + ; + class_signature: + [ [ "["; tl = LIST1 ctyp SEP ","; "]"; id = clty_longident -> + <:class_type< $list:id$ [ $list:tl$ ] >> + | id = clty_longident -> <:class_type< $list:id$ >> + | "object"; cst = OPT class_self_type; csf = LIST0 class_sig_item; + "end" -> + <:class_type< object $opt:cst$ $list:csf$ end >> ] ] + ; + class_self_type: + [ [ "("; t = ctyp; ")" -> t ] ] + ; + class_sig_item: + [ [ "inherit"; cs = class_signature -> <:class_sig_item< inherit $cs$ >> + | "val"; mf = OPT "mutable"; l = label; ":"; t = ctyp -> + <:class_sig_item< value $opt:o2b mf$ $l$ : $t$ >> + | "method"; "private"; "virtual"; l = label; ":"; t = ctyp -> + <:class_sig_item< method virtual private $l$ : $t$ >> + | "method"; "virtual"; "private"; l = label; ":"; t = ctyp -> + <:class_sig_item< method virtual private $l$ : $t$ >> + | "method"; "virtual"; l = label; ":"; t = ctyp -> + <:class_sig_item< method virtual $l$ : $t$ >> + | "method"; "private"; l = label; ":"; t = ctyp -> + <:class_sig_item< method private $l$ : $t$ >> + | "method"; l = label; ":"; t = ctyp -> + <:class_sig_item< method $l$ : $t$ >> + | "constraint"; t1 = ctyp; "="; t2 = ctyp -> + <:class_sig_item< type $t1$ = $t2$ >> ] ] + ; + class_description: + [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; ":"; + ct = class_type -> + {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; + MLast.ciNam = n; MLast.ciExp = ct} + | vf = OPT "virtual"; ctp = class_type_parameters; n = LABEL; + ct = class_type -> + {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; + MLast.ciNam = n; MLast.ciExp = ct} ] ] + ; + class_type_declaration: + [ [ vf = OPT "virtual"; ctp = class_type_parameters; n = LIDENT; "="; + cs = class_signature -> + {MLast.ciLoc = loc; MLast.ciVir = o2b vf; MLast.ciPrm = ctp; + MLast.ciNam = n; MLast.ciExp = cs} ] ] + ; + (* Expressions *) + expr: LEVEL "apply" + [ LEFTA + [ "new"; i = class_longident -> <:expr< new $list:i$ >> ] ] + ; + expr: LEVEL "simple" + [ [ e = SELF; "#"; lab = label -> <:expr< $e$ # $lab$ >> ] ] + ; + expr: LEVEL "simple" + [ [ "("; e = SELF; ":"; t1 = ctyp; ":>"; t2 = ctyp; ")" -> + <:expr< ($e$ : $t1$ :> $t2$) >> + | "("; e = SELF; ":>"; t = ctyp; ")" -> <:expr< ($e$ :> $t$) >> + | "{<"; ">}" -> <:expr< {< >} >> + | "{<"; fel = field_expr_list; ">}" -> <:expr< {< $list:fel$ >} >> ] ] + ; + field_expr_list: + [ [ l = label; "="; e = expr LEVEL "expr1"; ";"; fel = SELF -> + [(l, e) :: fel] + | l = label; "="; e = expr LEVEL "expr1"; ";" -> [(l, e)] + | l = label; "="; e = expr LEVEL "expr1" -> [(l, e)] ] ] + ; + (* Core types *) + ctyp: LEVEL "simple" + [ [ "#"; id = class_longident -> <:ctyp< # $list:id$ >> + | "<"; (ml, v) = meth_list; ">" -> <:ctyp< < $list:ml$ $opt:v$ > >> + | "<"; ">" -> <:ctyp< < > >> ] ] + ; + meth_list: + [ [ f = field; ";"; (ml, v) = SELF -> ([f :: ml], v) + | f = field; ";" -> ([f], False) + | f = field -> ([f], False) + | ".." -> ([], True) ] ] + ; + field: + [ [ lab = LIDENT; ":"; t = ctyp -> (lab, t) + | lab = LABEL; t = ctyp -> (lab, t) ] ] + ; + (* Identifiers *) + clty_longident: + [ [ m = UIDENT; "."; l = SELF -> [m :: l] + | i = LIDENT -> [i] ] ] + ; + class_longident: + [ [ m = UIDENT; "."; l = SELF -> [m :: l] + | i = LIDENT -> [i] ] ] + ; +END; + +(* Labels *) + +EXTEND + GLOBAL: ctyp expr patt fun_def fun_binding class_type class_fun_binding; + ctyp: AFTER "arrow" + [ NONA + [ i = LABEL; t = SELF -> <:ctyp< ~ $i$ : $t$ >> + | "?"; i = LABEL; t = SELF -> <:ctyp< ? $i$ : $t$ >> ] ] + ; + ctyp: LEVEL "simple" + [ [ "["; OPT "|"; rfl = LIST0 row_field SEP "|"; "]" -> + <:ctyp< [ = $list:rfl$ ] >> + | "["; ">"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> + <:ctyp< [ > $list:rfl$ ] >> + | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; "]" -> + <:ctyp< [ < $list:rfl$ ] >> + | "[<"; OPT "|"; rfl = LIST1 row_field SEP "|"; ">"; + ntl = LIST1 name_tag; "]" -> + <:ctyp< [ < $list:rfl$ > $list:ntl$ ] >> ] ] + ; + row_field: + [ [ "`"; i = ident -> MLast.RfTag i False [] + | "`"; i = ident; "of"; ao = OPT "&"; l = LIST1 ctyp SEP "&" -> + MLast.RfTag i (o2b ao) l + | "`"; i = ident; "&"; l = LIST1 ctyp SEP "&" -> MLast.RfTag i True l + | "`"; i = ident; l = LIST1 ctyp SEP "&" -> MLast.RfTag i False l ] ] + ; + name_tag: + [ [ "`"; i = ident -> i ] ] + ; + expr: LEVEL "expr1" + [ [ "fun"; p = labeled_patt; e = fun_def -> <:expr< fun $p$ -> $e$ >> ] ] + ; + expr: AFTER "apply" + [ "label" + [ i = LABEL; e = SELF -> <:expr< ~ $i$ : $e$ >> + | i = ELABEL -> <:expr< ~ $i$ >> + | "?"; i = LABEL; e = SELF -> <:expr< ? $i$ : $e$ >> + | "?"; i = ELABEL -> <:expr< ? $i$ >> ] ] + ; + expr: LEVEL "simple" + [ [ "`"; s = ident -> <:expr< ` $s$ >> ] ] + ; + fun_def: + [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] + ; + fun_binding: + [ [ p = labeled_patt; e = SELF -> <:expr< fun $p$ -> $e$ >> ] ] + ; + patt: LEVEL "simple" + [ [ "`"; s = ident -> <:patt< ` $s$ >> ] ] + ; + labeled_patt: + [ [ i = LABEL; p = patt LEVEL "simple" -> <:patt< ~ $i$ : $p$ >> + | i = ELABEL -> <:patt< ~ $i$ >> + | "?"; i = LABEL; j = LIDENT -> <:patt< ? $i$ : ($lid:j$) >> + | "?"; "("; i = LABEL; j = LIDENT; ")" -> <:patt< ? $i$ : ($lid:j$) >> + | "?"; "("; i = LABEL; j = LIDENT; "="; e = expr; ")" -> + <:patt< ? $i$ : ( $lid:j$ = $e$ ) >> + | "?"; i = ELABEL -> <:patt< ? $i$ : ($lid:i$) >> + | "?"; "("; i = ELABEL; "="; e = expr; ")" -> + <:patt< ? $i$ : ( $lid:i$ = $e$ ) >> ] ] + ; + class_type: + [ [ i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> + <:class_type< [ ~ $i$ : $t$ ] -> $ct$ >> + | "?"; i = LABEL; t = ctyp LEVEL "ctyp1"; "->"; ct = SELF -> + <:class_type< [ ? $i$ : $t$ ] -> $ct$ >> ] ] + ; + class_fun_binding: + [ [ p = labeled_patt; cfb = SELF -> <:class_expr< fun $p$ -> $cfb$ >> ] ] + ; + ident: + [ [ i = LIDENT -> i + | i = UIDENT -> i ] ] + ; +END; + +type spat_comp = + [ SpTrm of Loc.t and MLast.patt and option MLast.expr + | SpNtr of Loc.t and MLast.patt and MLast.expr + | SpStr of Loc.t and MLast.patt ] +; +type sexp_comp = + [ SeTrm of Loc.t and MLast.expr | SeNtr of Loc.t and MLast.expr ] +; + +value strm_n = "__strm"; +value peek_fun loc = <:expr< Stream.peek >>; +value junk_fun loc = <:expr< Stream.junk >>; + +(* Parsers. *) +(* In syntax generated, many cases are optimisations. *) + +value rec pattern_eq_expression p e = + match (p, e) with + [ (<:patt< $lid:a$ >>, <:expr< $lid:b$ >>) -> a = b + | (<:patt< $uid:a$ >>, <:expr< $uid:b$ >>) -> a = b + | (<:patt< $p1$ $p2$ >>, <:expr< $e1$ $e2$ >>) -> + pattern_eq_expression p1 e1 && pattern_eq_expression p2 e2 + | _ -> False ] +; + +value is_raise e = + match e with + [ <:expr< raise $_$ >> -> True + | _ -> False ] +; + +value is_raise_failure e = + match e with + [ <:expr< raise Stream.Failure >> -> True + | _ -> False ] +; + +value rec handle_failure e = + match e with + [ <:expr< try $te$ with [ Stream.Failure -> $e$] >> -> handle_failure e + | <:expr< match $me$ with [ $list:pel$ ] >> -> + handle_failure me && + List.for_all + (fun + [ (_, None, e) -> handle_failure e + | _ -> False ]) + pel + | <:expr< let $list:pel$ in $e$ >> -> + List.for_all (fun (p, e) -> handle_failure e) pel && handle_failure e + | <:expr< $lid:_$ >> | <:expr< $int:_$ >> | <:expr< $str:_$ >> | + <:expr< $chr:_$ >> | <:expr< fun [ $list:_$ ] >> | <:expr< $uid:_$ >> -> + True + | <:expr< raise $e$ >> -> + match e with + [ <:expr< Stream.Failure >> -> False + | _ -> True ] + | <:expr< $f$ $x$ >> -> + is_constr_apply f && handle_failure f && handle_failure x + | _ -> False ] +and is_constr_apply = + fun + [ <:expr< $uid:_$ >> -> True + | <:expr< $lid:_$ >> -> False + | <:expr< $x$ $_$ >> -> is_constr_apply x + | _ -> False ] +; + +value rec subst v e = + let loc = MLast.loc_of_expr e in + match e with + [ <:expr< $lid:x$ >> -> + let x = if x = v then strm_n else x in + <:expr< $lid:x$ >> + | <:expr< $uid:_$ >> -> e + | <:expr< $int:_$ >> -> e + | <:expr< $chr:_$ >> -> e + | <:expr< $str:_$ >> -> e + | <:expr< $_$ . $_$ >> -> e + | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> + <:expr< let $opt:rf$ $list:List.map (subst_pe v) pel$ in $subst v e$ >> + | <:expr< $e1$ $e2$ >> -> <:expr< $subst v e1$ $subst v e2$ >> + | <:expr< ( $list:el$ ) >> -> <:expr< ( $list:List.map (subst v) el$ ) >> + | _ -> raise Not_found ] +and subst_pe v (p, e) = + match p with + [ <:patt< $lid:v'$ >> -> if v = v' then (p, e) else (p, subst v e) + | _ -> raise Not_found ] +; + +value stream_pattern_component skont ckont = + fun + [ SpTrm loc p wo -> + <:expr< match $peek_fun loc$ $lid:strm_n$ with + [ Some $p$ $when:wo$ -> + do { $junk_fun loc$ $lid:strm_n$; $skont$ } + | _ -> $ckont$ ] >> + | SpNtr loc p e -> + let e = + match e with + [ <:expr< fun [ ($lid:v$ : Stream.t _) -> $e$ ] >> when v = strm_n -> + e + | _ -> <:expr< $e$ $lid:strm_n$ >> ] + in + if pattern_eq_expression p skont then + if is_raise_failure ckont then e + else if handle_failure e then e + else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> + else if is_raise_failure ckont then <:expr< let $p$ = $e$ in $skont$ >> + else if pattern_eq_expression <:patt< Some $p$ >> skont then + <:expr< try Some $e$ with [ Stream.Failure -> $ckont$ ] >> + else if is_raise ckont then + let tst = + if handle_failure e then e + else <:expr< try $e$ with [ Stream.Failure -> $ckont$ ] >> + in + <:expr< let $p$ = $tst$ in $skont$ >> + else + <:expr< match try Some $e$ with [ Stream.Failure -> None ] with + [ Some $p$ -> $skont$ + | _ -> $ckont$ ] >> + | SpStr loc p -> + try + match p with + [ <:patt< $lid:v$ >> -> subst v skont + | _ -> raise Not_found ] + with + [ Not_found -> <:expr< let $p$ = $lid:strm_n$ in $skont$ >> ] ] +; + +value rec stream_pattern loc epo e ekont = + fun + [ [] -> + match epo with + [ Some ep -> <:expr< let $ep$ = Stream.count $lid:strm_n$ in $e$ >> + | _ -> e ] + | [(spc, err) :: spcl] -> + let skont = + let ekont err = + let str = + match err with + [ Some estr -> estr + | _ -> <:expr< "" >> ] + in + <:expr< raise (Stream.Error $str$) >> + in + stream_pattern loc epo e ekont spcl + in + let ckont = ekont err in + stream_pattern_component skont ckont spc ] +; + +value stream_patterns_term loc ekont tspel = + let pel = + List.map + (fun (p, w, loc, spcl, epo, e) -> + let p = <:patt< Some $p$ >> in + let e = + let ekont err = + let str = + match err with + [ Some estr -> estr + | _ -> <:expr< "" >> ] + in + <:expr< raise (Stream.Error $str$) >> + in + let skont = stream_pattern loc epo e ekont spcl in + <:expr< do { $junk_fun loc$ $lid:strm_n$; $skont$ } >> + in + (p, w, e)) + tspel + in + let pel = pel @ [(<:patt< _ >>, None, ekont ())] in + <:expr< match $peek_fun loc$ $lid:strm_n$ with [ $list:pel$ ] >> +; + +value rec group_terms = + fun + [ [([(SpTrm loc p w, None) :: spcl], epo, e) :: spel] -> + let (tspel, spel) = group_terms spel in + ([(p, w, loc, spcl, epo, e) :: tspel], spel) + | spel -> ([], spel) ] +; + +value rec parser_cases loc = + fun + [ [] -> <:expr< raise Stream.Failure >> + | spel -> + match group_terms spel with + [ ([], [(spcl, epo, e) :: spel]) -> + stream_pattern loc epo e (fun _ -> parser_cases loc spel) spcl + | (tspel, spel) -> + stream_patterns_term loc (fun _ -> parser_cases loc spel) tspel ] ] +; + +value cparser loc bpo pc = + let e = parser_cases loc pc in + let e = + match bpo with + [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $e$ >> + | None -> e ] + in + let p = <:patt< ($lid:strm_n$ : Stream.t _) >> in + <:expr< fun $p$ -> $e$ >> +; + +value cparser_match loc me bpo pc = + let pc = parser_cases loc pc in + let e = + match bpo with + [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> + | None -> pc ] + in + <:expr< let $lid:strm_n$ = $me$ in $e$ >> +; + +(* streams *) + +value rec not_computing = + fun + [ <:expr< $lid:_$ >> | <:expr< $uid:_$ >> | <:expr< $int:_$ >> | + <:expr< $flo:_$ >> | <:expr< $chr:_$ >> | <:expr< $str:_$ >> -> + True + | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y + | _ -> False ] +and is_cons_apply_not_computing = + fun + [ <:expr< $uid:_$ >> -> True + | <:expr< $lid:_$ >> -> False + | <:expr< $x$ $y$ >> -> is_cons_apply_not_computing x && not_computing y + | _ -> False ] +; + +value slazy loc e = + match e with + [ <:expr< $f$ () >> -> + match f with + [ <:expr< $lid:_$ >> -> f + | _ -> <:expr< fun _ -> $e$ >> ] + | _ -> <:expr< fun _ -> $e$ >> ] +; + +value rec cstream gloc = + fun + [ [] -> + let loc = gloc in + <:expr< Stream.sempty >> + | [SeTrm loc e] -> + if not_computing e then <:expr< Stream.ising $e$ >> + else <:expr< Stream.lsing $slazy loc e$ >> + | [SeTrm loc e :: secl] -> + if not_computing e then <:expr< Stream.icons $e$ $cstream gloc secl$ >> + else <:expr< Stream.lcons $slazy loc e$ $cstream gloc secl$ >> + | [SeNtr loc e] -> + if not_computing e then e else <:expr< Stream.slazy $slazy loc e$ >> + | [SeNtr loc e :: secl] -> + if not_computing e then <:expr< Stream.iapp $e$ $cstream gloc secl$ >> + else <:expr< Stream.lapp $slazy loc e$ $cstream gloc secl$ >> ] +; + +(* Syntax extensions in Ocaml grammar *) + +EXTEND + GLOBAL: expr; + expr: LEVEL "expr1" + [ [ "parser"; po = OPT ipatt; OPT "|"; pcl = LIST1 parser_case SEP "|" -> + <:expr< $cparser loc po pcl$ >> + | "match"; e = SELF; "with"; "parser"; po = OPT ipatt; OPT "|"; + pcl = LIST1 parser_case SEP "|" -> + <:expr< $cparser_match loc e po pcl$ >> ] ] + ; + parser_case: + [ [ "[<"; sp = stream_patt; ">]"; po = OPT ipatt; "->"; e = expr -> + (sp, po, e) ] ] + ; + stream_patt: + [ [ spc = stream_patt_comp -> [(spc, None)] + | spc = stream_patt_comp; ";" -> [(spc, None)] + | spc = stream_patt_comp; ";"; sp = stream_patt_comp_err_list -> + [(spc, None) :: sp] + | -> (* empty *) [] ] ] + ; + stream_patt_comp_err_list: + [ [ spc = stream_patt_comp_err -> [spc] + | spc = stream_patt_comp_err; ";" -> [spc] + | spc = stream_patt_comp_err; ";"; sp = SELF -> [spc :: sp] ] ] + ; + stream_patt_comp: + [ [ "'"; p = patt; eo = OPT [ "when"; e = expr LEVEL "expr1" -> e ] -> + SpTrm loc p eo + | p = patt; "="; e = expr LEVEL "expr1" -> SpNtr loc p e + | p = patt -> SpStr loc p ] ] + ; + stream_patt_comp_err: + [ [ spc = stream_patt_comp; + eo = OPT [ "?"; e = expr LEVEL "expr1" -> e ] -> + (spc, eo) ] ] + ; + ipatt: + [ [ i = LIDENT -> <:patt< $lid:i$ >> ] ] + ; + expr: LEVEL "simple" + [ [ "[<"; ">]" -> <:expr< $cstream loc []$ >> + | "[<"; sel = stream_expr_comp_list; ">]" -> + <:expr< $cstream loc sel$ >> ] ] + ; + stream_expr_comp_list: + [ [ se = stream_expr_comp; ";"; sel = SELF -> [se :: sel] + | se = stream_expr_comp; ";" -> [se] + | se = stream_expr_comp -> [se] ] ] + ; + stream_expr_comp: + [ [ "'"; e = expr LEVEL "expr1" -> SeTrm loc e + | e = expr LEVEL "expr1" -> SeNtr loc e ] ] + ; +END; diff --git a/ocaml-binary-annot/camlp4/unmaintained/scheme/.depend b/ocaml-binary-annot/camlp4/unmaintained/scheme/.depend new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/scheme/.depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/scheme/Makefile b/ocaml-binary-annot/camlp4/unmaintained/scheme/Makefile new file mode 100644 index 0000000000..01036c2252 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/scheme/Makefile @@ -0,0 +1,85 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# Makefile for pa_lefteval +# M.Mauny +# + +include ../../config/Makefile.cnf + +OCAMLTOP=../../.. +CAMLP4=../../camlp4/camlp4$(EXE) + +OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) +OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) + +P4INCLUDES= -nolib -I ../../meta -I ../../etc +OCAMLINCLUDES= -nostdlib -I $(OCAMLTOP)/stdlib -I ../../camlp4 -I ../../lib -I ../../etc +OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) + +SCHSRC=pa_scheme.sc +SRC=pa_scheme.ml pr_scheme.ml pr_schp_main.ml +OBJS=$(SRC:.ml=.cmo) +OBJSX=$(OCAMLSRC:.ml=.cmx) + +all: $(OBJS) pr_schemep.cmo camlp4sch$(EXE) + +opt: all + +bootstrap: camlp4sch$(EXE) save + ./camlp4sch$(EXE) ../../etc/q_phony.cmo ../../meta/pa_extend.cmo ../../etc/pr_r.cmo ../../etc/pr_extend.cmo ../../etc/pr_rp.cmo -impl pa_scheme.sc \ + | sed -e 's/^;; \(.*\)$$/(* \1 *)/' -e 's/^; \(.*\)$$/(* \1 *)/' \ + -e 's/$$Id.*\$$/File generated by pretty print; do not edit!/' > pa_scheme.ml + @if cmp -s pa_scheme.ml SAVED/pa_scheme.ml; then \ + echo 'pa_scheme.ml and SAVED/pa_scheme.ml are identical' ; \ + else \ + echo '**** Note: pa_scheme.ml differs from SAVED/pa_scheme.ml'; \ + fi + +save: + test -d SAVED || mkdir SAVED + mkdir SAVED.$$$$ && mv SAVED pa_scheme.ml SAVED.$$$$ && mv SAVED.$$$$ SAVED + +restore: + mv SAVED SAVED.$$$$ && mv SAVED.$$$$/* . && rmdir SAVED.$$$$ + +depend: + cp .depend .depend.bak + > .depend + for file in $(SRC); do \ + $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ + sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ + done + +clean: + rm -f camlp4sch$(EXE) *.cm* *.$(O) *.bak .*.bak + +camlp4sch: pa_scheme.cmo + rm -f camlp4sch + DIR=`pwd` && cd ../../camlp4 && $(MAKE) CAMLP4=$$DIR/camlp4sch CAMLP4M="-I $$DIR pa_scheme.cmo ../meta/pr_dump.cmo" + +pr_schemep.cmo: pr_schp_main.cmo + $(OCAMLC) ../../etc/parserify.cmo pr_schp_main.cmo -a -o $@ + +.SUFFIXES: .cmx .cmo .cmi .ml .mli + +.mli.cmi: + $(OCAMLC) $(OCAMLCFLAGS) -c $< + + +.ml.cmo: + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<` -loc loc" -c $< + +include .depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/scheme/README b/ocaml-binary-annot/camlp4/unmaintained/scheme/README new file mode 100644 index 0000000000..809d42f2a8 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/scheme/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + diff --git a/ocaml-binary-annot/camlp4/unmaintained/scheme/pa_scheme.ml b/ocaml-binary-annot/camlp4/unmaintained/scheme/pa_scheme.ml new file mode 100644 index 0000000000..4389321030 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/scheme/pa_scheme.ml @@ -0,0 +1,1093 @@ +(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) +(* ********************************************************************** *) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file *) +(* ../../../LICENSE. *) +(* *) +(* ********************************************************************** *) +(* File generated by pretty print; do not edit! *) + +open Pcaml; +open Stdpp; + +type choice 'a 'b = + [ Left of 'a + | Right of 'b ] +; + +(* Buffer *) + +module Buff = + struct + value buff = ref (String.create 80); + value store len x = + do { + if len >= String.length buff.val then + buff.val := buff.val ^ String.create (String.length buff.val) + else (); + buff.val.[len] := x; + succ len + } + ; + value get len = String.sub buff.val 0 len; + end +; + +(* Lexer *) + +value rec skip_to_eol = + parser + [ [: `'\n' | '\r' :] -> () + | [: `_; s :] -> skip_to_eol s ] +; + +value no_ident = ['('; ')'; '['; ']'; '{'; '}'; ' '; '\t'; '\n'; '\r'; ';']; + +value rec ident len = + parser + [ [: `'.' :] -> (Buff.get len, True) + | [: `x when not (List.mem x no_ident); s :] -> ident (Buff.store len x) s + | [: :] -> (Buff.get len, False) ] +; + +value identifier kwt (s, dot) = + let con = + try do { (Hashtbl.find kwt s : unit); "" } with + [ Not_found -> + match s.[0] with + [ 'A'..'Z' -> if dot then "UIDENTDOT" else "UIDENT" + | _ -> if dot then "LIDENTDOT" else "LIDENT" ] ] + in + (con, s) +; + +value rec string len = + parser + [ [: `'"' :] -> Buff.get len + | [: `'\\'; `c; s :] -> string (Buff.store (Buff.store len '\\') c) s + | [: `x; s :] -> string (Buff.store len x) s ] +; + +value rec end_exponent_part_under len = + parser + [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s + | [: :] -> ("FLOAT", Buff.get len) ] +; + +value end_exponent_part len = + parser + [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (Buff.store len c) s + | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ] +; + +value exponent_part len = + parser + [ [: `('+' | '-' as c); s :] -> end_exponent_part (Buff.store len c) s + | [: a = end_exponent_part len :] -> a ] +; + +value rec decimal_part len = + parser + [ [: `('0'..'9' as c); s :] -> decimal_part (Buff.store len c) s + | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s + | [: :] -> ("FLOAT", Buff.get len) ] +; + +value rec number len = + parser + [ [: `('0'..'9' as c); s :] -> number (Buff.store len c) s + | [: `'.'; s :] -> decimal_part (Buff.store len '.') s + | [: `'e' | 'E'; s :] -> exponent_part (Buff.store len 'E') s + | [: :] -> ("INT", Buff.get len) ] +; + +value binary = parser [: `('0'..'1' as c) :] -> c; + +value octal = parser [: `('0'..'7' as c) :] -> c; + +value hexa = parser [: `('0'..'9' | 'a'..'f' | 'A'..'F' as c) :] -> c; + +value rec digits_under kind len = + parser + [ [: d = kind; s :] -> digits_under kind (Buff.store len d) s + | [: :] -> Buff.get len ] +; + +value digits kind bp len = + parser + [ [: d = kind; s :] -> ("INT", digits_under kind (Buff.store len d) s) + | [: s :] ep -> + raise_with_loc + (Reloc.shift_pos bp Reloc.zero_loc, Reloc.shift_pos ep Reloc.zero_loc) + (Failure "ill-formed integer constant") ] +; + +value base_number kwt bp len = + parser + [ [: `'b' | 'B'; s :] -> digits binary bp (Buff.store len 'b') s + | [: `'o' | 'O'; s :] -> digits octal bp (Buff.store len 'o') s + | [: `'x' | 'X'; s :] -> digits hexa bp (Buff.store len 'x') s + | [: id = ident (Buff.store 0 '#') :] -> identifier kwt id ] +; + +value rec operator len = + parser + [ [: `'.' :] -> Buff.get (Buff.store len '.') + | [: :] -> Buff.get len ] +; + +value char_or_quote_id x = + parser + [ [: `''' :] -> ("CHAR", String.make 1 x) + | [: s :] ep -> + if List.mem x no_ident then + Stdpp.raise_with_loc + (Reloc.shift_pos (ep - 2) Reloc.zero_loc, + Reloc.shift_pos (ep - 1) Reloc.zero_loc) + (Stream.Error "bad quote") + else + let len = Buff.store (Buff.store 0 ''') x in + let (s, dot) = ident len s in + (if dot then "LIDENTDOT" else "LIDENT", s) ] +; + +value rec char len = + parser + [ [: `''' :] -> len + | [: `x; s :] -> char (Buff.store len x) s ] +; + +value quote = + parser + [ [: `'\\'; len = char (Buff.store 0 '\\') :] -> ("CHAR", Buff.get len) + | [: `x; s :] -> char_or_quote_id x s ] +; + +(* The system with LIDENTDOT and UIDENTDOT is not great (it would be *) +(* better to have a token DOT (actually SPACEDOT and DOT)) but it is *) +(* the only way (that I have found) to have a good behaviour in the *) +(* toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be *) +(* complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the *) +(* parser rule with dot is right associative and we have to reverse *) +(* the resulting tree (using the function leftify). *) +(* This is a complicated issue: the behaviour of the OCaml toplevel *) +(* is strange, anyway. For example, even without Camlp4, The OCaml *) +(* toplevel accepts that: *) +(* # let x = 32;; foo bar match let ) *) + +value rec lexer kwt = parser [: t = lexer0 kwt; _ = no_dot :] -> t +and no_dot = + parser + [ [: `'.' :] ep -> + Stdpp.raise_with_loc + (Reloc.shift_pos (ep - 1) Reloc.zero_loc, + Reloc.shift_pos ep Reloc.zero_loc) + (Stream.Error "bad dot") + | [: :] -> () ] +and lexer0 kwt = + parser bp + [ [: `'\t' | '\n' | '\r'; s :] -> lexer0 kwt s + | [: `' '; s :] -> after_space kwt s + | [: `';'; _ = skip_to_eol; s :] -> lexer kwt s + | [: `'(' :] -> (("", "("), (bp, bp + 1)) + | [: `')'; s :] ep -> (("", rparen s), (bp, ep)) + | [: `'[' :] -> (("", "["), (bp, bp + 1)) + | [: `']' :] -> (("", "]"), (bp, bp + 1)) + | [: `'{' :] -> (("", "{"), (bp, bp + 1)) + | [: `'}' :] -> (("", "}"), (bp, bp + 1)) + | [: `'"'; s = string 0 :] ep -> (("STRING", s), (bp, ep)) + | [: `'''; tok = quote :] ep -> (tok, (bp, ep)) + | [: `'<'; tok = less kwt :] ep -> (tok, (bp, ep)) + | [: `'-'; tok = minus kwt :] ep -> (tok, (bp, ep)) + | [: `'~'; tok = tilde :] ep -> (tok, (bp, ep)) + | [: `'?'; tok = question :] ep -> (tok, (bp, ep)) + | [: `'#'; tok = base_number kwt bp (Buff.store 0 '0') :] ep -> + (tok, (bp, ep)) + | [: `('0'..'9' as c); tok = number (Buff.store 0 c) :] ep -> + (tok, (bp, ep)) + | [: `('+' | '*' | '/' as c); id = operator (Buff.store 0 c) :] ep -> + (identifier kwt (id, False), (bp, ep)) + | [: `x; id = ident (Buff.store 0 x) :] ep -> (identifier kwt id, (bp, ep)) + | [: :] -> (("EOI", ""), (bp, bp + 1)) ] +and rparen = + parser + [ [: `'.' :] -> ")." + | [: ___ :] -> ")" ] +and after_space kwt = + parser + [ [: `'.' :] ep -> (("", "."), (ep - 1, ep)) + | [: x = lexer0 kwt :] -> x ] +and tilde = + parser + [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] -> + ("TILDEIDENT", s) + | [: :] -> ("LIDENT", "~") ] +and question = + parser + [ [: `('a'..'z' as c); (s, dot) = ident (Buff.store 0 c) :] -> + ("QUESTIONIDENT", s) + | [: :] -> ("LIDENT", "?") ] +and minus kwt = + parser + [ [: `'.' :] -> identifier kwt ("-.", False) + | [: `('0'..'9' as c); n = number (Buff.store (Buff.store 0 '-') c) :] -> + n + | [: id = ident (Buff.store 0 '-') :] -> identifier kwt id ] +and less kwt = + parser + [ [: `':'; lab = label 0; `'<' ? "'<' expected"; q = quotation 0 :] -> + ("QUOT", lab ^ ":" ^ q) + | [: id = ident (Buff.store 0 '<') :] -> identifier kwt id ] +and label len = + parser + [ [: `('a'..'z' | 'A'..'Z' | '_' as c); s :] -> label (Buff.store len c) s + | [: :] -> Buff.get len ] +and quotation len = + parser + [ [: `'>'; s :] -> quotation_greater len s + | [: `x; s :] -> quotation (Buff.store len x) s + | [: :] -> failwith "quotation not terminated" ] +and quotation_greater len = + parser + [ [: `'>' :] -> Buff.get len + | [: a = quotation (Buff.store len '>') :] -> a ] +; + +value lexer_using kwt (con, prm) = + match con with + [ "CHAR" | "EOI" | "INT" | "FLOAT" | "LIDENT" | "LIDENTDOT" | + "QUESTIONIDENT" | "QUOT" | "STRING" | "TILDEIDENT" | "UIDENT" | + "UIDENTDOT" -> + () + | "ANTIQUOT" -> () + | "" -> + try Hashtbl.find kwt prm with [ Not_found -> Hashtbl.add kwt prm () ] + | _ -> + raise + (Token.Error + ("the constructor \"" ^ con ^ "\" is not recognized by Plexer")) ] +; + +value lexer_text (con, prm) = + if con = "" then "'" ^ prm ^ "'" + else if prm = "" then con + else con ^ " \"" ^ prm ^ "\"" +; + +value lexer_gmake () = + let kwt = Hashtbl.create 89 in + {Token.tok_func = + Token.lexer_func_of_parser + (fun s -> + let (r, (bp, ep)) = lexer kwt s in + (r, + (Reloc.shift_pos bp Reloc.zero_loc, + Reloc.shift_pos ep Reloc.zero_loc))); + Token.tok_using = lexer_using kwt; Token.tok_removing = fun []; + Token.tok_match = Token.default_match; Token.tok_text = lexer_text; + Token.tok_comm = None} +; + +(* Building AST *) + +type sexpr = + [ Sacc of Loc.t and sexpr and sexpr + | Schar of Loc.t and string + | Sexpr of Loc.t and list sexpr + | Sint of Loc.t and string + | Sfloat of Loc.t and string + | Slid of Loc.t and string + | Slist of Loc.t and list sexpr + | Sqid of Loc.t and string + | Squot of Loc.t and string and string + | Srec of Loc.t and list sexpr + | Sstring of Loc.t and string + | Stid of Loc.t and string + | Suid of Loc.t and string ] +; + +value loc_of_sexpr = + fun [ + Sacc loc _ _ | Schar loc _ | Sexpr loc _ | Sint loc _ | Sfloat loc _ | + Slid loc _ | Slist loc _ | Sqid loc _ | Squot loc _ _ | Srec loc _ | + Sstring loc _ | Stid loc _ | Suid loc _ -> + loc ] +; +value error_loc loc err = + raise_with_loc loc (Stream.Error (err ^ " expected")) +; +value error se err = error_loc (loc_of_sexpr se) err; + +value strm_n = "__strm"; +value peek_fun loc = <:expr< Stream.peek >>; +value junk_fun loc = <:expr< Stream.junk >>; + +value assoc_left_parsed_op_list = + ["+"; "*"; "+."; "*."; "land"; "lor"; "lxor"] +; +value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"]; +value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="]; + +value op_apply loc e1 e2 = + fun + [ "and" -> <:expr< $e1$ && $e2$ >> + | "or" -> <:expr< $e1$ || $e2$ >> + | x -> <:expr< $lid:x$ $e1$ $e2$ >> ] +; + +value string_se = + fun + [ Sstring loc s -> s + | se -> error se "string" ] +; + +value mod_ident_se = + fun + [ Suid _ s -> [Pcaml.rename_id.val s] + | Slid _ s -> [Pcaml.rename_id.val s] + | se -> error se "mod_ident" ] +; + +value lident_expr loc s = + if String.length s > 1 && s.[0] = '`' then + let s = String.sub s 1 (String.length s - 1) in + <:expr< ` $s$ >> + else <:expr< $lid:(Pcaml.rename_id.val s)$ >> +; + +value rec module_expr_se = + fun + [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] -> + let s = Pcaml.rename_id.val s in + let mt = module_type_se se1 in + let me = module_expr_se se2 in + <:module_expr< functor ($s$ : $mt$) -> $me$ >> + | Sexpr loc [Slid _ "struct" :: sl] -> + let mel = List.map str_item_se sl in + <:module_expr< struct $list:mel$ end >> + | Sexpr loc [se1; se2] -> + let me1 = module_expr_se se1 in + let me2 = module_expr_se se2 in + <:module_expr< $me1$ $me2$ >> + | Suid loc s -> <:module_expr< $uid:(Pcaml.rename_id.val s)$ >> + | se -> error se "module expr" ] +and module_type_se = + fun + [ Sexpr loc [Slid _ "functor"; Suid _ s; se1; se2] -> + let s = Pcaml.rename_id.val s in + let mt1 = module_type_se se1 in + let mt2 = module_type_se se2 in + <:module_type< functor ($s$ : $mt1$) -> $mt2$ >> + | Sexpr loc [Slid _ "sig" :: sel] -> + let sil = List.map sig_item_se sel in + <:module_type< sig $list:sil$ end >> + | Sexpr loc [Slid _ "with"; se; Sexpr _ sel] -> + let mt = module_type_se se in + let wcl = List.map with_constr_se sel in + <:module_type< $mt$ with $list:wcl$ >> + | Suid loc s -> <:module_type< $uid:(Pcaml.rename_id.val s)$ >> + | se -> error se "module type" ] +and with_constr_se = + fun + [ Sexpr loc [Slid _ "type"; se1; se2] -> + let tn = mod_ident_se se1 in + let te = ctyp_se se2 in + MLast.WcTyp loc tn [] te + | se -> error se "with constr" ] +and sig_item_se = + fun + [ Sexpr loc [Slid _ "type" :: sel] -> + let tdl = type_declaration_list_se sel in + <:sig_item< type $list:tdl$ >> + | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] -> + let c = Pcaml.rename_id.val c in + let tl = List.map ctyp_se sel in + <:sig_item< exception $c$ of $list:tl$ >> + | Sexpr loc [Slid _ "value"; Slid _ s; se] -> + let s = Pcaml.rename_id.val s in + let t = ctyp_se se in + <:sig_item< value $s$ : $t$ >> + | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] -> + let i = Pcaml.rename_id.val i in + let pd = List.map string_se sel in + let t = ctyp_se se in + <:sig_item< external $i$ : $t$ = $list:pd$ >> + | Sexpr loc [Slid _ "module"; Suid _ s; se] -> + let s = Pcaml.rename_id.val s in + let mb = module_type_se se in + <:sig_item< module $s$ : $mb$ >> + | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] -> + let s = Pcaml.rename_id.val s in + let mt = module_type_se se in + <:sig_item< module type $s$ = $mt$ >> + | se -> error se "sig item" ] +and str_item_se se = + match se with + [ Sexpr loc [Slid _ "open"; se] -> + let s = mod_ident_se se in + <:str_item< open $s$ >> + | Sexpr loc [Slid _ "type" :: sel] -> + let tdl = type_declaration_list_se sel in + <:str_item< type $list:tdl$ >> + | Sexpr loc [Slid _ "exception"; Suid _ c :: sel] -> + let c = Pcaml.rename_id.val c in + let tl = List.map ctyp_se sel in + <:str_item< exception $c$ of $list:tl$ >> + | Sexpr loc [Slid _ ("define" | "definerec" as r); se :: sel] -> + let r = r = "definerec" in + let (p, e) = fun_binding_se se (begin_se loc sel) in + <:str_item< value $opt:r$ $p$ = $e$ >> + | Sexpr loc [Slid _ ("define*" | "definerec*" as r) :: sel] -> + let r = r = "definerec*" in + let lbs = List.map let_binding_se sel in + <:str_item< value $opt:r$ $list:lbs$ >> + | Sexpr loc [Slid _ "external"; Slid _ i; se :: sel] -> + let i = Pcaml.rename_id.val i in + let pd = List.map string_se sel in + let t = ctyp_se se in + <:str_item< external $i$ : $t$ = $list:pd$ >> + | Sexpr loc [Slid _ "module"; Suid _ i; se] -> + let i = Pcaml.rename_id.val i in + let mb = module_binding_se se in + <:str_item< module $i$ = $mb$ >> + | Sexpr loc [Slid _ "moduletype"; Suid _ s; se] -> + let s = Pcaml.rename_id.val s in + let mt = module_type_se se in + <:str_item< module type $s$ = $mt$ >> + | _ -> + let loc = loc_of_sexpr se in + let e = expr_se se in + <:str_item< $exp:e$ >> ] +and module_binding_se se = module_expr_se se +and expr_se = + fun + [ Sacc loc se1 se2 -> + let e1 = expr_se se1 in + match se2 with + [ Slist loc [se2] -> + let e2 = expr_se se2 in + <:expr< $e1$ .[ $e2$ ] >> + | Sexpr loc [se2] -> + let e2 = expr_se se2 in + <:expr< $e1$ .( $e2$ ) >> + | _ -> + let e2 = expr_se se2 in + <:expr< $e1$ . $e2$ >> ] + | Slid loc s -> lident_expr loc s + | Suid loc s -> <:expr< $uid:(Pcaml.rename_id.val s)$ >> + | Sint loc s -> <:expr< $int:s$ >> + | Sfloat loc s -> <:expr< $flo:s$ >> + | Schar loc s -> <:expr< $chr:s$ >> + | Sstring loc s -> <:expr< $str:s$ >> + | Stid loc s -> <:expr< ~ $(Pcaml.rename_id.val s)$ >> + | Sqid loc s -> <:expr< ? $(Pcaml.rename_id.val s)$ >> + | Sexpr loc [] -> <:expr< () >> + | Sexpr loc [Slid _ s; e1 :: ([_ :: _] as sel)] + when List.mem s assoc_left_parsed_op_list -> + let rec loop e1 = + fun + [ [] -> e1 + | [e2 :: el] -> loop (op_apply loc e1 e2 s) el ] + in + loop (expr_se e1) (List.map expr_se sel) + | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)] + when List.mem s assoc_right_parsed_op_list -> + let rec loop = + fun + [ [] -> assert False + | [e1] -> e1 + | [e1 :: el] -> + let e2 = loop el in + op_apply loc e1 e2 s ] + in + loop (List.map expr_se sel) + | Sexpr loc [Slid _ s :: ([_; _ :: _] as sel)] + when List.mem s and_by_couple_op_list -> + let rec loop = + fun + [ [] | [_] -> assert False + | [e1; e2] -> <:expr< $lid:s$ $e1$ $e2$ >> + | [e1 :: ([e2; _ :: _] as el)] -> + let a1 = op_apply loc e1 e2 s in + let a2 = loop el in + <:expr< $a1$ && $a2$ >> ] + in + loop (List.map expr_se sel) + | Sexpr loc [Stid _ s; se] -> + let e = expr_se se in + <:expr< ~ $s$ : $e$ >> + | Sexpr loc [Slid _ "-"; se] -> + let e = expr_se se in + <:expr< - $e$ >> + | Sexpr loc [Slid _ "if"; se; se1] -> + let e = expr_se se in + let e1 = expr_se se1 in + <:expr< if $e$ then $e1$ else () >> + | Sexpr loc [Slid _ "if"; se; se1; se2] -> + let e = expr_se se in + let e1 = expr_se se1 in + let e2 = expr_se se2 in + <:expr< if $e$ then $e1$ else $e2$ >> + | Sexpr loc [Slid _ "cond" :: sel] -> + let rec loop = + fun + [ [Sexpr loc [Slid _ "else" :: sel]] -> begin_se loc sel + | [Sexpr loc [se1 :: sel1] :: sel] -> + let e1 = expr_se se1 in + let e2 = begin_se loc sel1 in + let e3 = loop sel in + <:expr< if $e1$ then $e2$ else $e3$ >> + | [] -> <:expr< () >> + | [se :: _] -> error se "cond clause" ] + in + loop sel + | Sexpr loc [Slid _ "while"; se :: sel] -> + let e = expr_se se in + let el = List.map expr_se sel in + <:expr< while $e$ do { $list:el$ } >> + | Sexpr loc [Slid _ "for"; Slid _ i; se1; se2 :: sel] -> + let i = Pcaml.rename_id.val i in + let e1 = expr_se se1 in + let e2 = expr_se se2 in + let el = List.map expr_se sel in + <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> + | Sexpr loc [Slid loc1 "lambda"] -> <:expr< fun [] >> + | Sexpr loc [Slid loc1 "lambda"; sep :: sel] -> + let e = begin_se loc1 sel in + match ipatt_opt_se sep with + [ Left p -> <:expr< fun $p$ -> $e$ >> + | Right (se, sel) -> + List.fold_right + (fun se e -> + let p = ipatt_se se in + <:expr< fun $p$ -> $e$ >>) + [se :: sel] e ] + | Sexpr loc [Slid _ "lambda_match" :: sel] -> + let pel = List.map (match_case loc) sel in + <:expr< fun [ $list:pel$ ] >> + | Sexpr loc [Slid _ ("let" | "letrec" as r) :: sel] -> + match sel with + [ [Sexpr _ sel1 :: sel2] -> + let r = r = "letrec" in + let lbs = List.map let_binding_se sel1 in + let e = begin_se loc sel2 in + <:expr< let $opt:r$ $list:lbs$ in $e$ >> + | [Slid _ n; Sexpr _ sl :: sel] -> + let n = Pcaml.rename_id.val n in + let (pl, el) = + List.fold_right + (fun se (pl, el) -> + match se with + [ Sexpr _ [se1; se2] -> + ([patt_se se1 :: pl], [expr_se se2 :: el]) + | se -> error se "named let" ]) + sl ([], []) + in + let e1 = + List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl + (begin_se loc sel) + in + let e2 = + List.fold_left (fun e1 e2 -> <:expr< $e1$ $e2$ >>) + <:expr< $lid:n$ >> el + in + <:expr< let rec $lid:n$ = $e1$ in $e2$ >> + | [se :: _] -> error se "let_binding" + | _ -> error_loc loc "let_binding" ] + | Sexpr loc [Slid _ "let*" :: sel] -> + match sel with + [ [Sexpr _ sel1 :: sel2] -> + List.fold_right + (fun se ek -> + let (p, e) = let_binding_se se in + <:expr< let $p$ = $e$ in $ek$ >>) + sel1 (begin_se loc sel2) + | [se :: _] -> error se "let_binding" + | _ -> error_loc loc "let_binding" ] + | Sexpr loc [Slid _ "match"; se :: sel] -> + let e = expr_se se in + let pel = List.map (match_case loc) sel in + <:expr< match $e$ with [ $list:pel$ ] >> + | Sexpr loc [Slid _ "parser" :: sel] -> + let e = + match sel with + [ [(Slid _ _ as se) :: sel] -> + let p = patt_se se in + let pc = parser_cases_se loc sel in + <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >> + | _ -> parser_cases_se loc sel ] + in + <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >> + | Sexpr loc [Slid _ "match_with_parser"; se :: sel] -> + let me = expr_se se in + let (bpo, sel) = + match sel with + [ [(Slid _ _ as se) :: sel] -> (Some (patt_se se), sel) + | _ -> (None, sel) ] + in + let pc = parser_cases_se loc sel in + let e = + match bpo with + [ Some bp -> <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >> + | None -> pc ] + in + match me with + [ <:expr< $lid:x$ >> when x = strm_n -> e + | _ -> <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >> ] + | Sexpr loc [Slid _ "try"; se :: sel] -> + let e = expr_se se in + let pel = List.map (match_case loc) sel in + <:expr< try $e$ with [ $list:pel$ ] >> + | Sexpr loc [Slid _ "begin" :: sel] -> + let el = List.map expr_se sel in + <:expr< do { $list:el$ } >> + | Sexpr loc [Slid _ ":="; se1; se2] -> + let e1 = expr_se se1 in + let e2 = expr_se se2 in + <:expr< $e1$ := $e2$ >> + | Sexpr loc [Slid _ "values" :: sel] -> + let el = List.map expr_se sel in + <:expr< ( $list:el$ ) >> + | Srec loc [Slid _ "with"; se :: sel] -> + let e = expr_se se in + let lel = List.map (label_expr_se loc) sel in + <:expr< { ($e$) with $list:lel$ } >> + | Srec loc sel -> + let lel = List.map (label_expr_se loc) sel in + <:expr< { $list:lel$ } >> + | Sexpr loc [Slid _ ":"; se1; se2] -> + let e = expr_se se1 in + let t = ctyp_se se2 in + <:expr< ( $e$ : $t$ ) >> + | Sexpr loc [se] -> + let e = expr_se se in + <:expr< $e$ () >> + | Sexpr loc [Slid _ "assert"; Suid _ "False"] -> <:expr< assert False >> + | Sexpr loc [Slid _ "assert"; se] -> + let e = expr_se se in + <:expr< assert $e$ >> + | Sexpr loc [Slid _ "lazy"; se] -> + let e = expr_se se in + <:expr< lazy $e$ >> + | Sexpr loc [se :: sel] -> + List.fold_left + (fun e se -> + let e1 = expr_se se in + <:expr< $e$ $e1$ >>) + (expr_se se) sel + | Slist loc sel -> + let rec loop = + fun + [ [] -> <:expr< [] >> + | [se1; Slid _ "."; se2] -> + let e = expr_se se1 in + let el = expr_se se2 in + <:expr< [$e$ :: $el$] >> + | [se :: sel] -> + let e = expr_se se in + let el = loop sel in + <:expr< [$e$ :: $el$] >> ] + in + loop sel + | Squot loc typ txt -> Pcaml.handle_expr_quotation loc (typ, txt) ] +and begin_se loc = + fun + [ [] -> <:expr< () >> + | [se] -> expr_se se + | sel -> + let el = List.map expr_se sel in + let loc = (fst (loc_of_sexpr (List.hd sel)), snd loc) in + <:expr< do { $list:el$ } >> ] +and let_binding_se = + fun + [ Sexpr loc [se :: sel] -> + let e = begin_se loc sel in + match ipatt_opt_se se with + [ Left p -> (p, e) + | Right _ -> fun_binding_se se e ] + | se -> error se "let_binding" ] +and fun_binding_se se e = + match se with + [ Sexpr _ [Slid _ "values" :: _] -> (ipatt_se se, e) + | Sexpr _ [Slid loc s :: sel] -> + let s = Pcaml.rename_id.val s in + let e = + List.fold_right + (fun se e -> + let loc = (fst (loc_of_sexpr se), snd (MLast.loc_of_expr e)) in + let p = ipatt_se se in + <:expr< fun $p$ -> $e$ >>) + sel e + in + let p = <:patt< $lid:s$ >> in + (p, e) + | _ -> (ipatt_se se, e) ] +and match_case loc = + fun + [ Sexpr loc [Sexpr _ [Slid _ "when"; se; sew] :: sel] -> + (patt_se se, Some (expr_se sew), begin_se loc sel) + | Sexpr loc [se :: sel] -> (patt_se se, None, begin_se loc sel) + | se -> error se "match_case" ] +and label_expr_se loc = + fun + [ Sexpr _ [se1; se2] -> (patt_se se1, expr_se se2) + | se -> error se "label_expr" ] +and label_patt_se loc = + fun + [ Sexpr _ [se1; se2] -> (patt_se se1, patt_se se2) + | se -> error se "label_patt" ] +and parser_cases_se loc = + fun + [ [] -> <:expr< raise Stream.Failure >> + | [Sexpr loc [Sexpr _ spsel :: act] :: sel] -> + let ekont _ = parser_cases_se loc sel in + let act = + match act with + [ [se] -> expr_se se + | [sep; se] -> + let p = patt_se sep in + let e = expr_se se in + <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >> + | _ -> error_loc loc "parser_case" ] + in + stream_pattern_se loc act ekont spsel + | [se :: _] -> error se "parser_case" ] +and stream_pattern_se loc act ekont = + fun + [ [] -> act + | [se :: sel] -> + let ckont err = <:expr< raise (Stream.Error $err$) >> in + let skont = stream_pattern_se loc act ckont sel in + stream_pattern_component skont ekont <:expr< "" >> se ] +and stream_pattern_component skont ekont err = + fun + [ Sexpr loc [Slid _ "`"; se :: wol] -> + let wo = + match wol with + [ [se] -> Some (expr_se se) + | [] -> None + | _ -> error_loc loc "stream_pattern_component" ] + in + let e = peek_fun loc in + let p = patt_se se in + let j = junk_fun loc in + let k = ekont err in + <:expr< match $e$ $lid:strm_n$ with + [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } + | _ -> $k$ ] >> + | Sexpr loc [se1; se2] -> + let p = patt_se se1 in + let e = + let e = expr_se se2 in + <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >> + in + let k = ekont err in + <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >> + | Sexpr loc [Slid _ "?"; se1; se2] -> + stream_pattern_component skont ekont (expr_se se2) se1 + | Slid loc s -> + let s = Pcaml.rename_id.val s in + <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >> + | se -> error se "stream_pattern_component" ] +and patt_se = + fun + [ Sacc loc se1 se2 -> + let p1 = patt_se se1 in + let p2 = patt_se se2 in + <:patt< $p1$ . $p2$ >> + | Slid loc "_" -> <:patt< _ >> + | Slid loc s -> <:patt< $lid:(Pcaml.rename_id.val s)$ >> + | Suid loc s -> <:patt< $uid:(Pcaml.rename_id.val s)$ >> + | Sint loc s -> <:patt< $int:s$ >> + | Sfloat loc s -> <:patt< $flo:s$ >> + | Schar loc s -> <:patt< $chr:s$ >> + | Sstring loc s -> <:patt< $str:s$ >> + | Stid loc _ -> error_loc loc "patt" + | Sqid loc _ -> error_loc loc "patt" + | Srec loc sel -> + let lpl = List.map (label_patt_se loc) sel in + <:patt< { $list:lpl$ } >> + | Sexpr loc [Slid _ ":"; se1; se2] -> + let p = patt_se se1 in + let t = ctyp_se se2 in + <:patt< ($p$ : $t$) >> + | Sexpr loc [Slid _ "or"; se :: sel] -> + List.fold_left + (fun p se -> + let p1 = patt_se se in + <:patt< $p$ | $p1$ >>) + (patt_se se) sel + | Sexpr loc [Slid _ "range"; se1; se2] -> + let p1 = patt_se se1 in + let p2 = patt_se se2 in + <:patt< $p1$ .. $p2$ >> + | Sexpr loc [Slid _ "values" :: sel] -> + let pl = List.map patt_se sel in + <:patt< ( $list:pl$ ) >> + | Sexpr loc [Slid _ "as"; se1; se2] -> + let p1 = patt_se se1 in + let p2 = patt_se se2 in + <:patt< ($p1$ as $p2$) >> + | Sexpr loc [se :: sel] -> + List.fold_left + (fun p se -> + let p1 = patt_se se in + <:patt< $p$ $p1$ >>) + (patt_se se) sel + | Sexpr loc [] -> <:patt< () >> + | Slist loc sel -> + let rec loop = + fun + [ [] -> <:patt< [] >> + | [se1; Slid _ "."; se2] -> + let p = patt_se se1 in + let pl = patt_se se2 in + <:patt< [$p$ :: $pl$] >> + | [se :: sel] -> + let p = patt_se se in + let pl = loop sel in + <:patt< [$p$ :: $pl$] >> ] + in + loop sel + | Squot loc typ txt -> Pcaml.handle_patt_quotation loc (typ, txt) ] +and ipatt_se se = + match ipatt_opt_se se with + [ Left p -> p + | Right (se, _) -> error se "ipatt" ] +and ipatt_opt_se = + fun + [ Slid loc "_" -> Left <:patt< _ >> + | Slid loc s -> Left <:patt< $lid:(Pcaml.rename_id.val s)$ >> + | Stid loc s -> Left <:patt< ~ $(Pcaml.rename_id.val s)$ >> + | Sqid loc s -> Left <:patt< ? $(Pcaml.rename_id.val s)$ >> + | Sexpr loc [Sqid _ s; se] -> + let s = Pcaml.rename_id.val s in + let e = expr_se se in + Left <:patt< ? ( $lid:s$ = $e$ ) >> + | Sexpr loc [Slid _ ":"; se1; se2] -> + let p = ipatt_se se1 in + let t = ctyp_se se2 in + Left <:patt< ($p$ : $t$) >> + | Sexpr loc [Slid _ "values" :: sel] -> + let pl = List.map ipatt_se sel in + Left <:patt< ( $list:pl$ ) >> + | Sexpr loc [] -> Left <:patt< () >> + | Sexpr loc [se :: sel] -> Right (se, sel) + | se -> error se "ipatt" ] +and type_declaration_list_se = + fun + [ [se1; se2 :: sel] -> + let (n1, loc1, tpl) = + match se1 with + [ Sexpr _ [Slid loc n :: sel] -> + (n, loc, List.map type_parameter_se sel) + | Slid loc n -> (n, loc, []) + | se -> error se "type declaration" ] + in + [((loc1, Pcaml.rename_id.val n1), tpl, ctyp_se se2, []) :: + type_declaration_list_se sel] + | [] -> [] + | [se :: _] -> error se "type_declaration" ] +and type_parameter_se = + fun + [ Slid _ s when String.length s >= 2 && s.[0] = ''' -> + (String.sub s 1 (String.length s - 1), (False, False)) + | se -> error se "type_parameter" ] +and ctyp_se = + fun + [ Sexpr loc [Slid _ "sum" :: sel] -> + let cdl = List.map constructor_declaration_se sel in + <:ctyp< [ $list:cdl$ ] >> + | Srec loc sel -> + let ldl = List.map label_declaration_se sel in + <:ctyp< { $list:ldl$ } >> + | Sexpr loc [Slid _ "->" :: ([_; _ :: _] as sel)] -> + let rec loop = + fun + [ [] -> assert False + | [se] -> ctyp_se se + | [se :: sel] -> + let t1 = ctyp_se se in + let loc = (fst (loc_of_sexpr se), snd loc) in + let t2 = loop sel in + <:ctyp< $t1$ -> $t2$ >> ] + in + loop sel + | Sexpr loc [Slid _ "*" :: sel] -> + let tl = List.map ctyp_se sel in + <:ctyp< ($list:tl$) >> + | Sexpr loc [se :: sel] -> + List.fold_left + (fun t se -> + let t2 = ctyp_se se in + <:ctyp< $t$ $t2$ >>) + (ctyp_se se) sel + | Sacc loc se1 se2 -> + let t1 = ctyp_se se1 in + let t2 = ctyp_se se2 in + <:ctyp< $t1$ . $t2$ >> + | Slid loc "_" -> <:ctyp< _ >> + | Slid loc s -> + if s.[0] = ''' then + let s = String.sub s 1 (String.length s - 1) in + <:ctyp< '$s$ >> + else <:ctyp< $lid:(Pcaml.rename_id.val s)$ >> + | Suid loc s -> <:ctyp< $uid:(Pcaml.rename_id.val s)$ >> + | se -> error se "ctyp" ] +and constructor_declaration_se = + fun + [ Sexpr loc [Suid _ ci :: sel] -> + (loc, Pcaml.rename_id.val ci, List.map ctyp_se sel) + | se -> error se "constructor_declaration" ] +and label_declaration_se = + fun + [ Sexpr loc [Slid _ lab; Slid _ "mutable"; se] -> + (loc, Pcaml.rename_id.val lab, True, ctyp_se se) + | Sexpr loc [Slid _ lab; se] -> + (loc, Pcaml.rename_id.val lab, False, ctyp_se se) + | se -> error se "label_declaration" ] +; + +value directive_se = + fun + [ Sexpr _ [Slid _ s] -> (s, None) + | Sexpr _ [Slid _ s; se] -> + let e = expr_se se in + (s, Some e) + | se -> error se "directive" ] +; + +(* Parser *) + +Pcaml.syntax_name.val := "Scheme"; +Pcaml.no_constructors_arity.val := False; + +do { + Grammar.Unsafe.gram_reinit gram (lexer_gmake ()); + Grammar.Unsafe.clear_entry interf; + Grammar.Unsafe.clear_entry implem; + Grammar.Unsafe.clear_entry top_phrase; + Grammar.Unsafe.clear_entry use_file; + Grammar.Unsafe.clear_entry module_type; + Grammar.Unsafe.clear_entry module_expr; + Grammar.Unsafe.clear_entry sig_item; + Grammar.Unsafe.clear_entry str_item; + Grammar.Unsafe.clear_entry expr; + Grammar.Unsafe.clear_entry patt; + Grammar.Unsafe.clear_entry ctyp; + Grammar.Unsafe.clear_entry let_binding; + Grammar.Unsafe.clear_entry type_declaration; + Grammar.Unsafe.clear_entry class_type; + Grammar.Unsafe.clear_entry class_expr; + Grammar.Unsafe.clear_entry class_sig_item; + Grammar.Unsafe.clear_entry class_str_item +}; + +Pcaml.parse_interf.val := Grammar.Entry.parse interf; +Pcaml.parse_implem.val := Grammar.Entry.parse implem; + +value sexpr = Grammar.Entry.create gram "sexpr"; + +value rec leftify = + fun + [ Sacc loc1 se1 se2 -> + match leftify se2 with + [ Sacc loc2 se2 se3 -> Sacc loc1 (Sacc loc2 se1 se2) se3 + | se2 -> Sacc loc1 se1 se2 ] + | x -> x ] +; + +EXTEND + GLOBAL: implem interf top_phrase use_file str_item sig_item expr patt sexpr; + implem: + [ [ "#"; se = sexpr -> + let (n, dp) = directive_se se in + ([(<:str_item< # $n$ $opt:dp$ >>, loc)], True) + | si = str_item; x = SELF -> + let (sil, stopped) = x in + let loc = MLast.loc_of_str_item si in + ([(si, loc) :: sil], stopped) + | EOI -> ([], False) ] ] + ; + interf: + [ [ "#"; se = sexpr -> + let (n, dp) = directive_se se in + ([(<:sig_item< # $n$ $opt:dp$ >>, loc)], True) + | si = sig_item; x = SELF -> + let (sil, stopped) = x in + let loc = MLast.loc_of_sig_item si in + ([(si, loc) :: sil], stopped) + | EOI -> ([], False) ] ] + ; + top_phrase: + [ [ "#"; se = sexpr -> + let (n, dp) = directive_se se in + Some <:str_item< # $n$ $opt:dp$ >> + | se = sexpr -> Some (str_item_se se) + | EOI -> None ] ] + ; + use_file: + [ [ "#"; se = sexpr -> + let (n, dp) = directive_se se in + ([<:str_item< # $n$ $opt:dp$ >>], True) + | si = str_item; x = SELF -> + let (sil, stopped) = x in + ([si :: sil], stopped) + | EOI -> ([], False) ] ] + ; + str_item: + [ [ se = sexpr -> str_item_se se + | e = expr -> <:str_item< $exp:e$ >> ] ] + ; + sig_item: + [ [ se = sexpr -> sig_item_se se ] ] + ; + expr: + [ "top" + [ se = sexpr -> expr_se se ] ] + ; + patt: + [ [ se = sexpr -> patt_se se ] ] + ; + sexpr: + [ [ se1 = sexpr_dot; se2 = SELF -> leftify (Sacc loc se1 se2) ] + | [ "("; sl = LIST0 sexpr; ")" -> Sexpr loc sl + | "("; sl = LIST0 sexpr; ")."; se = SELF -> + leftify (Sacc loc (Sexpr loc sl) se) + | "["; sl = LIST0 sexpr; "]" -> Slist loc sl + | "{"; sl = LIST0 sexpr; "}" -> Srec loc sl + | a = pa_extend_keyword -> Slid loc a + | s = LIDENT -> Slid loc s + | s = UIDENT -> Suid loc s + | s = TILDEIDENT -> Stid loc s + | s = QUESTIONIDENT -> Sqid loc s + | s = INT -> Sint loc s + | s = FLOAT -> Sfloat loc s + | s = CHAR -> Schar loc s + | s = STRING -> Sstring loc s + | s = QUOT -> + let i = String.index s ':' in + let typ = String.sub s 0 i in + let txt = String.sub s (i + 1) (String.length s - i - 1) in + Squot loc typ txt ] ] + ; + sexpr_dot: + [ [ s = LIDENTDOT -> Slid loc s + | s = UIDENTDOT -> Suid loc s ] ] + ; + pa_extend_keyword: + [ [ "_" -> "_" + | "," -> "," + | "=" -> "=" + | ":" -> ":" + | "." -> "." + | "/" -> "/" ] ] + ; +END; diff --git a/ocaml-binary-annot/camlp4/unmaintained/scheme/pa_scheme.sc b/ocaml-binary-annot/camlp4/unmaintained/scheme/pa_scheme.sc new file mode 100644 index 0000000000..cc6de1894b --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/scheme/pa_scheme.sc @@ -0,0 +1,1029 @@ +; pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo +; ********************************************************************** +; +; Camlp4 +; +; Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt +; +; Copyright 2002 Institut National de Recherche en Informatique et +; en Automatique. All rights reserved. This file is distributed +; under the terms of the GNU Library General Public License, with +; the special exception on linking described in file +; ../../../LICENSE. +; +; ********************************************************************** + +(open Pcaml) +(open Stdpp) + +(type (choice 'a 'b) (sum (Left 'a) (Right 'b))) + +; Buffer + +(module Buff + (struct + (define buff (ref (String.create 80))) + (define (store len x) + (if (>= len (String.length buff.val)) + (:= buff.val (^ buff.val (String.create (String.length buff.val))))) + (:= buff.val.[len] x) + (succ len)) + (define (get len) (String.sub buff.val 0 len)))) + +; Lexer + +(definerec skip_to_eol + (parser + (((` (or '\n' '\r'))) ()) + (((` _) s) (skip_to_eol s)))) + +(define no_ident ['(' ')' '[' ']' '{' '}' ' ' '\t' '\n' '\r' ';']) + +(definerec (ident len) + (parser + (((` '.')) (values (Buff.get len) True)) + (((` x (not (List.mem x no_ident))) s) (ident (Buff.store len x) s)) + (() (values (Buff.get len) False)))) + +(define (identifier kwt (values s dot)) + (let ((con + (try (begin (: (Hashtbl.find kwt s) unit) "") + (Not_found + (match s.[0] + ((range 'A' 'Z') (if dot "UIDENTDOT" "UIDENT")) + (_ (if dot "LIDENTDOT" "LIDENT"))))))) + (values con s))) + +(definerec (string len) + (parser + (((` '"')) (Buff.get len)) + (((` '\\') (` c) s) (string (Buff.store (Buff.store len '\\') c) s)) + (((` x) s) (string (Buff.store len x) s)))) + +(definerec (end_exponent_part_under len) + (parser + (((` (as (range '0' '9') c)) s) + (end_exponent_part_under (Buff.store len c) s)) + (() (values "FLOAT" (Buff.get len))))) + +(define (end_exponent_part len) + (parser + (((` (as (range '0' '9') c)) s) + (end_exponent_part_under (Buff.store len c) s)) + (() (raise (Stream.Error "ill-formed floating-point constant"))))) + +(define (exponent_part len) + (parser + (((` (as (or '+' '-') c)) s) (end_exponent_part (Buff.store len c) s)) + (((a (end_exponent_part len))) a))) + +(definerec (decimal_part len) + (parser + (((` (as (range '0' '9') c)) s) (decimal_part (Buff.store len c) s)) + (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s)) + (() (values "FLOAT" (Buff.get len))))) + +(definerec (number len) + (parser + (((` (as (range '0' '9') c)) s) (number (Buff.store len c) s)) + (((` '.') s) (decimal_part (Buff.store len '.') s)) + (((` (or 'e' 'E')) s) (exponent_part (Buff.store len 'E') s)) + (() (values "INT" (Buff.get len))))) + +(define binary + (parser + (((` (as (range '0' '1') c))) c))) + +(define octal + (parser + (((` (as (range '0' '7') c))) c))) + +(define hexa + (parser + (((` (as (or (range '0' '9') (range 'a' 'f') (range 'A' 'F')) c))) c))) + +(definerec (digits_under kind len) + (parser + (((d kind) s) (digits_under kind (Buff.store len d) s)) + (() (Buff.get len)))) + +(define (digits kind bp len) + (parser + (((d kind) s) (values "INT" (digits_under kind (Buff.store len d) s))) + ((s) ep + (raise_with_loc (values + (Reloc.shift_pos bp Reloc.zero_loc) + (Reloc.shift_pos ep Reloc.zero_loc)) + (Failure "ill-formed integer constant"))))) + +(define (base_number kwt bp len) + (parser + (((` (or 'b' 'B')) s) (digits binary bp (Buff.store len 'b') s)) + (((` (or 'o' 'O')) s) (digits octal bp (Buff.store len 'o') s)) + (((` (or 'x' 'X')) s) (digits hexa bp (Buff.store len 'x') s)) + (((id (ident (Buff.store 0 '#')))) (identifier kwt id)))) + +(definerec (operator len) + (parser + (((` '.')) (Buff.get (Buff.store len '.'))) + (() (Buff.get len)))) + +(define (char_or_quote_id x) + (parser + (((` ''')) (values "CHAR" (String.make 1 x))) + ((s) ep + (if (List.mem x no_ident) + (Stdpp.raise_with_loc (values + (Reloc.shift_pos (- ep 2) Reloc.zero_loc) + (Reloc.shift_pos (- ep 1) Reloc.zero_loc)) + (Stream.Error "bad quote")) + (let* ((len (Buff.store (Buff.store 0 ''') x)) + ((values s dot) (ident len s))) + (values (if dot "LIDENTDOT" "LIDENT") s)))))) + +(definerec (char len) + (parser + (((` ''')) len) + (((` x) s) (char (Buff.store len x) s)))) + +(define quote + (parser + (((` '\\') (len (char (Buff.store 0 '\\')))) + (values "CHAR" (Buff.get len))) + (((` x) s) (char_or_quote_id x s)))) + +; The system with LIDENTDOT and UIDENTDOT is not great (it would be +; better to have a token DOT (actually SPACEDOT and DOT)) but it is +; the only way (that I have found) to have a good behaviour in the +; toplevel (not expecting tokens after a phrase). Drawbacks: 1/ to be +; complete, we should have STRINGDOT, RIGHTPARENDOT, and so on 2/ the +; parser rule with dot is right associative and we have to reverse +; the resulting tree (using the function leftify). +; This is a complicated issue: the behaviour of the OCaml toplevel +; is strange, anyway. For example, even without Camlp4, The OCaml +; toplevel accepts that: +; # let x = 32;; foo bar match let ) + +(definerec* + ((lexer kwt) + (parser + (((t (lexer0 kwt)) + (_ no_dot)) t))) + (no_dot + (parser + (((` '.')) ep + (Stdpp.raise_with_loc (values + (Reloc.shift_pos (- ep 1) Reloc.zero_loc) + (Reloc.shift_pos ep Reloc.zero_loc)) + (Stream.Error "bad dot"))) + (() ()))) + ((lexer0 kwt) + (parser bp + (((` (or '\t' '\n' '\r')) s) (lexer0 kwt s)) + (((` ' ') s) (after_space kwt s)) + (((` ';') (_ skip_to_eol) s) (lexer kwt s)) + (((` '(')) (values (values "" "(") (values bp (+ bp 1)))) + (((` ')') s) ep (values (values "" (rparen s)) (values bp ep))) + (((` '[')) (values (values "" "[") (values bp (+ bp 1)))) + (((` ']')) (values (values "" "]") (values bp (+ bp 1)))) + (((` '{')) (values (values "" "{") (values bp (+ bp 1)))) + (((` '}')) (values (values "" "}") (values bp (+ bp 1)))) + (((` '"') (s (string 0))) ep + (values (values "STRING" s) (values bp ep))) + (((` ''') (tok quote)) ep (values tok (values bp ep))) + (((` '<') (tok (less kwt))) ep (values tok (values bp ep))) + (((` '-') (tok (minus kwt))) ep (values tok (values bp ep))) + (((` '~') (tok tilde)) ep (values tok (values bp ep))) + (((` '?') (tok question)) ep (values tok (values bp ep))) + (((` '#') (tok (base_number kwt bp (Buff.store 0 '0')))) ep + (values tok (values bp ep))) + (((` (as (range '0' '9') c)) (tok (number (Buff.store 0 c)))) ep + (values tok (values bp ep))) + (((` (as (or '+' '*' '/') c)) (id (operator (Buff.store 0 c)))) ep + (values (identifier kwt (values id False)) (values bp ep))) + (((` x) (id (ident (Buff.store 0 x)))) ep + (values (identifier kwt id) (values bp ep))) + (() (values (values "EOI" "") (values bp (+ bp 1)))))) + (rparen + (parser + (((` '.')) ").") + ((_) ")"))) + ((after_space kwt) + (parser + (((` '.')) ep (values (values "" ".") (values (- ep 1) ep))) + (((x (lexer0 kwt))) x))) + (tilde + (parser + (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c)))) + (values "TILDEIDENT" s)) + (() (values "LIDENT" "~")))) + (question + (parser + (((` (as (range 'a' 'z') c)) ((values s dot) (ident (Buff.store 0 c)))) + (values "QUESTIONIDENT" s)) + (() (values "LIDENT" "?")))) + ((minus kwt) + (parser + (((` '.')) (identifier kwt (values "-." False))) + (((` (as (range '0' '9') c)) + (n (number (Buff.store (Buff.store 0 '-') c)))) ep n) + (((id (ident (Buff.store 0 '-')))) (identifier kwt id)))) + ((less kwt) + (parser + (((` ':') (lab (label 0)) (? (` '<') "'<' expected") (q (quotation 0))) + (values "QUOT" (^ lab ":" q))) + (((id (ident (Buff.store 0 '<')))) (identifier kwt id)))) + ((label len) + (parser + (((` (as (or (range 'a' 'z') (range 'A' 'Z') '_') c)) s) + (label (Buff.store len c) s)) + (() (Buff.get len)))) + ((quotation len) + (parser + (((` '>') s) (quotation_greater len s)) + (((` x) s) (quotation (Buff.store len x) s)) + (() (failwith "quotation not terminated")))) + ((quotation_greater len) + (parser + (((` '>')) (Buff.get len)) + (((a (quotation (Buff.store len '>')))) a)))) + +(define (lexer_using kwt (values con prm)) + (match con + ((or "CHAR" "EOI" "INT" "FLOAT" "LIDENT" "LIDENTDOT" "QUESTIONIDENT" + "QUOT" "STRING" "TILDEIDENT" "UIDENT" "UIDENTDOT") + ()) + ("ANTIQUOT" ()) + ("" (try (Hashtbl.find kwt prm) (Not_found (Hashtbl.add kwt prm ())))) + (_ + (raise + (Token.Error + (^ "the constructor \"" con "\" is not recognized by Plexer")))))) + +(define (lexer_text (values con prm)) + (cond + ((= con "") (^ "'"prm "'")) + ((= prm "") con) + (else (^ con " \"" prm "\"")))) + +(define (lexer_gmake ()) + (let ((kwt (Hashtbl.create 89))) + {(Token.tok_func + (Token.lexer_func_of_parser + (lambda (s) + (let (((values r (values bp ep)) (lexer kwt s))) + (values r (values (Reloc.shift_pos bp Reloc.zero_loc) + (Reloc.shift_pos ep Reloc.zero_loc))))))) + (Token.tok_using (lexer_using kwt)) + (Token.tok_removing (lambda)) + (Token.tok_match Token.default_match) + (Token.tok_text lexer_text) + (Token.tok_comm None)})) + +; Building AST + +(type sexpr + (sum + (Sacc MLast.loc sexpr sexpr) + (Schar MLast.loc string) + (Sexpr MLast.loc (list sexpr)) + (Sint MLast.loc string) + (Sfloat MLast.loc string) + (Slid MLast.loc string) + (Slist MLast.loc (list sexpr)) + (Sqid MLast.loc string) + (Squot MLast.loc string string) + (Srec MLast.loc (list sexpr)) + (Sstring MLast.loc string) + (Stid MLast.loc string) + (Suid MLast.loc string))) + +(define loc_of_sexpr + (lambda_match + ((or (Sacc loc _ _) (Schar loc _) (Sexpr loc _) (Sint loc _) + (Sfloat loc _) (Slid loc _) (Slist loc _) (Sqid loc _) (Squot loc _ _) + (Srec loc _) (Sstring loc _) (Stid loc _) (Suid loc _)) + loc))) +(define (error_loc loc err) + (raise_with_loc loc (Stream.Error (^ err " expected")))) +(define (error se err) (error_loc (loc_of_sexpr se) err)) + +(define strm_n "strm__") +(define (peek_fun loc) <:expr< Stream.peek >>) +(define (junk_fun loc) <:expr< Stream.junk >>) + +(define assoc_left_parsed_op_list ["+" "*" "+." "*." "land" "lor" "lxor"]) +(define assoc_right_parsed_op_list ["and" "or" "^" "@"]) +(define and_by_couple_op_list ["=" "<>" "<" ">" "<=" ">=" "==" "!="]) + +(define (op_apply loc e1 e2) + (lambda_match + ("and" <:expr< $e1$ && $e2$ >>) + ("or" <:expr< $e1$ || $e2$ >>) + (x <:expr< $lid:x$ $e1$ $e2$ >>))) + +(define string_se + (lambda_match + ((Sstring loc s) s) + (se (error se "string")))) + +(define mod_ident_se + (lambda_match + ((Suid _ s) [(Pcaml.rename_id.val s)]) + ((Slid _ s) [(Pcaml.rename_id.val s)]) + (se (error se "mod_ident")))) + +(define (lident_expr loc s) + (if (&& (> (String.length s) 1) (= s.[0] '`')) + (let ((s (String.sub s 1 (- (String.length s) 1)))) + <:expr< ` $s$ >>) + <:expr< $lid:(Pcaml.rename_id.val s)$ >>)) + +(definerec* + (module_expr_se + (lambda_match + ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2]) + (let* ((s (Pcaml.rename_id.val s)) + (mt (module_type_se se1)) + (me (module_expr_se se2))) + <:module_expr< functor ($s$ : $mt$) -> $me$ >>)) + ((Sexpr loc [(Slid _ "struct") . sl]) + (let ((mel (List.map str_item_se sl))) + <:module_expr< struct $list:mel$ end >>)) + ((Sexpr loc [se1 se2]) + (let* ((me1 (module_expr_se se1)) + (me2 (module_expr_se se2))) + <:module_expr< $me1$ $me2$ >>)) + ((Suid loc s) <:module_expr< $uid:(Pcaml.rename_id.val s)$ >>) + (se (error se "module expr")))) + (module_type_se + (lambda_match + ((Sexpr loc [(Slid _ "functor") (Suid _ s) se1 se2]) + (let* ((s (Pcaml.rename_id.val s)) + (mt1 (module_type_se se1)) + (mt2 (module_type_se se2))) + <:module_type< functor ($s$ : $mt1$) -> $mt2$ >>)) + ((Sexpr loc [(Slid _ "sig") . sel]) + (let ((sil (List.map sig_item_se sel))) + <:module_type< sig $list:sil$ end >>)) + ((Sexpr loc [(Slid _ "with") se (Sexpr _ sel)]) + (let* ((mt (module_type_se se)) + (wcl (List.map with_constr_se sel))) + <:module_type< $mt$ with $list:wcl$ >>)) + ((Suid loc s) <:module_type< $uid:(Pcaml.rename_id.val s)$ >>) + (se (error se "module type")))) + (with_constr_se + (lambda_match + ((Sexpr loc [(Slid _ "type") se1 se2]) + (let* ((tn (mod_ident_se se1)) + (te (ctyp_se se2))) + (MLast.WcTyp loc tn [] te))) + (se (error se "with constr")))) + (sig_item_se + (lambda_match + ((Sexpr loc [(Slid _ "type") . sel]) + (let ((tdl (type_declaration_list_se sel))) + <:sig_item< type $list:tdl$ >>)) + ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel]) + (let* ((c (Pcaml.rename_id.val c)) + (tl (List.map ctyp_se sel))) + <:sig_item< exception $c$ of $list:tl$ >>)) + ((Sexpr loc [(Slid _ "value") (Slid _ s) se]) + (let* ((s (Pcaml.rename_id.val s)) + (t (ctyp_se se))) + <:sig_item< value $s$ : $t$ >>)) + ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel]) + (let* ((i (Pcaml.rename_id.val i)) + (pd (List.map string_se sel)) + (t (ctyp_se se))) + <:sig_item< external $i$ : $t$ = $list:pd$ >>)) + ((Sexpr loc [(Slid _ "module") (Suid _ s) se]) + (let* ((s (Pcaml.rename_id.val s)) + (mb (module_type_se se))) + <:sig_item< module $s$ : $mb$ >>)) + ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se]) + (let* ((s (Pcaml.rename_id.val s)) + (mt (module_type_se se))) + <:sig_item< module type $s$ = $mt$ >>)) + (se (error se "sig item")))) + ((str_item_se se) + (match se + ((Sexpr loc [(Slid _ "open") se]) + (let ((s (mod_ident_se se))) <:str_item< open $s$ >>)) + ((Sexpr loc [(Slid _ "type") . sel]) + (let ((tdl (type_declaration_list_se sel))) + <:str_item< type $list:tdl$ >>)) + ((Sexpr loc [(Slid _ "exception") (Suid _ c) . sel]) + (let* ((c (Pcaml.rename_id.val c)) + (tl (List.map ctyp_se sel))) + <:str_item< exception $c$ of $list:tl$ >>)) + ((Sexpr loc [(Slid _ (as (or "define" "definerec") r)) se . sel]) + (let* ((r (= r "definerec")) + ((values p e) (fun_binding_se se (begin_se loc sel)))) + <:str_item< value $opt:r$ $p$ = $e$ >>)) + ((Sexpr loc [(Slid _ (as (or "define*" "definerec*") r)) . sel]) + (let* ((r (= r "definerec*")) + (lbs (List.map let_binding_se sel))) + <:str_item< value $opt:r$ $list:lbs$ >>)) + ((Sexpr loc [(Slid _ "external") (Slid _ i) se . sel]) + (let* ((i (Pcaml.rename_id.val i)) + (pd (List.map string_se sel)) + (t (ctyp_se se))) + <:str_item< external $i$ : $t$ = $list:pd$ >>)) + ((Sexpr loc [(Slid _ "module") (Suid _ i) se]) + (let* ((i (Pcaml.rename_id.val i)) + (mb (module_binding_se se))) + <:str_item< module $i$ = $mb$ >>)) + ((Sexpr loc [(Slid _ "moduletype") (Suid _ s) se]) + (let* ((s (Pcaml.rename_id.val s)) + (mt (module_type_se se))) + <:str_item< module type $s$ = $mt$ >>)) + (_ + (let* ((loc (loc_of_sexpr se)) + (e (expr_se se))) + <:str_item< $exp:e$ >>)))) + ((module_binding_se se) (module_expr_se se)) + (expr_se + (lambda_match + ((Sacc loc se1 se2) + (let ((e1 (expr_se se1))) + (match se2 + ((Slist loc [se2]) + (let ((e2 (expr_se se2))) <:expr< $e1$ .[ $e2$ ] >>)) + ((Sexpr loc [se2]) + (let ((e2 (expr_se se2))) <:expr< $e1$ .( $e2$ ) >>)) + (_ (let ((e2 (expr_se se2))) <:expr< $e1$ . $e2$ >>))))) + ((Slid loc s) (lident_expr loc s)) + ((Suid loc s) <:expr< $uid:(Pcaml.rename_id.val s)$ >>) + ((Sint loc s) <:expr< $int:s$ >>) + ((Sfloat loc s) <:expr< $flo:s$ >>) + ((Schar loc s) <:expr< $chr:s$ >>) + ((Sstring loc s) <:expr< $str:s$ >>) + ((Stid loc s) <:expr< ~ $(Pcaml.rename_id.val s)$ >>) + ((Sqid loc s) <:expr< ? $(Pcaml.rename_id.val s)$ >>) + ((Sexpr loc []) <:expr< () >>) + ((when (Sexpr loc [(Slid _ s) e1 . (as [_ . _] sel)]) + (List.mem s assoc_left_parsed_op_list)) + (letrec + (((loop e1) + (lambda_match + ([] e1) + ([e2 . el] (loop (op_apply loc e1 e2 s) el))))) + (loop (expr_se e1) (List.map expr_se sel)))) + ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)]) + (List.mem s assoc_right_parsed_op_list)) + (letrec + ((loop + (lambda_match + ([] + (assert False)) + ([e1] e1) + ([e1 . el] (let ((e2 (loop el))) (op_apply loc e1 e2 s)))))) + (loop (List.map expr_se sel)))) + ((when (Sexpr loc [(Slid _ s) . (as [_ _ . _] sel)]) + (List.mem s and_by_couple_op_list)) + (letrec + ((loop + (lambda_match + ((or [] [_]) (assert False)) + ([e1 e2] <:expr< $lid:s$ $e1$ $e2$ >>) + ([e1 . (as [e2 _ . _] el)] + (let* ((a1 (op_apply loc e1 e2 s)) + (a2 (loop el))) + <:expr< $a1$ && $a2$ >>))))) + (loop (List.map expr_se sel)))) + ((Sexpr loc [(Stid _ s) se]) + (let ((e (expr_se se))) <:expr< ~ $s$ : $e$ >>)) + ((Sexpr loc [(Slid _ "-") se]) + (let ((e (expr_se se))) <:expr< - $e$ >>)) + ((Sexpr loc [(Slid _ "if") se se1]) + (let* ((e (expr_se se)) + (e1 (expr_se se1))) + <:expr< if $e$ then $e1$ else () >>)) + ((Sexpr loc [(Slid _ "if") se se1 se2]) + (let* ((e (expr_se se)) + (e1 (expr_se se1)) + (e2 (expr_se se2))) + <:expr< if $e$ then $e1$ else $e2$ >>)) + ((Sexpr loc [(Slid _ "cond") . sel]) + (letrec + ((loop + (lambda_match + ([(Sexpr loc [(Slid _ "else") . sel])] (begin_se loc sel)) + ([(Sexpr loc [se1 . sel1]) . sel] + (let* ((e1 (expr_se se1)) + (e2 (begin_se loc sel1)) + (e3 (loop sel))) + <:expr< if $e1$ then $e2$ else $e3$ >>)) + ([] <:expr< () >>) + ([se . _] (error se "cond clause"))))) + (loop sel))) + ((Sexpr loc [(Slid _ "while") se . sel]) + (let* ((e (expr_se se)) + (el (List.map expr_se sel))) + <:expr< while $e$ do { $list:el$ } >>)) + ((Sexpr loc [(Slid _ "for") (Slid _ i) se1 se2 . sel]) + (let* ((i (Pcaml.rename_id.val i)) + (e1 (expr_se se1)) + (e2 (expr_se se2)) + (el (List.map expr_se sel))) + <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >>)) + ((Sexpr loc [(Slid loc1 "lambda")]) <:expr< fun [] >>) + ((Sexpr loc [(Slid loc1 "lambda") sep . sel]) + (let ((e (begin_se loc1 sel))) + (match (ipatt_opt_se sep) + ((Left p) <:expr< fun $p$ -> $e$ >>) + ((Right (values se sel)) + (List.fold_right + (lambda (se e) + (let ((p (ipatt_se se))) <:expr< fun $p$ -> $e$ >>)) + [se . sel] e))))) + ((Sexpr loc [(Slid _ "lambda_match") . sel]) + (let ((pel (List.map (match_case loc) sel))) + <:expr< fun [ $list:pel$ ] >>)) + ((Sexpr loc [(Slid _ (as (or "let" "letrec") r)) . sel]) + (match sel + ([(Sexpr _ sel1) . sel2] + (let* ((r (= r "letrec")) + (lbs (List.map let_binding_se sel1)) + (e (begin_se loc sel2))) + <:expr< let $opt:r$ $list:lbs$ in $e$ >>)) + ([(Slid _ n) (Sexpr _ sl) . sel] + (let* ((n (Pcaml.rename_id.val n)) + ((values pl el) + (List.fold_right + (lambda (se (values pl el)) + (match se + ((Sexpr _ [se1 se2]) + (values [(patt_se se1) . pl] + [(expr_se se2) . el])) + (se (error se "named let")))) + sl (values [] []))) + (e1 + (List.fold_right + (lambda (p e) <:expr< fun $p$ -> $e$ >>) + pl (begin_se loc sel))) + (e2 + (List.fold_left + (lambda (e1 e2) <:expr< $e1$ $e2$ >>) + <:expr< $lid:n$ >> el))) + <:expr< let rec $lid:n$ = $e1$ in $e2$ >>)) + ([se . _] (error se "let_binding")) + (_ (error_loc loc "let_binding")))) + ((Sexpr loc [(Slid _ "let*") . sel]) + (match sel + ([(Sexpr _ sel1) . sel2] + (List.fold_right + (lambda (se ek) + (let (((values p e) (let_binding_se se))) + <:expr< let $p$ = $e$ in $ek$ >>)) + sel1 (begin_se loc sel2))) + ([se . _] (error se "let_binding")) + (_ (error_loc loc "let_binding")))) + ((Sexpr loc [(Slid _ "match") se . sel]) + (let* ((e (expr_se se)) + (pel (List.map (match_case loc) sel))) + <:expr< match $e$ with [ $list:pel$ ] >>)) + ((Sexpr loc [(Slid _ "parser") . sel]) + (let ((e + (match sel + ([(as (Slid _ _) se) . sel] + (let* ((p (patt_se se)) + (pc (parser_cases_se loc sel))) + <:expr< let $p$ = Stream.count $lid:strm_n$ in $pc$ >>)) + (_ (parser_cases_se loc sel))))) + <:expr< fun ($lid:strm_n$ : Stream.t _) -> $e$ >>)) + ((Sexpr loc [(Slid _ "match_with_parser") se . sel]) + (let* ((me (expr_se se)) + ((values bpo sel) + (match sel + ([(as (Slid _ _) se) . sel] (values (Some (patt_se se)) sel)) + (_ (values None sel)))) + (pc (parser_cases_se loc sel)) + (e + (match bpo + ((Some bp) + <:expr< let $bp$ = Stream.count $lid:strm_n$ in $pc$ >>) + (None pc)))) + (match me + ((when <:expr< $lid:x$ >> (= x strm_n)) e) + (_ <:expr< let ($lid:strm_n$ : Stream.t _) = $me$ in $e$ >>)))) + ((Sexpr loc [(Slid _ "try") se . sel]) + (let* ((e (expr_se se)) + (pel (List.map (match_case loc) sel))) + <:expr< try $e$ with [ $list:pel$ ] >>)) + ((Sexpr loc [(Slid _ "begin") . sel]) + (let ((el (List.map expr_se sel))) <:expr< do { $list:el$ } >>)) + ((Sexpr loc [(Slid _ ":=") se1 se2]) + (let* ((e1 (expr_se se1)) + (e2 (expr_se se2))) + <:expr< $e1$ := $e2$ >>)) + ((Sexpr loc [(Slid _ "values") . sel]) + (let ((el (List.map expr_se sel))) <:expr< ( $list:el$ ) >>)) + ((Srec loc [(Slid _ "with") se . sel]) + (let* ((e (expr_se se)) + (lel (List.map (label_expr_se loc) sel))) + <:expr< { ($e$) with $list:lel$ } >>)) + ((Srec loc sel) + (let ((lel (List.map (label_expr_se loc) sel))) + <:expr< { $list:lel$ } >>)) + ((Sexpr loc [(Slid _ ":") se1 se2]) + (let* ((e (expr_se se1)) (t (ctyp_se se2))) <:expr< ( $e$ : $t$ ) >>)) + ((Sexpr loc [se]) (let ((e (expr_se se))) <:expr< $e$ () >>)) + ((Sexpr loc [(Slid _ "assert") (Suid _ "False")]) + <:expr< assert False >>) + ((Sexpr loc [(Slid _ "assert") se]) + (let ((e (expr_se se))) <:expr< assert $e$ >>)) + ((Sexpr loc [(Slid _ "lazy") se]) + (let ((e (expr_se se))) <:expr< lazy $e$ >>)) + ((Sexpr loc [se . sel]) + (List.fold_left + (lambda (e se) (let ((e1 (expr_se se))) <:expr< $e$ $e1$ >>)) + (expr_se se) sel)) + ((Slist loc sel) + (letrec ((loop + (lambda_match + ([] <:expr< [] >>) + ([se1 (Slid _ ".") se2] + (let* ((e (expr_se se1)) + (el (expr_se se2))) + <:expr< [$e$ :: $el$] >>)) + ([se . sel] + (let* ((e (expr_se se)) + (el (loop sel))) + <:expr< [$e$ :: $el$] >>))))) + (loop sel))) + ((Squot loc typ txt) + (Pcaml.handle_expr_quotation loc (values typ txt))))) + ((begin_se loc) + (lambda_match + ([] <:expr< () >>) + ([se] (expr_se se)) + ((sel) + (let* ((el (List.map expr_se sel)) + (loc (values (fst (loc_of_sexpr (List.hd sel))) (snd loc)))) + <:expr< do { $list:el$ } >>)))) + (let_binding_se + (lambda_match + ((Sexpr loc [se . sel]) + (let ((e (begin_se loc sel))) + (match (ipatt_opt_se se) + ((Left p) (values p e)) + ((Right _) (fun_binding_se se e))))) + (se (error se "let_binding")))) + ((fun_binding_se se e) + (match se + ((Sexpr _ [(Slid _ "values") . _]) (values (ipatt_se se) e)) + ((Sexpr _ [(Slid loc s) . sel]) + (let* ((s (Pcaml.rename_id.val s)) + (e + (List.fold_right + (lambda (se e) + (let* ((loc + (values (fst (loc_of_sexpr se)) + (snd (MLast.loc_of_expr e)))) + (p (ipatt_se se))) + <:expr< fun $p$ -> $e$ >>)) + sel e)) + (p <:patt< $lid:s$ >>)) + (values p e))) + ((_) (values (ipatt_se se) e)))) + ((match_case loc) + (lambda_match + ((Sexpr loc [(Sexpr _ [(Slid _ "when") se sew]) . sel]) + (values (patt_se se) (Some (expr_se sew)) (begin_se loc sel))) + ((Sexpr loc [se . sel]) + (values (patt_se se) None (begin_se loc sel))) + (se (error se "match_case")))) + ((label_expr_se loc) + (lambda_match + ((Sexpr _ [se1 se2]) (values (patt_se se1) (expr_se se2))) + (se (error se "label_expr")))) + ((label_patt_se loc) + (lambda_match + ((Sexpr _ [se1 se2]) (values (patt_se se1) (patt_se se2))) + (se (error se "label_patt")))) + ((parser_cases_se loc) + (lambda_match + ([] <:expr< raise Stream.Failure >>) + ([(Sexpr loc [(Sexpr _ spsel) . act]) . sel] + (let* ((ekont (lambda _ (parser_cases_se loc sel))) + (act (match act + ([se] (expr_se se)) + ([sep se] + (let* ((p (patt_se sep)) + (e (expr_se se))) + <:expr< let $p$ = Stream.count $lid:strm_n$ in $e$ >>)) + (_ (error_loc loc "parser_case"))))) + (stream_pattern_se loc act ekont spsel))) + ([se . _] + (error se "parser_case")))) + ((stream_pattern_se loc act ekont) + (lambda_match + ([] act) + ([se . sel] + (let* ((ckont (lambda err <:expr< raise (Stream.Error $err$) >>)) + (skont (stream_pattern_se loc act ckont sel))) + (stream_pattern_component skont ekont <:expr< "" >> se))))) + ((stream_pattern_component skont ekont err) + (lambda_match + ((Sexpr loc [(Slid _ "`") se . wol]) + (let* ((wo (match wol + ([se] (Some (expr_se se))) + ([] None) + (_ (error_loc loc "stream_pattern_component")))) + (e (peek_fun loc)) + (p (patt_se se)) + (j (junk_fun loc)) + (k (ekont err))) + <:expr< match $e$ $lid:strm_n$ with + [ Some $p$ $when:wo$ -> do { $j$ $lid:strm_n$ ; $skont$ } + | _ -> $k$ ] >>)) + ((Sexpr loc [se1 se2]) + (let* ((p (patt_se se1)) + (e (let ((e (expr_se se2))) + <:expr< try Some ($e$ $lid:strm_n$) with [ Stream.Failure -> None ] >>)) + (k (ekont err))) + <:expr< match $e$ with [ Some $p$ -> $skont$ | _ -> $k$ ] >>)) + ((Sexpr loc [(Slid _ "?") se1 se2]) + (stream_pattern_component skont ekont (expr_se se2) se1)) + ((Slid loc s) + (let ((s (Pcaml.rename_id.val s))) + <:expr< let $lid:s$ = $lid:strm_n$ in $skont$ >>)) + (se + (error se "stream_pattern_component")))) + (patt_se + (lambda_match + ((Sacc loc se1 se2) + (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ . $p2$ >>)) + ((Slid loc "_") <:patt< _ >>) + ((Slid loc s) <:patt< $lid:(Pcaml.rename_id.val s)$ >>) + ((Suid loc s) <:patt< $uid:(Pcaml.rename_id.val s)$ >>) + ((Sint loc s) <:patt< $int:s$ >>) + ((Sfloat loc s) <:patt< $flo:s$ >>) + ((Schar loc s) <:patt< $chr:s$ >>) + ((Sstring loc s) <:patt< $str:s$ >>) + ((Stid loc _) (error_loc loc "patt")) + ((Sqid loc _) (error_loc loc "patt")) + ((Srec loc sel) + (let ((lpl (List.map (label_patt_se loc) sel))) + <:patt< { $list:lpl$ } >>)) + ((Sexpr loc [(Slid _ ":") se1 se2]) + (let* ((p (patt_se se1)) (t (ctyp_se se2))) <:patt< ($p$ : $t$) >>)) + ((Sexpr loc [(Slid _ "or") se . sel]) + (List.fold_left + (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ | $p1$ >>)) + (patt_se se) sel)) + ((Sexpr loc [(Slid _ "range") se1 se2]) + (let* ((p1 (patt_se se1)) (p2 (patt_se se2))) <:patt< $p1$ .. $p2$ >>)) + ((Sexpr loc [(Slid _ "values") . sel]) + (let ((pl (List.map patt_se sel))) <:patt< ( $list:pl$ ) >>)) + ((Sexpr loc [(Slid _ "as") se1 se2]) + (let* ((p1 (patt_se se1)) + (p2 (patt_se se2))) + <:patt< ($p1$ as $p2$) >>)) + ((Sexpr loc [se . sel]) + (List.fold_left + (lambda (p se) (let ((p1 (patt_se se))) <:patt< $p$ $p1$ >>)) + (patt_se se) sel)) + ((Sexpr loc []) <:patt< () >>) + ((Slist loc sel) + (letrec ((loop + (lambda_match + ([] <:patt< [] >>) + ([se1 (Slid _ ".") se2] + (let* ((p (patt_se se1)) + (pl (patt_se se2))) + <:patt< [$p$ :: $pl$] >>)) + ([se . sel] + (let* ((p (patt_se se)) + (pl (loop sel))) + <:patt< [$p$ :: $pl$] >>))))) + (loop sel))) + ((Squot loc typ txt) + (Pcaml.handle_patt_quotation loc (values typ txt))))) + ((ipatt_se se) + (match (ipatt_opt_se se) + ((Left p) p) + ((Right (values se _)) (error se "ipatt")))) + (ipatt_opt_se + (lambda_match + ((Slid loc "_") (Left <:patt< _ >>)) + ((Slid loc s) (Left <:patt< $lid:(Pcaml.rename_id.val s)$ >>)) + ((Stid loc s) (Left <:patt< ~ $(Pcaml.rename_id.val s)$ >>)) + ((Sqid loc s) (Left <:patt< ? $(Pcaml.rename_id.val s)$ >>)) + ((Sexpr loc [(Sqid _ s) se]) + (let* ((s (Pcaml.rename_id.val s)) + (e (expr_se se))) + (Left <:patt< ? ( $lid:s$ = $e$ ) >>))) + ((Sexpr loc [(Slid _ ":") se1 se2]) + (let* ((p (ipatt_se se1)) (t (ctyp_se se2))) + (Left <:patt< ($p$ : $t$) >>))) + ((Sexpr loc [(Slid _ "values") . sel]) + (let ((pl (List.map ipatt_se sel))) (Left <:patt< ( $list:pl$ ) >>))) + ((Sexpr loc []) (Left <:patt< () >>)) + ((Sexpr loc [se . sel]) (Right (values se sel))) + (se (error se "ipatt")))) + (type_declaration_list_se + (lambda_match + ([se1 se2 . sel] + (let (((values n1 loc1 tpl) + (match se1 + ((Sexpr _ [(Slid loc n) . sel]) + (values n loc (List.map type_parameter_se sel))) + ((Slid loc n) + (values n loc [])) + ((se) + (error se "type declaration"))))) + [(values (values loc1 (Pcaml.rename_id.val n1)) tpl (ctyp_se se2) []) . + (type_declaration_list_se sel)])) + ([] []) + ([se . _] (error se "type_declaration")))) + (type_parameter_se + (lambda_match + ((when (Slid _ s) (and (>= (String.length s) 2) (= s.[0] '''))) + (values (String.sub s 1 (- (String.length s) 1)) (values False False))) + (se + (error se "type_parameter")))) + (ctyp_se + (lambda_match + ((Sexpr loc [(Slid _ "sum") . sel]) + (let ((cdl (List.map constructor_declaration_se sel))) + <:ctyp< [ $list:cdl$ ] >>)) + ((Srec loc sel) + (let ((ldl (List.map label_declaration_se sel))) + <:ctyp< { $list:ldl$ } >>)) + ((Sexpr loc [(Slid _ "->") . (as [_ _ . _] sel)]) + (letrec + ((loop + (lambda_match + ([] (assert False)) + ([se] (ctyp_se se)) + ([se . sel] + (let* ((t1 (ctyp_se se)) + (loc (values (fst (loc_of_sexpr se)) (snd loc))) + (t2 (loop sel))) + <:ctyp< $t1$ -> $t2$ >>))))) + (loop sel))) + ((Sexpr loc [(Slid _ "*") . sel]) + (let ((tl (List.map ctyp_se sel))) <:ctyp< ($list:tl$) >>)) + ((Sexpr loc [se . sel]) + (List.fold_left + (lambda (t se) (let ((t2 (ctyp_se se))) <:ctyp< $t$ $t2$ >>)) + (ctyp_se se) sel)) + ((Sacc loc se1 se2) + (let* ((t1 (ctyp_se se1)) (t2 (ctyp_se se2))) <:ctyp< $t1$ . $t2$ >>)) + ((Slid loc "_") <:ctyp< _ >>) + ((Slid loc s) + (if (= s.[0] ''') + (let ((s (String.sub s 1 (- (String.length s) 1)))) + <:ctyp< '$s$ >>) + <:ctyp< $lid:(Pcaml.rename_id.val s)$ >>)) + ((Suid loc s) <:ctyp< $uid:(Pcaml.rename_id.val s)$ >>) + (se (error se "ctyp")))) + (constructor_declaration_se + (lambda_match + ((Sexpr loc [(Suid _ ci) . sel]) + (values loc (Pcaml.rename_id.val ci) (List.map ctyp_se sel))) + (se + (error se "constructor_declaration")))) + (label_declaration_se + (lambda_match + ((Sexpr loc [(Slid _ lab) (Slid _ "mutable") se]) + (values loc (Pcaml.rename_id.val lab) True (ctyp_se se))) + ((Sexpr loc [(Slid _ lab) se]) + (values loc (Pcaml.rename_id.val lab) False (ctyp_se se))) + (se + (error se "label_declaration"))))) + +(define directive_se + (lambda_match + ((Sexpr _ [(Slid _ s)]) (values s None)) + ((Sexpr _ [(Slid _ s) se]) (let ((e (expr_se se))) (values s (Some e)))) + (se (error se "directive")))) + +; Parser + +(:= Pcaml.syntax_name.val "Scheme") +(:= Pcaml.no_constructors_arity.val False) + +(begin + (Grammar.Unsafe.gram_reinit gram (lexer_gmake ())) + (Grammar.Unsafe.clear_entry interf) + (Grammar.Unsafe.clear_entry implem) + (Grammar.Unsafe.clear_entry top_phrase) + (Grammar.Unsafe.clear_entry use_file) + (Grammar.Unsafe.clear_entry module_type) + (Grammar.Unsafe.clear_entry module_expr) + (Grammar.Unsafe.clear_entry sig_item) + (Grammar.Unsafe.clear_entry str_item) + (Grammar.Unsafe.clear_entry expr) + (Grammar.Unsafe.clear_entry patt) + (Grammar.Unsafe.clear_entry ctyp) + (Grammar.Unsafe.clear_entry let_binding) + (Grammar.Unsafe.clear_entry type_declaration) + (Grammar.Unsafe.clear_entry class_type) + (Grammar.Unsafe.clear_entry class_expr) + (Grammar.Unsafe.clear_entry class_sig_item) + (Grammar.Unsafe.clear_entry class_str_item)) + +(:= Pcaml.parse_interf.val (Grammar.Entry.parse interf)) +(:= Pcaml.parse_implem.val (Grammar.Entry.parse implem)) + +(define sexpr (Grammar.Entry.create gram "sexpr")) + +(definerec leftify + (lambda_match + ((Sacc loc1 se1 se2) + (match (leftify se2) + ((Sacc loc2 se2 se3) (Sacc loc1 (Sacc loc2 se1 se2) se3)) + (se2 (Sacc loc1 se1 se2)))) + (x x))) + +EXTEND + GLOBAL : implem interf top_phrase use_file str_item sig_item expr + patt sexpr / + implem : + [ [ "#" / se = sexpr -> + (let (((values n dp) (directive_se se))) + (values [(values <:str_item< # $n$ $opt:dp$ >> loc)] True)) + | si = str_item / x = SELF -> + (let* (((values sil stopped) x) + (loc (MLast.loc_of_str_item si))) + (values [(values si loc) . sil] stopped)) + | EOI -> (values [] False) ] ] + / + interf : + [ [ "#" / se = sexpr -> + (let (((values n dp) (directive_se se))) + (values [(values <:sig_item< # $n$ $opt:dp$ >> loc)] True)) + | si = sig_item / x = SELF -> + (let* (((values sil stopped) x) + (loc (MLast.loc_of_sig_item si))) + (values [(values si loc) . sil] stopped)) + | EOI -> (values [] False) ] ] + / + top_phrase : + [ [ "#" / se = sexpr -> + (let (((values n dp) (directive_se se))) + (Some <:str_item< # $n$ $opt:dp$ >>)) + | se = sexpr -> (Some (str_item_se se)) + | EOI -> None ] ] + / + use_file : + [ [ "#" / se = sexpr -> + (let (((values n dp) (directive_se se))) + (values [<:str_item< # $n$ $opt:dp$ >>] True)) + | si = str_item / x = SELF -> + (let (((values sil stopped) x)) (values [si . sil] stopped)) + | EOI -> (values [] False) ] ] + / + str_item : + [ [ se = sexpr -> (str_item_se se) + | e = expr -> <:str_item< $exp:e$ >> ] ] + / + sig_item : + [ [ se = sexpr -> (sig_item_se se) ] ] + / + expr : + [ "top" + [ se = sexpr -> (expr_se se) ] ] + / + patt : + [ [ se = sexpr -> (patt_se se) ] ] + / + sexpr : + [ [ se1 = sexpr_dot / se2 = sexpr -> (leftify (Sacc loc se1 se2)) ] + | [ "(" / sl = LIST0 sexpr / ")" -> (Sexpr loc sl) + | "(" / sl = LIST0 sexpr / ")." / se = sexpr -> + (leftify (Sacc loc (Sexpr loc sl) se)) + | "[" / sl = LIST0 sexpr / "]" -> (Slist loc sl) + | "{" / sl = LIST0 sexpr / "}" -> (Srec loc sl) + | a = pa_extend_keyword -> (Slid loc a) + | s = LIDENT -> (Slid loc s) + | s = UIDENT -> (Suid loc s) + | s = TILDEIDENT -> (Stid loc s) + | s = QUESTIONIDENT -> (Sqid loc s) + | s = INT -> (Sint loc s) + | s = FLOAT -> (Sfloat loc s) + | s = CHAR -> (Schar loc s) + | s = STRING -> (Sstring loc s) + | s = QUOT -> + (let* ((i (String.index s ':')) + (typ (String.sub s 0 i)) + (txt (String.sub s (+ i 1) (- (- (String.length s) i) 1)))) + (Squot loc typ txt)) ] ] + / + sexpr_dot : + [ [ s = LIDENTDOT -> (Slid loc s) + | s = UIDENTDOT -> (Suid loc s) ] ] + / + pa_extend_keyword : + [ [ "_" -> "_" + | "," -> "," + | "=" -> "=" + | ":" -> ":" + | "." -> "." + | "/" -> "/" ] ] + / +END diff --git a/ocaml-binary-annot/camlp4/unmaintained/scheme/pr_scheme.ml b/ocaml-binary-annot/camlp4/unmaintained/scheme/pr_scheme.ml new file mode 100644 index 0000000000..a9cf348eb5 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/scheme/pr_scheme.ml @@ -0,0 +1,826 @@ +(* pa_r.cmo q_MLast.cmo pa_extfun.cmo pr_dump.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file *) +(* ../../../LICENSE. *) +(* *) +(***********************************************************************) + + +open Pcaml; +open Format; + +type printer_t 'a = + { pr_fun : mutable string -> next 'a; + pr_levels : mutable list (pr_level 'a) } +and pr_level 'a = + { pr_label : string; + pr_box : formatter -> (formatter -> unit) -> 'a -> unit; + pr_rules : mutable pr_rule 'a } +and pr_rule 'a = + Extfun.t 'a (formatter -> curr 'a -> next 'a -> string -> kont -> unit) +and curr 'a = formatter -> ('a * string * kont) -> unit +and next 'a = formatter -> ('a * string * kont) -> unit +and kont = formatter -> unit; + +value not_impl name x ppf k = + let desc = + if Obj.is_block (Obj.repr x) then + "tag = " ^ string_of_int (Obj.tag (Obj.repr x)) + else "int_val = " ^ string_of_int (Obj.magic x) + in + fprintf ppf "<pr_scheme: not impl: %s; %s>%t" name desc k +; + +value pr_fun name pr lab = + loop False pr.pr_levels where rec loop app = + fun + [ [] -> fun ppf (x, dg, k) -> failwith ("unable to print " ^ name) + | [lev :: levl] -> + if app || lev.pr_label = lab then + let next = loop True levl in + let rec curr ppf (x, dg, k) = + Extfun.apply lev.pr_rules x ppf curr next dg k + in + fun ppf ((x, _, _) as n) -> lev.pr_box ppf (fun ppf -> curr ppf n) x + else loop app levl ] +; + +value rec find_pr_level lab = + fun + [ [] -> failwith ("level " ^ lab ^ " not found") + | [lev :: levl] -> + if lev.pr_label = lab then lev else find_pr_level lab levl ] +; + +value pr_constr_decl = {pr_fun = fun []; pr_levels = []}; +value constr_decl ppf (x, k) = pr_constr_decl.pr_fun "top" ppf (x, "", k); +pr_constr_decl.pr_fun := pr_fun "constr_decl" pr_constr_decl; + +value pr_ctyp = {pr_fun = fun []; pr_levels = []}; +pr_ctyp.pr_fun := pr_fun "ctyp" pr_ctyp; +value ctyp ppf (x, k) = pr_ctyp.pr_fun "top" ppf (x, "", k); + +value pr_expr = {pr_fun = fun []; pr_levels = []}; +pr_expr.pr_fun := pr_fun "expr" pr_expr; +value expr ppf (x, k) = pr_expr.pr_fun "top" ppf (x, "", k); + +value pr_label_decl = {pr_fun = fun []; pr_levels = []}; +value label_decl ppf (x, k) = pr_label_decl.pr_fun "top" ppf (x, "", k); +pr_label_decl.pr_fun := pr_fun "label_decl" pr_label_decl; + +value pr_let_binding = {pr_fun = fun []; pr_levels = []}; +pr_let_binding.pr_fun := pr_fun "let_binding" pr_let_binding; +value let_binding ppf (x, k) = pr_let_binding.pr_fun "top" ppf (x, "", k); + +value pr_match_assoc = {pr_fun = fun []; pr_levels = []}; +pr_match_assoc.pr_fun := pr_fun "match_assoc" pr_match_assoc; +value match_assoc ppf (x, k) = pr_match_assoc.pr_fun "top" ppf (x, "", k); + +value pr_mod_ident = {pr_fun = fun []; pr_levels = []}; +pr_mod_ident.pr_fun := pr_fun "mod_ident" pr_mod_ident; +value mod_ident ppf (x, k) = pr_mod_ident.pr_fun "top" ppf (x, "", k); + +value pr_module_binding = {pr_fun = fun []; pr_levels = []}; +pr_module_binding.pr_fun := pr_fun "module_binding" pr_module_binding; +value module_binding ppf (x, k) = + pr_module_binding.pr_fun "top" ppf (x, "", k); + +value pr_module_expr = {pr_fun = fun []; pr_levels = []}; +pr_module_expr.pr_fun := pr_fun "module_expr" pr_module_expr; +value module_expr ppf (x, k) = pr_module_expr.pr_fun "top" ppf (x, "", k); + +value pr_module_type = {pr_fun = fun []; pr_levels = []}; +pr_module_type.pr_fun := pr_fun "module_type" pr_module_type; +value module_type ppf (x, k) = pr_module_type.pr_fun "top" ppf (x, "", k); + +value pr_patt = {pr_fun = fun []; pr_levels = []}; +pr_patt.pr_fun := pr_fun "patt" pr_patt; +value patt ppf (x, k) = pr_patt.pr_fun "top" ppf (x, "", k); + +value pr_sig_item = {pr_fun = fun []; pr_levels = []}; +pr_sig_item.pr_fun := pr_fun "sig_item" pr_sig_item; +value sig_item ppf (x, k) = pr_sig_item.pr_fun "top" ppf (x, "", k); + +value pr_str_item = {pr_fun = fun []; pr_levels = []}; +pr_str_item.pr_fun := pr_fun "str_item" pr_str_item; +value str_item ppf (x, k) = pr_str_item.pr_fun "top" ppf (x, "", k); + +value pr_type_decl = {pr_fun = fun []; pr_levels = []}; +value type_decl ppf (x, k) = pr_type_decl.pr_fun "top" ppf (x, "", k); +pr_type_decl.pr_fun := pr_fun "type_decl" pr_type_decl; + +value pr_type_params = {pr_fun = fun []; pr_levels = []}; +value type_params ppf (x, k) = pr_type_params.pr_fun "top" ppf (x, "", k); +pr_type_params.pr_fun := pr_fun "type_params" pr_type_params; + +value pr_with_constr = {pr_fun = fun []; pr_levels = []}; +value with_constr ppf (x, k) = pr_with_constr.pr_fun "top" ppf (x, "", k); +pr_with_constr.pr_fun := pr_fun "with_constr" pr_with_constr; + +(* general functions *) + +value nok ppf = (); +value ks s k ppf = fprintf ppf "%s%t" s k; + +value rec list f ppf (l, k) = + match l with + [ [] -> k ppf + | [x] -> f ppf (x, k) + | [x :: l] -> fprintf ppf "%a@ %a" f (x, nok) (list f) (l, k) ] +; + +value rec listwb b f ppf (l, k) = + match l with + [ [] -> k ppf + | [x] -> f ppf ((b, x), k) + | [x :: l] -> fprintf ppf "%a@ %a" f ((b, x), nok) (listwb "" f) (l, k) ] +; + +(* specific functions *) + +value rec is_irrefut_patt = + fun + [ <:patt< $lid:_$ >> -> True + | <:patt< () >> -> True + | <:patt< _ >> -> True + | <:patt< ($x$ as $y$) >> -> is_irrefut_patt x && is_irrefut_patt y + | <:patt< { $list:fpl$ } >> -> + List.for_all (fun (_, p) -> is_irrefut_patt p) fpl + | <:patt< ($p$ : $_$) >> -> is_irrefut_patt p + | <:patt< ($list:pl$) >> -> List.for_all is_irrefut_patt pl + | <:patt< ? $_$ : ( $p$ ) >> -> is_irrefut_patt p + | <:patt< ? $_$ : ($p$ = $_$) >> -> is_irrefut_patt p + | <:patt< ~ $_$ >> -> True + | <:patt< ~ $_$ : $p$ >> -> is_irrefut_patt p + | _ -> False ] +; + +value expr_fun_args ge = Extfun.apply pr_expr_fun_args.val ge; + +pr_expr_fun_args.val := + extfun Extfun.empty with + [ <:expr< fun [$p$ -> $e$] >> as ge -> + if is_irrefut_patt p then + let (pl, e) = expr_fun_args e in + ([p :: pl], e) + else ([], ge) + | ge -> ([], ge) ]; + +value sequence ppf (e, k) = + match e with + [ <:expr< do { $list:el$ } >> -> + fprintf ppf "@[<hv>%a@]" (list expr) (el, k) + | _ -> expr ppf (e, k) ] +; + +value string ppf (s, k) = fprintf ppf "\"%s\"%t" s k; + +value int_repr s = + if String.length s > 2 && s.[0] = '0' then + match s.[1] with + [ 'b' | 'o' | 'x' | 'B' | 'O' | 'X' -> + "#" ^ String.sub s 1 (String.length s - 1) + | _ -> s ] + else s +; + +value assoc_left_parsed_op_list = ["+"; "*"; "land"; "lor"; "lxor"]; +value assoc_right_parsed_op_list = ["and"; "or"; "^"; "@"]; +value and_by_couple_op_list = ["="; "<>"; "<"; ">"; "<="; ">="; "=="; "!="]; + +(* extensible pretty print functions *) + +pr_constr_decl.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ (loc, c, []) -> + fun ppf curr next dg k -> fprintf ppf "(@[<hv>%s%t@]" c (ks ")" k) + | (loc, c, tl) -> + fun ppf curr next dg k -> + fprintf ppf "(@[<hv>%s@ %a@]" c (list ctyp) (tl, ks ")" k) ]}]; + +pr_ctyp.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:ctyp< [ $list:cdl$ ] >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[<hv>sum@ %a@]" (list constr_decl) (cdl, ks ")" k) + | <:ctyp< { $list:cdl$ } >> -> + fun ppf curr next dg k -> + fprintf ppf "{@[<hv>%a@]" (list label_decl) (cdl, ks "}" k) + | <:ctyp< ( $list:tl$ ) >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[* @[<hv>%a@]@]" (list ctyp) (tl, ks ")" k) + | <:ctyp< $t1$ -> $t2$ >> -> + fun ppf curr next dg k -> + let tl = + loop t2 where rec loop = + fun + [ <:ctyp< $t1$ -> $t2$ >> -> [t1 :: loop t2] + | t -> [t] ] + in + fprintf ppf "(@[-> @[<hv>%a@]@]" (list ctyp) + ([t1 :: tl], ks ")" k) + | <:ctyp< $t1$ $t2$ >> -> + fun ppf curr next dg k -> + let (t, tl) = + loop [t2] t1 where rec loop tl = + fun + [ <:ctyp< $t1$ $t2$ >> -> loop [t2 :: tl] t1 + | t1 -> (t1, tl) ] + in + fprintf ppf "(@[%a@ %a@]" ctyp (t, nok) (list ctyp) (tl, ks ")" k) + | <:ctyp< $t1$ . $t2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "%a.%a" ctyp (t1, nok) ctyp (t2, k) + | <:ctyp< $lid:s$ >> | <:ctyp< $uid:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" s k + | <:ctyp< ' $s$ >> -> + fun ppf curr next dg k -> fprintf ppf "'%s%t" s k + | <:ctyp< _ >> -> + fun ppf curr next dg k -> fprintf ppf "_%t" k + | x -> + fun ppf curr next dg k -> not_impl "ctyp" x ppf k ]}]; + +pr_expr.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:expr< fun [] >> -> + fun ppf curr next dg k -> + fprintf ppf "(lambda%t" (ks ")" k) + | <:expr< fun $lid:s$ -> $e$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(lambda@ %s@;<1 1>%a" s expr (e, ks ")" k) + | <:expr< fun [ $list:pwel$ ] >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[<hv>lambda_match@ %a@]" (list match_assoc) + (pwel, ks ")" k) + | <:expr< match $e$ with [ $list:pwel$ ] >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[<hv>@[<b 2>match@ %a@]@ %a@]" expr (e, nok) + (list match_assoc) (pwel, ks ")" k) + | <:expr< try $e$ with [ $list:pwel$ ] >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[<hv>@[<b 2>try@ %a@]@ %a@]" expr (e, nok) + (list match_assoc) (pwel, ks ")" k) + | <:expr< let $p1$ = $e1$ in $e2$ >> -> + fun ppf curr next dg k -> + let (pel, e) = + loop [(p1, e1)] e2 where rec loop pel = + fun + [ <:expr< let $p1$ = $e1$ in $e2$ >> -> + loop [(p1, e1) :: pel] e2 + | e -> (List.rev pel, e) ] + in + let b = + match pel with + [ [_] -> "let" + | _ -> "let*" ] + in + fprintf ppf "(@[@[%s (@[<v>%a@]@]@;<1 2>%a@]" b + (listwb "" let_binding) (pel, ks ")" nok) + sequence (e, ks ")" k) + | <:expr< let $opt:rf$ $list:pel$ in $e$ >> -> + fun ppf curr next dg k -> + let b = if rf then "letrec" else "let" in + fprintf ppf "(@[<hv>%s@ (@[<hv>%a@]@ %a@]" b + (listwb "" let_binding) (pel, ks ")" nok) expr (e, ks ")" k) + | <:expr< if $e1$ then $e2$ else () >> -> + fun ppf curr next dg k -> + fprintf ppf "(if @[%a@;<1 0>%a@]" expr (e1, nok) + expr (e2, ks ")" k) + | <:expr< if $e1$ then $e2$ else $e3$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(if @[%a@ %a@ %a@]" expr (e1, nok) + expr (e2, nok) expr (e3, ks ")" k) + | <:expr< do { $list:el$ } >> -> + fun ppf curr next dg k -> + fprintf ppf "(begin@;<1 1>@[<hv>%a@]" (list expr) (el, ks ")" k) + | <:expr< for $i$ = $e1$ to $e2$ do { $list:el$ } >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[for %s@ %a@ %a %a@]" i expr (e1, nok) + expr (e2, nok) (list expr) (el, ks ")" k) + | <:expr< ($e$ : $t$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(:@ %a@ %a" expr (e, nok) ctyp (t, ks ")" k) + | <:expr< ($list:el$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(values @[%a@]" (list expr) (el, ks ")" k) + | <:expr< { $list:fel$ } >> -> + fun ppf curr next dg k -> + let record_binding ppf ((p, e), k) = + fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k) + in + fprintf ppf "{@[<hv>%a@]" (list record_binding) (fel, ks "}" k) + | <:expr< { ($e$) with $list:fel$ } >> -> + fun ppf curr next dg k -> + let record_binding ppf ((p, e), k) = + fprintf ppf "(@[%a@ %a@]" patt (p, nok) expr (e, ks ")" k) + in + fprintf ppf "{@[@[with@ %a@]@ @[%a@]@]" expr (e, nok) + (list record_binding) (fel, ks "}" k) + | <:expr< $e1$ := $e2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(:=@;<1 1>%a@;<1 1>%a" expr (e1, nok) + expr (e2, ks ")" k) + | <:expr< [$_$ :: $_$] >> as e -> + fun ppf curr next dg k -> + let (el, c) = + make_list e where rec make_list e = + match e with + [ <:expr< [$e$ :: $y$] >> -> + let (el, c) = make_list y in + ([e :: el], c) + | <:expr< [] >> -> ([], None) + | x -> ([], Some e) ] + in + match c with + [ None -> + fprintf ppf "[%a" (list expr) (el, ks "]" k) + | Some x -> + fprintf ppf "[%a@ %a" (list expr) (el, ks " ." nok) + expr (x, ks "]" k) ] + | <:expr< lazy ($x$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[lazy@ %a@]" expr (x, ks ")" k) + | <:expr< $lid:s$ $e1$ $e2$ >> + when List.mem s assoc_right_parsed_op_list -> + fun ppf curr next dg k -> + let el = + loop [e1] e2 where rec loop el = + fun + [ <:expr< $lid:s1$ $e1$ $e2$ >> when s1 = s -> + loop [e1 :: el] e2 + | e -> List.rev [e :: el] ] + in + fprintf ppf "(@[%s %a@]" s (list expr) (el, ks ")" k) + | <:expr< $e1$ $e2$ >> -> + fun ppf curr next dg k -> + let (f, el) = + loop [e2] e1 where rec loop el = + fun + [ <:expr< $e1$ $e2$ >> -> loop [e2 :: el] e1 + | e1 -> (e1, el) ] + in + fprintf ppf "(@[%a@ %a@]" expr (f, nok) (list expr) (el, ks ")" k) + | <:expr< ~ $s$ : ($e$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(~%s@ %a" s expr (e, ks ")" k) + | <:expr< $e1$ .[ $e2$ ] >> -> + fun ppf curr next dg k -> + fprintf ppf "%a.[%a" expr (e1, nok) expr (e2, ks "]" k) + | <:expr< $e1$ .( $e2$ ) >> -> + fun ppf curr next dg k -> + fprintf ppf "%a.(%a" expr (e1, nok) expr (e2, ks ")" k) + | <:expr< $e1$ . $e2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "%a.%a" expr (e1, nok) expr (e2, k) + | <:expr< $int:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k + | <:expr< $lid:s$ >> | <:expr< $uid:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" s k + | <:expr< ` $s$ >> -> + fun ppf curr next dg k -> fprintf ppf "`%s%t" s k + | <:expr< $str:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k + | <:expr< $chr:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k + | x -> + fun ppf curr next dg k -> not_impl "expr" x ppf k ]}]; + +pr_label_decl.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ (loc, f, m, t) -> + fun ppf curr next dg k -> + fprintf ppf "(@[<hv>%s%t@ %a@]" f + (fun ppf -> if m then fprintf ppf "@ mutable" else ()) + ctyp (t, ks ")" k) ]}]; + +pr_let_binding.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ (b, (p, e)) -> + fun ppf curr next dg k -> + let (pl, e) = expr_fun_args e in + match pl with + [ [] -> + fprintf ppf "(@[<b 1>%s%s%a@ %a@]" b + (if b = "" then "" else " ") patt (p, nok) + sequence (e, ks ")" k) + | _ -> + fprintf ppf "(@[<b 1>%s%s(%a)@ %a@]" b + (if b = "" then "" else " ") (list patt) ([p :: pl], nok) + sequence (e, ks ")" k) ] ]}]; + +pr_match_assoc.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ (p, we, e) -> + fun ppf curr next dg k -> + fprintf ppf "(@[%t@ %a@]" + (fun ppf -> + match we with + [ Some e -> + fprintf ppf "(when@ %a@ %a" patt (p, nok) + expr (e, ks ")" nok) + | None -> patt ppf (p, nok) ]) + sequence (e, ks ")" k) ]}]; + +pr_mod_ident.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ [s] -> + fun ppf curr next dg k -> + fprintf ppf "%s%t" s k + | [s :: sl] -> + fun ppf curr next dg k -> + fprintf ppf "%s.%a" s curr (sl, "", k) + | x -> + fun ppf curr next dg k -> not_impl "mod_ident" x ppf k ]}]; + +pr_module_binding.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ (b, s, me) -> + fun ppf curr next dg k -> + fprintf ppf "%s@ %s@ %a" b s module_expr (me, k) ]}]; + +pr_module_expr.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:module_expr< functor ($i$ : $mt$) -> $me$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]" + i module_type (mt, nok) module_expr (me, ks ")" k) + | <:module_expr< struct $list:sil$ end >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[struct@ @[<hv>%a@]@]" (list str_item) + (sil, ks ")" k) + | <:module_expr< $me1$ $me2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[%a@ %a@]" module_expr (me1, nok) + module_expr (me2, ks ")" k) + | <:module_expr< $uid:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" s k + | x -> + fun ppf curr next dg k -> not_impl "module_expr" x ppf k ]}]; + +pr_module_type.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:module_type< functor ($i$ : $mt1$) -> $mt2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[@[functor@ %s@]@ %a@]@ %a@]" + i module_type (mt1, nok) module_type (mt2, ks ")" k) + | <:module_type< sig $list:sil$ end >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[sig@ @[<hv>%a@]@]" (list sig_item) (sil, ks ")" k) + | <:module_type< $mt$ with $list:wcl$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[with@;<1 2>@[%a@ (%a@]@]" module_type (mt, nok) + (list with_constr) (wcl, ks "))" k) + | <:module_type< $uid:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" s k + | x -> + fun ppf curr next dg k -> not_impl "module_type" x ppf k ]}]; + +pr_patt.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:patt< $p1$ | $p2$ >> -> + fun ppf curr next dg k -> + let (f, pl) = + loop [p2] p1 where rec loop pl = + fun + [ <:patt< $p1$ | $p2$ >> -> loop [p2 :: pl] p1 + | p1 -> (p1, pl) ] + in + fprintf ppf "(@[or@ %a@ %a@]" patt (f, nok) (list patt) + (pl, ks ")" k) + | <:patt< ($p1$ as $p2$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[as@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) + | <:patt< $p1$ .. $p2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[range@ %a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) + | <:patt< [$_$ :: $_$] >> as p -> + fun ppf curr next dg k -> + let (pl, c) = + make_list p where rec make_list p = + match p with + [ <:patt< [$p$ :: $y$] >> -> + let (pl, c) = make_list y in + ([p :: pl], c) + | <:patt< [] >> -> ([], None) + | x -> ([], Some p) ] + in + match c with + [ None -> + fprintf ppf "[%a" (list patt) (pl, ks "]" k) + | Some x -> + fprintf ppf "[%a@ %a" (list patt) (pl, ks " ." nok) + patt (x, ks "]" k) ] + | <:patt< $p1$ $p2$ >> -> + fun ppf curr next dg k -> + let pl = + loop [p2] p1 where rec loop pl = + fun + [ <:patt< $p1$ $p2$ >> -> loop [p2 :: pl] p1 + | p1 -> [p1 :: pl] ] + in + fprintf ppf "(@[%a@]" (list patt) (pl, ks ")" k) + | <:patt< ($p$ : $t$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(:@ %a@ %a" patt (p, nok) ctyp (t, ks ")" k) + | <:patt< ($list:pl$) >> -> + fun ppf curr next dg k -> + fprintf ppf "(values @[%a@]" (list patt) (pl, ks ")" k) + | <:patt< { $list:fpl$ } >> -> + fun ppf curr next dg k -> + let record_binding ppf ((p1, p2), k) = + fprintf ppf "(@[%a@ %a@]" patt (p1, nok) patt (p2, ks ")" k) + in + fprintf ppf "(@[<hv>{}@ %a@]" (list record_binding) (fpl, ks ")" k) + | <:patt< ? $x$ >> -> + fun ppf curr next dg k -> fprintf ppf "?%s%t" x k + | <:patt< ? ($lid:x$ = $e$) >> -> + fun ppf curr next dg k -> fprintf ppf "(?%s@ %a" x expr (e, ks ")" k) + | <:patt< $p1$ . $p2$ >> -> + fun ppf curr next dg k -> + fprintf ppf "%a.%a" patt (p1, nok) patt (p2, k) + | <:patt< $lid:s$ >> | <:patt< $uid:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" s k + | <:patt< $str:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "\"%s\"%t" s k + | <:patt< $chr:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "'%s'%t" s k + | <:patt< $int:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" (int_repr s) k + | <:patt< $flo:s$ >> -> + fun ppf curr next dg k -> fprintf ppf "%s%t" s k + | <:patt< _ >> -> + fun ppf curr next dg k -> fprintf ppf "_%t" k + | x -> + fun ppf curr next dg k -> not_impl "patt" x ppf k ]}]; + +pr_sig_item.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:sig_item< type $list:tdl$ >> -> + fun ppf curr next dg k -> + match tdl with + [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k) + | tdl -> + fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl) + (tdl, ks ")" k) ] + | <:sig_item< exception $c$ of $list:tl$ >> -> + fun ppf curr next dg k -> + match tl with + [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k) + | tl -> + fprintf ppf "(@[@[exception@ %s@]@ %a@]" c + (list ctyp) (tl, ks ")" k) ] + | <:sig_item< value $i$ : $t$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[value %s@]@ %a@]" i ctyp (t, ks ")" k) + | <:sig_item< external $i$ : $t$ = $list:pd$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[external@ %s@]@ %a@ %a@]" i ctyp (t, nok) + (list string) (pd, ks ")" k) + | <:sig_item< module $s$ : $mt$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[module@ %s@]@ %a@]" s + module_type (mt, ks ")" k) + | <:sig_item< module type $s$ = $mt$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s + module_type (mt, ks ")" k) + | <:sig_item< declare $list:s$ end >> -> + fun ppf curr next dg k -> + if s = [] then fprintf ppf "; ..." + else fprintf ppf "%a" (list sig_item) (s, k) + | MLast.SgUse _ _ _ -> + fun ppf curr next dg k -> () + | x -> + fun ppf curr next dg k -> not_impl "sig_item" x ppf k ]}]; + +pr_str_item.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ <:str_item< open $i$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(open@ %a" mod_ident (i, ks ")" k) + | <:str_item< type $list:tdl$ >> -> + fun ppf curr next dg k -> + match tdl with + [ [td] -> fprintf ppf "(%a" type_decl (("type", td), ks ")" k) + | tdl -> + fprintf ppf "(@[<hv>type@ %a@]" (listwb "" type_decl) + (tdl, ks ")" k) ] + | <:str_item< exception $c$ of $list:tl$ >> -> + fun ppf curr next dg k -> + match tl with + [ [] -> fprintf ppf "(@[exception@ %s%t@]" c (ks ")" k) + | tl -> + fprintf ppf "(@[@[exception@ %s@]@ %a@]" c + (list ctyp) (tl, ks ")" k) ] + | <:str_item< value $opt:rf$ $list:pel$ >> -> + fun ppf curr next dg k -> + let b = if rf then "definerec" else "define" in + match pel with + [ [(p, e)] -> + fprintf ppf "%a" let_binding ((b, (p, e)), k) + | pel -> + fprintf ppf "(@[<hv 1>%s*@ %a@]" b (listwb "" let_binding) + (pel, ks ")" k) ] + | <:str_item< module $s$ = $me$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(%a" module_binding (("module", s, me), ks ")" k) + | <:str_item< module type $s$ = $mt$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[@[moduletype@ %s@]@ %a@]" s + module_type (mt, ks ")" k) + | <:str_item< external $i$ : $t$ = $list:pd$ >> -> + fun ppf curr next dg k -> + fprintf ppf "(@[external@ %s@ %a@ %a@]" i ctyp (t, nok) + (list string) (pd, ks ")" k) + | <:str_item< $exp:e$ >> -> + fun ppf curr next dg k -> + fprintf ppf "%a" expr (e, k) + | <:str_item< # $s$ $opt:x$ >> -> + fun ppf curr next dg k -> + match x with + [ Some e -> fprintf ppf "; # (%s %a" s expr (e, ks ")" k) + | None -> fprintf ppf "; # (%s%t" s (ks ")" k) ] + | <:str_item< declare $list:s$ end >> -> + fun ppf curr next dg k -> + if s = [] then fprintf ppf "; ..." + else fprintf ppf "%a" (list str_item) (s, k) + | MLast.StUse _ _ _ -> + fun ppf curr next dg k -> () + | x -> + fun ppf curr next dg k -> not_impl "str_item" x ppf k ]}]; + +pr_type_decl.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ (b, ((_, tn), tp, te, cl)) -> + fun ppf curr next dg k -> + fprintf ppf "%t%t@;<1 1>%a" + (fun ppf -> + if b <> "" then fprintf ppf "%s@ " b + else ()) + (fun ppf -> + match tp with + [ [] -> fprintf ppf "%s" tn + | tp -> fprintf ppf "(%s%a)" tn type_params (tp, nok) ]) + ctyp (te, k) ]}]; + +pr_type_params.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ [(s, vari) :: tpl] -> + fun ppf curr next dg k -> + fprintf ppf "@ '%s%a" s type_params (tpl, k) + | [] -> + fun ppf curr next dg k -> () ]}]; + +pr_with_constr.pr_levels := + [{pr_label = "top"; + pr_box ppf f x = fprintf ppf "@[%t@]" f; + pr_rules = + extfun Extfun.empty with + [ MLast.WcTyp _ m tp te -> + fun ppf curr next dg k -> + fprintf ppf "(type@ %t@;<1 1>%a" + (fun ppf -> + match tp with + [ [] -> fprintf ppf "%a" mod_ident (m, nok) + | tp -> + fprintf ppf "(%a@ %a)" mod_ident (m, nok) + type_params (tp, nok) ]) + ctyp (te, ks ")" k) + | x -> + fun ppf curr next dg k -> not_impl "with_constr" x ppf k ]}]; + +(* main *) + +value output_string_eval ppf s = + loop 0 where rec loop i = + if i == String.length s then () + else if i == String.length s - 1 then pp_print_char ppf s.[i] + else + match (s.[i], s.[i + 1]) with + [ ('\\', 'n') -> do { pp_print_char ppf '\n'; loop (i + 2) } + | (c, _) -> do { pp_print_char ppf c; loop (i + 1) } ] +; + +value sep = Pcaml.inter_phrases; + +value input_source ic len = + let buff = Buffer.create 20 in + try + let rec loop i = + if i >= len then Buffer.contents buff + else do { let c = input_char ic in Buffer.add_char buff c; loop (i + 1) } + in + loop 0 + with + [ End_of_file -> + let s = Buffer.contents buff in + if s = "" then + match sep.val with + [ Some s -> s + | None -> "\n" ] + else s ] +; + +value copy_source ppf (ic, first, bp, ep) = + match sep.val with + [ Some str -> + if first then () + else if ep == in_channel_length ic then pp_print_string ppf "\n" + else output_string_eval ppf str + | None -> + do { + seek_in ic bp; + let s = input_source ic (ep - bp) in pp_print_string ppf s + } ] +; + +value copy_to_end ppf (ic, first, bp) = + let ilen = in_channel_length ic in + if bp < ilen then copy_source ppf (ic, first, bp, ilen) + else pp_print_string ppf "\n" +; + +value apply_printer printer ast = + let ppf = std_formatter in + if Pcaml.input_file.val <> "-" && Pcaml.input_file.val <> "" then do { + let ic = open_in_bin Pcaml.input_file.val in + try + let (first, last_pos) = + List.fold_left + (fun (first, last_pos) (si, (bp, ep)) -> + do { + fprintf ppf "@[%a@]@?" copy_source (ic, first, last_pos.Lexing.pos_cnum, bp.Lexing.pos_cnum); + fprintf ppf "@[%a@]@?" printer (si, nok); + (False, ep) + }) + (True, Token.nowhere) ast + in + fprintf ppf "@[%a@]@?" copy_to_end (ic, first, last_pos.Lexing.pos_cnum) + with x -> + do { fprintf ppf "@."; close_in ic; raise x }; + close_in ic; + } + else failwith "not implemented" +; + +Pcaml.print_interf.val := apply_printer sig_item; +Pcaml.print_implem.val := apply_printer str_item; + +Pcaml.add_option "-l" (Arg.Int (fun x -> set_margin x)) + "<length> Maximum line length for pretty printing."; + +Pcaml.add_option "-sep" (Arg.String (fun x -> sep.val := Some x)) + "<string> Use this string between phrases instead of reading source."; diff --git a/ocaml-binary-annot/camlp4/unmaintained/scheme/pr_schp_main.ml b/ocaml-binary-annot/camlp4/unmaintained/scheme/pr_schp_main.ml new file mode 100644 index 0000000000..4d3a6fb4a1 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/scheme/pr_schp_main.ml @@ -0,0 +1,132 @@ +(* pa_r.cmo q_MLast.cmo pa_extfun.cmo pr_dump.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file *) +(* ../../../LICENSE. *) +(* *) +(***********************************************************************) + + +open Format; +open Pcaml; +open Parserify; + +value nok = Pr_scheme.nok; +value ks = Pr_scheme.ks; +value patt = Pr_scheme.patt; +value expr = Pr_scheme.expr; +value find_pr_level = Pr_scheme.find_pr_level; +value pr_expr = Pr_scheme.pr_expr; +type printer_t 'a = Pr_scheme.printer_t 'a == + { pr_fun : mutable string -> Pr_scheme.next 'a; + pr_levels : mutable list (pr_level 'a) } +and pr_level 'a = Pr_scheme.pr_level 'a == + { pr_label : string; + pr_box : formatter -> (formatter -> unit) -> 'a -> unit; + pr_rules : mutable Pr_scheme.pr_rule 'a } +; + +(* extensions for rebuilding syntax of parsers *) + +value parser_cases ppf (spel, k) = + let rec parser_cases ppf (spel, k) = + match spel with + [ [] -> fprintf ppf "[: `HVbox [: b; k :] :]" + | [(sp, epo, e)] -> parser_case ppf (sp, epo, e, k) + | [(sp, epo, e) :: spel] -> + fprintf ppf "%a@ %a" parser_case (sp, epo, e, nok) + parser_cases (spel, k) ] + and parser_case ppf (sp, epo, e, k) = + fprintf ppf "(@[@[(%a)%t@]@ %a@]" stream_patt (sp, nok) + (fun ppf -> + match epo with + [ Some p -> fprintf ppf "@ %a" patt (p, nok) + | None -> () ]) + expr (e, ks ")" k) + and stream_patt ppf (sp, k) = + match sp with + [ [] -> k ppf + | [(spc, None)] -> fprintf ppf "%a" stream_patt_comp (spc, k) + | [(spc, Some e)] -> + fprintf ppf "(@[? %a@ %a@]" stream_patt_comp (spc, nok) + expr (e, ks ")" k) + | [(spc, None) :: spcl] -> + fprintf ppf "%a@ %a" stream_patt_comp (spc, nok) stream_patt (spcl, k) + | [(spc, Some e) :: spcl] -> + fprintf ppf "(@[? %a@ %a@]@ %a" stream_patt_comp (spc, nok) + expr (e, ks ")" nok) stream_patt (spcl, k) ] + and stream_patt_comp ppf (spc, k) = + match spc with + [ SPCterm (p, w) -> + match w with + [ Some e -> + fprintf ppf "(` %a@ %a" patt (p, nok) expr (e, ks ")" k) + | None -> fprintf ppf "(` %a" patt (p, ks ")" k) ] + | SPCnterm p e -> + fprintf ppf "(@[%a %a@]" patt (p, nok) expr (e, ks ")" k) + | SPCsterm p -> fprintf ppf "%a" patt (p, k) ] + in + parser_cases ppf (spel, k) +; + +value parser_body ppf (e, k) = + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + match parser_of_expr e with + [ [] -> + fprintf ppf "(parser%t%t" + (fun ppf -> + match bp with + [ Some p -> fprintf ppf "@ %a" patt (p, nok) + | _ -> ()]) + (ks ")" k) + | spel -> + fprintf ppf "(@[<v>@[parser%t@]@ @[<v 0>%a@]@]" + (fun ppf -> + match bp with + [ Some p -> fprintf ppf "@ %a" patt (p, nok) + | _ -> ()]) + parser_cases (spel, ks ")" k) ] +; + +value pmatch ppf (e, k) = + let (me, e) = + match e with + [ <:expr< let (__strm : Stream.t _) = $me$ in $e$ >> -> (me, e) + | _ -> failwith "Pr_schp_main.pmatch" ] + in + let (bp, e) = + match e with + [ <:expr< let $bp$ = Stream.count __strm in $e$ >> -> (Some bp, e) + | e -> (None, e) ] + in + let spel = parser_of_expr e in + fprintf ppf "(@[@[match_with_parser@ %a@]%t@ @[<v 0>%a@]@]" expr (me, nok) + (fun ppf -> + match bp with + [ Some p -> fprintf ppf "@ %a" patt (p, nok) + | _ -> () ]) + parser_cases (spel, ks ")" k) +; + +pr_expr_fun_args.val := + extfun pr_expr_fun_args.val with + [ <:expr< fun [(__strm : $_$) -> $_$] >> as ge -> ([], ge) ]; + +let lev = find_pr_level "top" pr_expr.pr_levels in +lev.pr_rules := + extfun lev.pr_rules with + [ <:expr< fun (__strm : $_$) -> $x$ >> -> + fun ppf curr next dg k -> fprintf ppf "%a" parser_body (x, k) + | <:expr< let (__strm : Stream.t _) = $_$ in $_$ >> as e -> + fun ppf curr next dg k -> fprintf ppf "%a" pmatch (e, k) ]; diff --git a/ocaml-binary-annot/camlp4/unmaintained/sml/.depend b/ocaml-binary-annot/camlp4/unmaintained/sml/.depend new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/sml/.depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/sml/Makefile b/ocaml-binary-annot/camlp4/unmaintained/sml/Makefile new file mode 100644 index 0000000000..ea3980bef4 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/sml/Makefile @@ -0,0 +1,68 @@ +######################################################################### +# # +# Objective Caml # +# # +# Camlp4 # +# # +# Copyright 2004 Institut National de Recherche en Informatique et # +# en Automatique. All rights reserved. This file is distributed # +# under the terms of the Q Public License version 1.0. # +# # +######################################################################### +# +# Makefile for pa_sml +# M.Mauny +# + +include ../../config/Makefile.cnf + +OCAMLTOP=../../.. + +OCAMLC=$(OCAMLTOP)/ocamlc$(EXE) -nostdlib -I $(OCAMLTOP)/stdlib +OCAMLOPT=$(OCAMLTOP)/ocamlopt$(EXE) -nostdlib -I $(OCAMLTOP)/stdlib + +P4INCLUDES=-I ../../meta -I ../../etc -I ../../lib -I ../../camlp4 +OCAMLINCLUDES=-I ../../meta -I ../../lib -I ../../camlp4 + +CAMLP4=camlp4$(EXE) -nolib +OCAMLCFLAGS=-warn-error A $(OCAMLINCLUDES) + +SRC=pa_sml.ml +OBJS=$(SRC:.ml=.cmo) +OBJSX=$(SRC:.ml=.cmx) + +all: $(OBJS) smllib.cmo + +opt: $(OBJSX) smllib.cmx + +depend: + cp .depend .depend.bak + > .depend + for file in $(SRC); do \ + $(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $$file` pr_depend.cmo $$i | \ + sed -e 's| \.\./\.\./\.\.| $$(OCAMLTOP)|g' >> .depend; \ + done + +clean: + rm -f *.cm* *.o *.bak .*.bak + + +.SUFFIXES: .cmx .cmo .cmi .ml .mli .sml + +.mli.cmi: + $(OCAMLC) $(OCAMLCFLAGS) -c $< + + +.sml.cmo: + $(OCAMLC) -I ../../../otherlibs/unix -pp "$(CAMLP4) ./pa_sml.cmo ../../meta/pr_dump.cmo -impl" -c -o $*.cmo -impl $< + +.sml.cmx: + $(OCAMLOPT) -I ../../../otherlibs/unix -pp "$(CAMLP4) ./pa_sml.cmo ../../meta/pr_dump.cmo -impl" -c -o $*.cmx -impl $< + +.ml.cmo: + $(OCAMLC) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +.ml.cmx: + $(OCAMLOPT) $(OCAMLCFLAGS) -pp "$(CAMLP4) $(P4INCLUDES) `awk 'NR == 1 { ORS=" "; for (i=2; i < NF; i++) print $$i; } ' $<`" -c $< + +include .depend diff --git a/ocaml-binary-annot/camlp4/unmaintained/sml/README b/ocaml-binary-annot/camlp4/unmaintained/sml/README new file mode 100644 index 0000000000..809d42f2a8 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/sml/README @@ -0,0 +1,15 @@ +This is an application of or an extension for Camlp4. Although it is +currently distributed with OCaml/Camlp4, it may or may not be +actively maintained. + +It probably won't be part of future OCaml/Camlp4 distributions but be +accessible from the Camlp4 hump. If you are interested in developing +this package further and/or actively maintain it, please let us know +(caml@inria.fr) + +This package is distributed under the same license as the Objective +Caml Library (that is, LGPL with a special exception allowing both +static and dynamic link). + +-- Michel Mauny + diff --git a/ocaml-binary-annot/camlp4/unmaintained/sml/pa_sml.ml b/ocaml-binary-annot/camlp4/unmaintained/sml/pa_sml.ml new file mode 100644 index 0000000000..1808cdea5e --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/sml/pa_sml.ml @@ -0,0 +1,952 @@ +(* pa_r.cmo pa_rp.cmo pa_extend.cmo q_MLast.cmo pr_dump.cmo *) +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the GNU Library General Public License, with *) +(* the special exception on linking described in file *) +(* ../../../LICENSE. *) +(* *) +(***********************************************************************) + + + +open Stdpp; +open Pcaml; + +value ocaml_records = ref False; + +Pcaml.no_constructors_arity.val := True; + +value lexer = Plexer.gmake (); + +do { + Grammar.Unsafe.gram_reinit gram lexer; + Grammar.Unsafe.clear_entry interf; + Grammar.Unsafe.clear_entry implem; + Grammar.Unsafe.clear_entry top_phrase; + Grammar.Unsafe.clear_entry use_file; + Grammar.Unsafe.clear_entry module_type; + Grammar.Unsafe.clear_entry module_expr; + Grammar.Unsafe.clear_entry sig_item; + Grammar.Unsafe.clear_entry str_item; + Grammar.Unsafe.clear_entry expr; + Grammar.Unsafe.clear_entry patt; + Grammar.Unsafe.clear_entry ctyp; + Grammar.Unsafe.clear_entry let_binding; +}; + +Pcaml.parse_interf.val := Grammar.Entry.parse interf; +Pcaml.parse_implem.val := Grammar.Entry.parse implem; + +value not_impl loc s = + raise_with_loc loc (Stream.Error ("not implemented feature [" ^ s ^ "]")) +; + +type altern 'a 'b = [ Left of 'a | Right of 'b ]; + +value get_seq = + fun + [ <:expr< do { $list:el$ } >> -> el + | e -> [e] ] +; + +value choose_tvar tpl = + let rec find_alpha v = + let s = String.make 1 v in + if List.mem_assoc s tpl then + if v = 'z' then None else find_alpha (Char.chr (Char.code v + 1)) + else Some (String.make 1 v) + in + let rec make_n n = + let v = "a" ^ string_of_int n in + if List.mem_assoc v tpl then make_n (succ n) else v + in + match find_alpha 'a' with + [ Some x -> x + | None -> make_n 1 ] +; + +value mklistexp loc last = + loop True where rec loop top = + fun + [ [] -> + match last with + [ Some e -> e + | None -> <:expr< [] >> ] + | [e1 :: el] -> + let loc = if top then loc else (fst (MLast.loc_of_expr e1), snd loc) in + <:expr< [$e1$ :: $loop False el$] >> ] +; + +value mklistpat loc last = + loop True where rec loop top = + fun + [ [] -> + match last with + [ Some p -> p + | None -> <:patt< [] >> ] + | [p1 :: pl] -> + let loc = if top then loc else (fst (MLast.loc_of_patt p1), snd loc) in + <:patt< [$p1$ :: $loop False pl$] >> ] +; + +value expr_of_patt p = + let loc = MLast.loc_of_patt p in + match p with + [ <:patt< $lid:x$ >> -> <:expr< $lid:x$ >> + | _ -> Stdpp.raise_with_loc loc (Stream.Error "identifier expected") ] +; + +value apply_bind loc e bl = + let rec loop e = + fun + [ [] -> e + | [<:str_item< value $p1$ = $e1$ >> :: list] -> + loop_let e [(p1, e1)] list + | [<:str_item< value rec $p1$ = $e1$ >> :: list] -> + loop_letrec e [(p1, e1)] list + | [<:str_item< module $s$ = $me$ >> :: list] -> + let e = <:expr< let module $s$ = $me$ in $e$ >> in + loop e list + | [si :: list] -> + raise Exit ] + and loop_let e pel = + fun + [ [<:str_item< value $p1$ = $e1$ >> :: list] -> + loop_let e [(p1, e1) :: pel] list + | list -> + let e = <:expr< let $list:pel$ in $e$ >> in + loop e list ] + and loop_letrec e pel = + fun + [ [<:str_item< value rec $p1$ = $e1$ >> :: list] -> + loop_letrec e [(p1, e1) :: pel] list + | list -> + let e = <:expr< let rec $list:pel$ in $e$ >> in + loop e list ] + in + loop e (List.rev bl) +; + +value make_local loc sl1 sl2 = + try + let pl = + List.map + (fun + [ <:str_item< value $opt:_$ $p$ = $_$ >> -> p + | _ -> raise Exit ]) + sl2 + in + let e1 = + match List.map expr_of_patt pl with + [ [e] -> e + | el -> <:expr< ($list:el$) >> ] + in + let p1 = + match pl with + [ [p] -> p + | pl -> <:patt< ($list:pl$) >> ] + in + let e = apply_bind loc e1 sl2 in + let e = apply_bind loc e sl1 in + <:str_item< value $p1$ = $e$ >> + with + [ Exit -> + do { + Printf.eprintf "\ +*** Warning: a 'local' statement will be defined global because of bindings +which cannot be defined as first class values (modules, exceptions, ...)\n"; + flush stderr; + <:str_item< declare $list:sl1 @ sl2$ end >> + } ] +; + +value str_declare loc = + fun + [ [d] -> d + | dl -> <:str_item< declare $list:dl$ end >> ] +; + +value sig_declare loc = + fun + [ [d] -> d + | dl -> <:sig_item< declare $list:dl$ end >> ] +; + +value extract_label_types loc tn tal cdol = + let (cdl, aux) = + List.fold_right + (fun (loc, c, tl, aux_opt) (cdl, aux) -> + match aux_opt with + [ Some anon_record_type -> + let new_tn = tn ^ "_" ^ c in + let loc = MLast.loc_of_ctyp anon_record_type in + let aux_def = ((loc, new_tn), [], anon_record_type, []) in + let tl = [<:ctyp< $lid:new_tn$ >>] in + ([(loc, c, tl) :: cdl], [aux_def :: aux]) + | None -> ([(loc, c, tl) :: cdl], aux) ]) + cdol ([], []) + in + [((loc, tn), tal, <:ctyp< [ $list:cdl$ ] >>, []) :: aux] +; + +value function_of_clause_list loc xl = + let (fname, fname_loc, nbpat, l) = + List.fold_left + (fun (fname, fname_loc, nbpat, l) ((x1, loc), x2, x3, x4) -> + let (fname, fname_loc, nbpat) = + if fname = "" then (x1, loc, List.length x2) + else if x1 <> fname then + raise_with_loc loc + (Stream.Error ("'" ^ fname ^ "' expected")) + else if List.length x2 <> nbpat then + raise_with_loc loc + (Stream.Error "bad number of patterns in that clause") + else (fname, fname_loc, nbpat) + in + let x4 = + match x3 with + [ Some t -> <:expr< ($x4$ : $t$) >> + | _ -> x4 ] + in + let l = [(x2, x4) :: l] in + (fname, fname_loc, nbpat, l)) + ("", loc, 0, []) xl + in + let l = List.rev l in + let e = + match l with + [ [(pl, e)] -> + List.fold_right (fun p e -> <:expr< fun $p$ -> $e$ >>) pl e + | _ -> + if nbpat = 1 then + let pwel = + List.map + (fun (pl, e) -> (<:patt< $List.hd pl$ >>, None, e)) l + in + <:expr< fun [ $list:pwel$ ] >> + else + let sl = + loop 0 where rec loop n = + if n = nbpat then [] + else ["a" ^ string_of_int (n + 1) :: loop (n + 1)] + in + let e = + let el = List.map (fun s -> <:expr< $lid:s$ >>) sl in + let pwel = + List.map + (fun (pl, e) -> (<:patt< ($list:pl$) >>, None, e)) l + in + <:expr< match ($list:el$) with [ $list:pwel$ ] >> + in + List.fold_right (fun s e -> <:expr< fun $lid:s$ -> $e$ >>) sl e ] + in + (let loc = fname_loc in <:patt< $lid:fname$ >>, e) +; + +value record_expr loc x1 = + if ocaml_records.val then <:expr< { $list:x1$ } >> + else + let list1 = + List.map + (fun (l, v) -> + let id = + match l with + [ <:patt< $lid:l$ >> -> l + | _ -> "" ] + in + let loc = MLast.loc_of_expr v in + <:class_str_item< value $id$ = $v$ >>) + x1 + in + let list2 = + List.map + (fun (l, v) -> + let id = + match l with + [ <:patt< $lid:l$ >> -> l + | _ -> "" ] + in + let loc = MLast.loc_of_patt l in + <:class_str_item< method $id$ = $lid:id$ >>) + x1 + in + <:expr< + let module M = + struct + class a = object $list:list1 @ list2$ end; + end + in + new M.a + >> +; + +value record_match_assoc loc lpl e = + if ocaml_records.val then (<:patt< { $list:lpl$ } >>, e) + else + let pl = List.map (fun (_, p) -> p) lpl in + let e = + let el = + List.map + (fun (l, _) -> + let s = + match l with + [ <:patt< $lid:l$ >> -> l + | _ -> "" ] + in + let loc = MLast.loc_of_patt l in + <:expr< v # $lid:s$ >>) + lpl + in + let loc = MLast.loc_of_expr e in + <:expr< let v = $e$ in ($list:el$) >> + in + let p = <:patt< ($list:pl$) >> in + (p, e) +; + +value op = + Grammar.Entry.of_parser gram "op" + (parser [: `("", "op"); `(_, x) :] -> x) +; +lexer.Token.tok_using ("", "op"); + +value special x = + if String.length x >= 2 then + match x.[0] with + [ '+' | '<' | '^' -> True + | _ -> False ] + else False +; + +value idd = + let p = + parser + [ [: `("LIDENT", x) :] -> x + | [: `("UIDENT", x) :] -> x + | [: `("", "op"); `(_, x) :] -> x + | [: `("", x) when special x :] -> x ] + in + Grammar.Entry.of_parser Pcaml.gram "ID" p +; + +value uncap s = String.uncapitalize s; + +EXTEND + GLOBAL: implem interf top_phrase use_file sig_item str_item ctyp patt expr + module_type module_expr; + + implem: + [ [ x = interdec; EOI -> x ] ] + ; + interf: + [ [ x = LIST1 [ s = sig_item; OPT ";" -> (s, loc) ] -> (x, False) ] ] + ; + top_phrase: + [ [ ph = phrase; ";" -> Some ph + | EOI -> None ] ] + ; + use_file: + [ [ l = LIST0 phrase; EOI -> (l, False) ] ] + ; + phrase: + [ [ x = str_item -> x + | x = expr -> <:str_item< $exp:x$ >> + | "#"; n = LIDENT; dp = dir_param -> MLast.StDir loc n dp ] ] + ; + dir_param: + [ [ -> None + | e = expr -> Some e ] ] + ; + sdecs: + [ [ x = sdec; l = sdecs -> [x :: l] + | ";"; l = sdecs -> l + | -> [] ] ] + ; + + fsigb: [ [ -> not_impl loc "fsigb" ] ]; + fsigconstraint_op: [ [ -> not_impl loc "fsigconstraint_op" ] ]; + fct_exp: [ [ -> not_impl loc "fct_exp" ] ]; + exp_pa: [ [ -> not_impl loc "exp_pa" ] ]; + rvb: [ [ -> not_impl loc "rvb" ] ]; + tyvarseq: [ [ -> not_impl loc "tyvarseq" ] ]; + + tyvar_pc: + [ [ "'"; x1 = LIDENT -> [(x1, (False, False))] + | "'"; x1 = LIDENT; ","; l = tyvar_pc -> [(x1, (False, False)) :: l] ] ] + ; + id: + [ [ x1 = idd -> x1 + | "*" -> "*" ] ] + ; + ident: + [ [ x1 = idd -> x1 + | "*" -> "*" + | "=" -> "=" + | "<" -> "<" + | ">" -> ">" + | "<=" -> "<=" + | ">=" -> ">=" + | "^" -> "^" ] ] + ; + op_op: + [ [ x1 = op -> not_impl loc "op_op 1" + | -> () ] ] + ; + qid: + [ [ x1 = idd; "."; x2 = qid -> <:module_expr< $uid:x1$ . $x2$ >> + | x1 = idd -> <:module_expr< $uid:x1$ >> + | x1 = "*" -> <:module_expr< $uid:x1$ >> + | x1 = "=" -> <:module_expr< $uid:x1$ >> ] ] + ; + eqid: + [ [ x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >> + | x1 = UIDENT -> <:expr< $uid:x1$ >> + | x1 = idd -> <:expr< $lid:x1$ >> + | x1 = "*" -> <:expr< $lid:x1$ >> + | x1 = "=" -> <:expr< $lid:x1$ >> ] ] + ; + sqid: + [ [ x1 = idd; "."; x2 = sqid -> [x1 :: x2] + | x1 = idd -> [x1] + | x1 = "*" -> [x1] + | x1 = "=" -> [x1] ] ] + ; + tycon: + [ [ LIDENT "real" -> <:ctyp< float >> + | x1 = idd; "."; x2 = tycon -> + let r = <:ctyp< $uid:x1$ . $x2$ >> in + loop r where rec loop = + fun + [ <:ctyp< $a$ . ($b$ . $c$) >> -> <:ctyp< $a$ . $b$ . $loop c$ >> + | x -> x ] + | x1 = idd -> <:ctyp< $lid:uncap x1$ >> ] ] + ; + selector: + [ [ x1 = id -> x1 + | x1 = INT -> not_impl loc "selector 1" ] ] + ; + tlabel: + [ [ x1 = selector; ":"; x2 = ctyp -> (loc, x1, False, x2) ] ] + ; + tuple_ty: + [ [ x1 = ctyp LEVEL "ty'"; "*"; x2 = tuple_ty -> [x1 :: x2] + | x1 = ctyp LEVEL "ty'" -> [x1] ] ] + ; + ctyp: + [ RIGHTA + [ x1 = ctyp; "->"; x2 = ctyp -> <:ctyp< $x1$ -> $x2$ >> ] + | [ x1 = ctyp; "*"; x2 = tuple_ty -> <:ctyp< ($list:[x1 :: x2]$) >> ] + | "ty'" + [ "'"; x1 = LIDENT -> <:ctyp< '$x1$ >> + | "'"; "'"; x1 = LIDENT -> <:ctyp< '$x1$ >> + | "{"; x1 = LIST1 tlabel SEP ","; "}" -> + if ocaml_records.val then <:ctyp< { $list:x1$ } >> + else + let list = List.map (fun (_, l, _, t) -> (l, t)) x1 in + <:ctyp< < $list:list$ > >> + | "{"; "}" -> not_impl loc "ty' 3" + | "("; x1 = ctyp; ","; x2 = LIST1 ctyp SEP ","; ")"; x3 = tycon -> + List.fold_left (fun t1 t2 -> <:ctyp< $t1$ $t2$ >>) x3 [x1 :: x2] + | "("; x1 = ctyp; ")" -> x1 + | x1 = ctyp; x2 = tycon -> <:ctyp< $x2$ $x1$ >> + | x1 = tycon -> x1 ] ] + ; + rule: + [ [ x1 = patt; "=>"; x2 = expr -> (x1, None, x2) ] ] + ; + elabel: + [ [ x1 = selector; "="; x2 = expr -> (<:patt< $lid:x1$ >>, x2) ] ] + ; + exp_ps: + [ [ x1 = expr -> x1 + | x1 = expr; ";"; x2 = exp_ps -> + <:expr< do { $list:[x1 :: get_seq x2]$ } >> ] ] + ; + expr: + [ [ "if"; x1 = expr; "then"; x2 = expr; "else"; x3 = expr -> + <:expr< if $x1$ then $x2$ else $x3$ >> + | "fn"; x1 = LIST1 rule SEP "|" -> <:expr< fun [$list:x1$] >> + | "case"; x1 = expr; "of"; x2 = LIST1 rule SEP "|" -> + <:expr< match $x1$ with [$list:x2$] >> + | "while"; x1 = expr; "do"; x2 = expr -> + <:expr< while $x1$ do { $x2$ } >> + | x1 = expr; "handle"; x2 = LIST1 rule SEP "|" -> + <:expr< try $x1$ with [$list:x2$] >> ] + | RIGHTA + [ "raise"; x1 = expr -> <:expr< raise $x1$ >> ] + | [ e1 = expr; ":="; e2 = expr -> <:expr< $e1$.val := $e2$ >> ] + | LEFTA + [ x1 = expr; "orelse"; x2 = expr -> <:expr< $x1$ || $x2$ >> ] + | LEFTA + [ x1 = expr; "andalso"; x2 = expr -> <:expr< $x1$ && $x2$ >> ] + | LEFTA + [ x1 = expr; ":"; x2 = ctyp -> <:expr< ($x1$ : $x2$) >> ] + | "4" NONA + [ x1 = expr; "<"; x2 = expr -> <:expr< $x1$ < $x2$ >> + | x1 = expr; ">"; x2 = expr -> <:expr< $x1$ > $x2$ >> + | x1 = expr; "<>"; x2 = expr -> <:expr< $x1$ <> $x2$ >> + | x1 = expr; "="; x2 = expr -> <:expr< $x1$ = $x2$ >> + | x1 = expr; ">="; x2 = expr -> <:expr< $x1$ >= $x2$ >> + | x1 = expr; "<="; x2 = expr -> <:expr< $x1$ <= $x2$ >> ] + | RIGHTA + [ x1 = expr; "^"; x2 = expr -> <:expr< $x1$ ^ $x2$ >> + | x1 = expr; "@"; x2 = expr -> <:expr< $x1$ @ $x2$ >> + | x1 = expr; "o"; x2 = expr -> <:expr< ooo $x1$ $x2$ >> ] + | "5" RIGHTA + [ x1 = expr; "::"; x2 = expr -> <:expr< [$x1$ :: $x2$] >> ] + | "6" LEFTA + [ x1 = expr; "+"; x2 = expr -> <:expr< $x1$ + $x2$ >> + | x1 = expr; "-"; x2 = expr -> <:expr< $x1$ - $x2$ >> ] + | "7" LEFTA + [ x1 = expr; "*"; x2 = expr -> <:expr< $x1$ * $x2$ >> + | x1 = expr; "/"; x2 = expr -> <:expr< $x1$ / $x2$ >> + | x1 = expr; "div"; x2 = expr -> <:expr< $x1$ / $x2$ >> + | x1 = expr; "mod"; x2 = expr -> <:expr< $x1$ mod $x2$ >> ] + | LEFTA + [ x1 = expr; x2 = expr -> <:expr< $x1$ $x2$ >> ] + | [ "#"; x1 = STRING -> <:expr< $chr:x1$ >> + | "#"; x1 = selector; x2 = expr -> + if ocaml_records.val then <:expr< $x2$ . $lid:x1$ >> + else <:expr< $x2$ # $lid:x1$ >> + | x1 = expr; "ocaml_record_access"; x2 = expr -> <:expr< $x1$ . $x2$ >> ] + | [ "!"; x1 = expr -> <:expr< $x1$ . val >> + | "~"; x1 = expr -> <:expr< - $x1$ >> ] + | [ x1 = LIDENT -> + match x1 with + [ "true" | "false" -> <:expr< $uid:String.capitalize x1$ >> + | "nil" -> <:expr< [] >> + | _ -> <:expr< $lid:x1$ >> ] + | x1 = UIDENT -> <:expr< $uid:x1$ >> + | x1 = UIDENT; "."; x2 = eqid -> <:expr< $uid:x1$ . $x2$ >> + | x1 = INT -> <:expr< $int:x1$ >> + | x1 = FLOAT -> <:expr< $flo:x1$ >> + | x1 = STRING -> <:expr< $str:x1$ >> + | "~"; x1 = INT -> <:expr< $int:"-"^x1$ >> + | i = op -> + if i = "::" then <:expr< fun (x, y) -> [x :: y] >> + else <:expr< fun (x, y) -> $lid:i$ x y >> + | "let"; x1 = ldecs; "in"; x2 = exp_ps; "end" -> + List.fold_right + (fun pel x2 -> + let loc = + match pel with + [ [(p, _) :: _] -> + (fst (MLast.loc_of_patt p), snd (MLast.loc_of_expr x2)) + | _ -> loc ] + in + match pel with + [ [(_, <:expr< fun [$list:_$] >>) :: _] -> + <:expr< let rec $list:pel$ in $x2$ >> + | _ -> + let pel = + List.map + (fun (p, e) -> + match p with + [ <:patt< { $list:lpl$ } >> -> + record_match_assoc (MLast.loc_of_patt p) lpl e + | _ -> (p, e) ]) + pel + in + <:expr< let $list:pel$ in $x2$ >> ]) + x1 x2 + | "{"; x1 = LIST1 elabel SEP ","; "}" -> record_expr loc x1 + | "["; "]" -> <:expr< [] >> + | "["; x1 = expr; "]" -> <:expr< [$x1$] >> + | "["; x1 = expr; ","; x2 = LIST1 SELF SEP ","; "]" -> + mklistexp loc None [x1 :: x2] + | "("; ")" -> <:expr< () >> + | "("; x1 = expr; ","; x2 = LIST1 SELF SEP ","; ")" -> + <:expr< ($list:[x1::x2]$) >> + | "("; x1 = expr; ";"; x2 = LIST1 SELF SEP ";"; ")" -> + <:expr< do { $list:[x1::x2]$ } >> + | "("; x1 = expr; ")" -> x1 ] ] + ; + fixity: + [ [ "infix" -> ("infix", None) + | "infix"; x1 = INT -> not_impl loc "fixity 2" + | "infixr" -> not_impl loc "fixity 3" + | "infixr"; x1 = INT -> ("infixr", Some x1) + | "nonfix" -> not_impl loc "fixity 5" ] ] + ; + patt: + [ [ x1 = patt; "as"; x2 = patt -> <:patt< ($x1$ as $x2$) >> ] + | LEFTA + [ x1 = patt; ":"; x2 = ctyp -> <:patt< ($x1$ : $x2$) >> ] + | RIGHTA + [ x1 = patt; "::"; x2 = patt -> <:patt< [$x1$ :: $x2$] >> ] + | [ x1 = patt; x2 = patt -> + match x1 with + [ <:patt< ref >> -> <:patt< {contents = $x2$} >> + | _ -> <:patt< $x1$ $x2$ >> ] ] + | "apat" + [ x1 = patt; "."; x2 = patt -> <:patt< $x1$ . $x2$ >> + | x1 = INT -> <:patt< $int:x1$ >> + | x1 = UIDENT -> <:patt< $uid:x1$ >> + | x1 = STRING -> <:patt< $str:x1$ >> + | "#"; x1 = STRING -> <:patt< $chr:x1$ >> + | "~"; x1 = INT -> <:patt< $int:"-"^x1$ >> + | LIDENT "nil" -> <:patt< [] >> + | LIDENT "false" -> <:patt< False >> + | LIDENT "true" -> <:patt< True >> + | x1 = id -> <:patt< $lid:x1$ >> + | x1 = op -> <:patt< $lid:x1$ >> + | "_" -> <:patt< _ >> + | "["; "]" -> <:patt< [] >> + | "["; x1 = patt; "]" -> <:patt< [$x1$] >> + | "["; x1 = patt; ","; x2 = LIST1 SELF SEP ","; "]" -> + mklistpat loc None [x1 :: x2] + | "{"; x1 = LIST1 plabel SEP ","; "}" -> <:patt< {$list:x1$} >> + | "("; ")" -> <:patt< () >> + | "("; x1 = patt; ","; x2 = LIST1 SELF SEP ","; ")" -> + <:patt< ($list:[x1::x2]$) >> + | "("; x1 = patt; ")" -> x1 ] ] + ; + plabel: + [ [ x1 = selector; "="; x2 = patt -> (<:patt< $lid:x1$ >>, x2) + | x1 = selector -> (<:patt< $lid:x1$ >>, <:patt< $lid:x1$ >>) ] ] + ; + vb: + [ [ "lazy"; x1 = patt; "="; x2 = expr -> not_impl loc "vb 1" + | x1 = patt; "="; x2 = expr -> (x1, x2) ] ] + ; + constrain: + [ [ -> None + | ":"; x1 = ctyp -> Some x1 ] ] + ; + fb: + [ [ xl = LIST1 clause SEP "|" -> function_of_clause_list loc xl + | "lazy"; x1 = LIST1 clause SEP "|" -> not_impl loc "fb 2" ] ] + ; + clause: + [ [ x1 = patt LEVEL "apat"; x2 = LIST1 (patt LEVEL "apat"); + x3 = constrain; "="; x4 = expr -> + let x1 = + match x1 with + [ <:patt< $lid:id$ >> -> (id, MLast.loc_of_patt x1) + | _ -> not_impl loc "clause 1" ] + in + (x1, x2, x3, x4) ] ] + ; + tb: + [ [ x1 = tyvars; x2 = idd; "="; x3 = ctyp -> + ((loc, uncap x2), x1, x3, []) + | x1 = tyvars; x2 = idd; "="; x3 = ctyp; "=="; x4 = dbrhs -> + let x4 = List.map (fun (loc, c, tl, _) -> (loc, c, tl)) x4 in + ((loc, uncap x2), x1, <:ctyp< $x3$ == [ $list:x4$ ] >>, []) ] ] + ; + tyvars: + [ [ "'"; x1 = LIDENT -> [(x1, (False, False))] + | "("; x1 = tyvar_pc; ")" -> x1 + | -> [] ] ] + ; + db1: + [ [ x1 = tyvars; x2 = ident; "="; x3 = dbrhs -> + let x2 = uncap x2 in + extract_label_types loc x2 x1 x3 + | "lazy"; x1 = tyvars; x2 = ident; "="; x3 = dbrhs -> + not_impl loc "db 2" ] ] + ; + db: + [ [ x1 = LIST1 db1 SEP "and" -> + List.fold_right (fun td tdl -> td @ tdl) x1 [] ] ] + ; + dbrhs: + [ [ x1 = LIST1 constr SEP "|" -> x1 + | "datatype"; x1 = tycon -> not_impl loc "dbrhs 2" ] ] + ; + constr: + [ [ x1 = op_op; x2 = ident -> (loc, x2, [], None) + | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> + match x3 with + [ <:ctyp< {$list:_$} >> -> (loc, x2, [], Some x3) + | _ -> (loc, x2, [x3], None) ] ] ] + ; + eb: + [ [ x1 = op_op; x2 = ident -> (x2, [], []) + | x1 = op_op; x2 = ident; "of"; x3 = ctyp -> (x2, [x3], []) + | x1 = op_op; x2 = ident; "="; x3 = sqid -> (x2, [], x3) ] ] + ; + ldec1: + [ [ "val"; x1 = LIST1 vb SEP "and" -> x1 + | "fun"; x1 = LIST1 fb SEP "and" -> x1 ] ] + ; + ldecs: + [ [ -> [] + | x1 = ldec1; x2 = ldecs -> [x1 :: x2] + | ";"; x1 = ldecs -> x1 + | "local"; x1 = ldecs; "in"; x2 = ldecs; "end"; x3 = ldecs -> + not_impl loc "ldecs 4" ] ] + ; + spec_s: + [ [ -> [] + | x1 = spec; x2 = spec_s -> [x1 :: x2] + | ";"; x1 = spec_s -> x1 ] ] + ; + spec: + [ [ "structure"; x1 = LIST1 strspec SEP "and" -> sig_declare loc x1 + | "functor"; x1 = LIST1 fctspec SEP "and" -> sig_declare loc x1 + | "datatype"; x1 = db -> <:sig_item< type $list:x1$ >> + | "type"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >> + | "eqtype"; x1 = LIST1 tyspec SEP "and" -> <:sig_item< type $list:x1$ >> + | "val"; x1 = LIST1 valspec SEP "and" -> sig_declare loc x1 + | "exception"; x1 = LIST1 exnspec SEP "and" -> sig_declare loc x1 + | "sharing"; x1 = LIST1 sharespec SEP "and" -> <:sig_item< declare end >> + | "include"; x1 = module_type -> <:sig_item< include $x1$ >> ] ] + ; + sig_item: + [ [ x = spec -> x ] ] + ; + strspec: + [ [ x1 = ident; ":"; x2 = module_type; x3 = LIST0 sharing_def -> + let x2 = + List.fold_left + (fun mt sdl -> + List.fold_right + (fun spl mt -> + match spl with + [ Right ([m1], m2) -> + let (m1, m2) = + match m2 with + [ <:module_expr< $uid:x$ . $_$ >> -> + if x = x1 then (m2, m1) else (m1, m2) + | _ -> (m1, m2) ] + in + let m1 = + loop m1 where rec loop = + fun + [ <:module_expr< $uid:x$ >> -> x + | <:module_expr< $uid:x$ . $y$ >> -> loop y + | _ -> not_impl loc "strspec 2" ] + in + <:module_type< $mt$ with module $[m1]$ = $m2$ >> + | _ -> not_impl loc "strspec 1" ]) + sdl mt) + x2 x3 + in + <:sig_item< module $x1$ : $x2$ >> ] ] + ; + sharing_def: + [ [ "sharing"; x3 = LIST1 sharespec SEP "and" -> x3 ] ] + ; + fctspec: + [ [ x1 = ident; x2 = fsig -> <:sig_item< module $x1$ : $x2$ >> ] ] + ; + tyspec: + [ [ x1 = tyvars; x2 = idd -> + ((loc, uncap x2), x1, <:ctyp< '$choose_tvar x1$ >>, []) + | x1 = tyvars; x2 = idd; "="; x3 = ctyp -> + ((loc, uncap x2), x1, x3, []) ] ] + ; + valspec: + [ [ x1 = op_op; x2 = ident; ":"; x3 = ctyp -> + <:sig_item< value $x2$ : $x3$ >> ] ] + ; + exnspec: + [ [ x1 = ident -> <:sig_item< exception $x1$ >> + | x1 = ident; "of"; x2 = ctyp -> + <:sig_item< exception $x1$ of $x2$ >> ] ] + ; + sharespec: + [ [ "type"; x1 = patheqn -> Left x1 + | x1 = patheqn -> Right x1 ] ] + ; + patheqn: + [ [ l = patheqn1 -> l ] ] + ; + patheqn1: + [ [ (l, y) = patheqn1; "="; x = qid -> ([y :: l], x) + | x = qid -> ([], x) ] ] + ; + whspec: + [ [ "type"; x1 = tyvars; x2 = sqid; "="; x3 = ctyp -> + MLast.WcTyp loc x2 x1 x3 + | x1 = sqid; "="; x2 = qid -> MLast.WcMod loc x1 x2 ] ] + ; + module_type: + [ [ x1 = ident -> <:module_type< $uid:x1$ >> + | "sig"; x1 = spec_s; "end" -> <:module_type< sig $list:x1$ end >> + | x1 = module_type; "where"; x2 = LIST1 whspec SEP "and" -> + <:module_type< $x1$ with $list:x2$ >> ] ] + ; + sigconstraint_op: + [ [ -> None + | ":"; x1 = module_type -> Some x1 + | ":>"; x1 = module_type -> not_impl loc "sigconstraint_op 3" ] ] + ; + sigb: + [ [ x1 = ident; "="; x2 = module_type -> + <:str_item< module type $x1$ = $x2$ >> ] ] + ; + fsig: + [ [ ":"; x1 = ident -> not_impl loc "fsig 1" + | x1 = fparamList; ":"; x2 = module_type -> not_impl loc "fsig 2" ] ] + ; + module_expr: + [ [ x1 = qid -> x1 + | "struct"; x1 = strdecs; "end" -> <:module_expr< struct $list:x1$ end >> + | x1 = qid; x2 = arg_fct -> + match x2 with + [ Left [] -> x1 + | Left x2 -> <:module_expr< $x1$ (struct $list:x2$ end) >> + | Right x2 -> <:module_expr< $x1$ $x2$ >> ] + | "let"; x1 = strdecs; "in"; x2 = module_expr; "end" -> + not_impl loc "str 4" + | x1 = module_expr; ":"; x2 = module_type -> not_impl loc "str 5" + | x1 = module_expr; x2 = ":>"; x3 = module_type -> + not_impl loc "str 6" ] ] + ; + arg_fct: + [ [ "("; x1 = strdecs; ")"; x2 = arg_fct -> not_impl loc "arg_fct 1" + | "("; x1 = module_expr; ")"; x2 = arg_fct -> not_impl loc "arg_fct 2" + | "("; x1 = module_expr; ")" -> Right x1 + | "("; x2 = strdecs; ")" -> Left x2 ] ] + ; + strdecs: + [ [ x1 = str_item LEVEL "strdec"; x2 = strdecs -> [x1 :: x2] + | ";"; x1 = strdecs -> x1 + | -> [] ] ] + ; + str_item: + [ [ "signature"; x1 = LIST1 sigb SEP "and" -> str_declare loc x1 + | "funsig"; x1 = fsigb -> not_impl loc "sdec 3" ] + | "strdec" + [ "structure"; x1 = LIST1 strb SEP "and" -> str_declare loc x1 + | "functor"; x1 = LIST1 fctb SEP "and" -> str_declare loc x1 + | "local"; x1 = sdecs; "in"; x2 = sdecs; "end" -> + make_local loc x1 x2 ] + | [ "val"; x1 = LIST1 vb SEP "and" -> <:str_item< value $list:x1$ >> + | "val"; x1 = tyvarseq; x3 = LIST1 vb SEP "and" -> + not_impl loc "ldec 2" + | "val"; "rec"; x1 = rvb -> not_impl loc "ldec 3" + | "val"; "rec"; x1 = tyvarseq; x2 = rvb -> not_impl loc "ldec 4" + | "fun"; x1 = LIST1 fb SEP "and" -> <:str_item< value rec $list:x1$ >> + | "fun"; x1 = tyvarseq; x2 = fb -> not_impl loc "ldec 6" + | "type"; x1 = LIST1 tb SEP "and" -> <:str_item< type $list:x1$ >> + | "datatype"; x1 = db -> <:str_item< type $list:x1$ >> + | "datatype"; x1 = db; "withtype"; x2 = tb -> + <:str_item< type $list:x1 @ [x2]$ >> + | "abstype"; x1 = db; "with"; x2 = ldecs; "end" -> not_impl loc "ldec 10" + | "abstype"; x1 = db; "withtype"; x2 = tb; "with"; x3 = ldecs; "end" -> + not_impl loc "ldec 11" + | "exception"; x1 = LIST1 eb SEP "and" -> + let dl = + List.map + (fun (s, tl, eqn) -> + <:str_item< exception $s$ of $list:tl$ = $eqn$ >>) + x1 + in + str_declare loc dl + | "open"; x1 = LIST1 sqid -> + let dl = List.map (fun sl -> <:str_item< open $sl$ >>) x1 in + str_declare loc dl + | LIDENT "use"; s = STRING -> + <:str_item< #use $str:s$ >> + | x1 = fixity; list = LIST1 idd -> + match x1 with + [ ("infixr", Some n) -> + do { + List.iter + (fun s -> + EXTEND + expr: LEVEL $n$ + [ [ x1 = expr; $s$; x2 = expr -> + <:expr< $lid:s$ ($x1$, $x2$) >> ] ] + ; + END) + list; + str_declare loc [] + } + | ("infix", None) -> + do { + List.iter + (fun s -> + EXTEND + expr: LEVEL "4" + [ [ x1 = expr; $s$; x2 = expr -> + <:expr< $lid:s$ ($x1$, $x2$) >> ] ] + ; + clause: + [ [ x1 = patt LEVEL "apat"; $s$; + x2 = patt LEVEL "apat"; "="; x4 = expr -> + ((s, loc), [<:patt< ($x1$, $x2$) >>], + None, x4) ] ] + ; + END) + list; + str_declare loc [] + } + | _ -> not_impl loc "ldec 14" ] + | "overload"; x1 = ident; ":"; x2 = ctyp; "as"; x3 = exp_pa -> + not_impl loc "ldec 15" + | x = expr -> <:str_item< $exp:x$ >> ] ] + ; + sdec: + [ [ x = str_item -> x ] ] + ; + strb: + [ [ x1 = ident; x2 = sigconstraint_op; "="; x3 = module_expr -> + let x3 = + match x2 with + [ Some x2 -> <:module_expr< ($x3$ : $x2$) >> + | None -> x3 ] + in + <:str_item< module $x1$ = $x3$ >> ] ] + ; + fparam: + [ [ x1 = idd; ":"; x2 = module_type -> [<:sig_item< module $x1$ : $x2$ >>] + | x1 = spec_s -> x1 ] ] + ; + fparamList: + [ [ "("; x1 = fparam; ")" -> [x1] + | "("; x1 = fparam; ")"; x2 = fparamList -> [x1 :: x2] ] ] + ; + fctb: + [ [ x1 = ident; x2 = fparamList; x3 = sigconstraint_op; "="; + x4 = module_expr -> + let list = List.flatten x2 in + let x4 = + if list = [] then x4 + else + match x4 with + [ <:module_expr< struct $list:list$ end >> -> + let si = + let loc = (Token.nowhere, Token.nowhere) in + <:str_item< open AAA >> in + <:module_expr< struct $list:[si :: list]$ end >> + | _ -> not_impl loc "fctb 1" ] + in + let x4 = + match x3 with + [ Some x3 -> <:module_expr< ($x4$ : $x3$) >> + | None -> x4 ] + in + let x4 = + if list = [] then x4 + else + let mt = + let loc = + (fst (MLast.loc_of_sig_item (List.hd list)), + snd (MLast.loc_of_sig_item (List.hd (List.rev list)))) + in + <:module_type< sig $list:list$ end >> + in + <:module_expr< functor (AAA : $mt$) -> $x4$ >> + in + <:str_item< module $x1$ = $x4$ >> + | x1 = ident; x2 = fsigconstraint_op; "="; x3 = fct_exp -> + not_impl loc "fctb 2" ] ] + ; + interdec: + [ [ x = LIST1 [ s = str_item; OPT ";" -> (s, loc) ] -> (x, False) + | x = expr; OPT ";" -> not_impl loc "interdec 2" ] ] + ; +END; + +Pcaml.add_option "-records" (Arg.Set ocaml_records) + "Convert record into OCaml records, instead of objects"; diff --git a/ocaml-binary-annot/camlp4/unmaintained/sml/smllib.sml b/ocaml-binary-annot/camlp4/unmaintained/sml/smllib.sml new file mode 100644 index 0000000000..5ecd093788 --- /dev/null +++ b/ocaml-binary-annot/camlp4/unmaintained/sml/smllib.sml @@ -0,0 +1,395 @@ +(***********************************************************************) +(* *) +(* Camlp4 *) +(* *) +(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 2002 Institut National de Recherche en Informatique et *) +(* Automatique. Distributed only by permission. *) +(* *) +(***********************************************************************) + + + +datatype 'a option = SOME of 'a | NONE +exception Fail of string +exception Domain +exception Subscript +type 'a vector = 'a array + +structure OCaml = + struct + structure List = List + structure String = String + end + +structure Time = + struct + datatype time = TIME of { sec : int, usec : int } + fun toString _ = failwith "not implemented Time.toString" + fun now _ = failwith "not implemented Time.now" + end + +datatype cpu_timer = + CPUT of { gc : Time.time, sys : Time.time, usr : Time.time } + +datatype real_timer = + RealT of Time.time + +structure Char = + struct + val ord = Char.code + end + +structure General = + struct + datatype order = LESS | EQUAL | GREATER + end +type order = General.order == LESS | EQUAL | GREATER + +structure OS = + struct + exception SysErr + structure Path = + struct + fun dir s = + let val r = Filename.dirname s in + if r = "." then "" else r + end + val file = Filename.basename + fun ext s = + let fun loop i = + if i < 0 then NONE + else if String.get s i = #"." then + let val len = String.length s - i - 1 in + if len = 0 then NONE else SOME (String.sub s (i + 1) len) + end + else loop (i - 1) + in + loop (String.length s - 1) + end + fun splitDirFile s = + {dir = Filename.dirname s, + file = Filename.basename s} + fun joinDirFile x = + let val {dir,file} = x in Filename.concat dir file end + end + structure FileSys = + struct + datatype access_mode = A_READ | A_WRITE | A_EXEC + val chDir = Sys.chdir + fun isDir s = + (Unix.stat s) ocaml_record_access Unix.st_kind = Unix.S_DIR + handle Unix.Unix_error _ => raise SysErr + fun access (s, accs) = + let val st = Unix.stat s + val prm = st ocaml_record_access Unix.st_perm + val prm = + if st ocaml_record_access Unix.st_uid = Unix.getuid () then + lsr prm 6 + else if st ocaml_record_access Unix.st_uid = Unix.getgid () + then + lsr prm 3 + else prm + val rf = + if List.mem A_READ accs then land prm 4 <> 0 else true + val wf = + if List.mem A_WRITE accs then land prm 2 <> 0 else true + val xf = + if List.mem A_EXEC accs then land prm 1 <> 0 else true + in + rf andalso wf andalso xf + end + handle Unix.Unix_error (_, f, _) => + if f = "stat" then false else raise SysErr + end + structure Process = + struct + fun system s = (flush stdout; flush stderr; Sys.command s) + fun getEnv s = SOME (Sys.getenv s) handle Not_found => NONE + val success = 0 + end + end + +exception SysErr = OS.SysErr + +structure IO = + struct + exception Io of {cause:exn, function:string, name:string} + end + +structure TextIO = + struct + type instream = in_channel * char option option ref + type outstream = out_channel + type elem = char + type vector = string + fun openIn fname = + (open_in fname, ref NONE) handle exn => + raise IO.Io {cause = exn, function = "openIn", name = fname} + val openOut = open_out + fun closeIn (ic, ahc) = (ahc := SOME NONE; close_in ic) + val closeOut = close_out + val stdIn = (stdin, ref (NONE : char option option)) + fun endOfStream (ic, _) = pos_in ic = in_channel_length ic + fun inputLine (ic, ahc) = + case !ahc of + NONE => + (input_line ic ^ "\n" handle End_of_file => (ahc := SOME NONE; "")) + | SOME NONE => "" + | SOME (SOME c) => + (ahc := NONE; + if c = #"\n" then "\n" + else + String.make 1 c ^ input_line ic ^ "\n" handle + End_of_file => (ahc := SOME NONE; "")) + fun input1 (ic, ahc) = + case !ahc of + NONE => + (SOME (input_char ic) handle End_of_file => (ahc := SOME NONE; NONE)) + | SOME NONE => NONE + | SOME x => (ahc := NONE; x) + fun inputN (ins, n) = + let fun loop n = + if n <= 0 then "" + else + case input1 ins of + SOME c => String.make 1 c ^ loop (n - 1) + | NONE => "" + in + loop n + end + fun output (oc, v) = output_string oc v + fun inputAll ic = failwith "not implemented TextIO.inputAll" + fun lookahead (ic, ahc) = + case !ahc of + NONE => let val r = SOME (input_char ic) in ahc := SOME r; r end + | SOME x => x + fun print s = (print_string s; flush stdout) + end + +structure Timer = + struct + fun startRealTimer () = failwith "not implemented Timer.startRealTimer" + fun startCPUTimer () = failwith "not implemented Timer.startCPUTimer" + fun checkRealTimer _ = failwith "not implemented Timer.checkRealTimer" + fun checkCPUTimer _ = failwith "not implemented Timer.checkCPUTimer" + end + +structure Date = + struct + datatype month = + Jan | Feb | Mar | Apr | May | Jun | Jul | Sep | Oct | Nov | Dec + datatype wday = Sun | Mon | Tue | Wed | Thu | Fri | Sat + datatype date = + DATE of + {day : int, hour : int, isDst : bool option, minute : int, + month : month, offset : int option, second : int, wday : wday, + yday : int, year : int} + fun fmt _ _ = failwith "not implemented Date.fmt" + fun fromTimeLocal _ = failwith "not implemented Date.fromTimeLocal" + end + +structure Posix = + struct + structure ProcEnv = + struct + fun getenv s = SOME (Sys.getenv s) handle Not_found => NONE + end + end + +structure SMLofNJ = + struct + fun exportML s = failwith ("not implemented exportML " ^ s) + end + +fun null x = x = [] +fun explode s = + let fun loop i = + if i = String.length s then [] + else String.get s i :: loop (i + 1) + in + loop 0 + end + +val app = List.iter +fun implode [] = "" + | implode (c :: l) = String.make 1 c ^ implode l + +fun ooo f g x = f (g x) + +structure Array = + struct + fun array (len, v) = Array.create len v + fun sub _ = failwith "not implemented Array.sub" + fun update _ = failwith "not implemented Array.update" + (* for make the profiler work *) + val set = Array.set + val get = Array.get + end + +structure Vector = + struct + fun tabulate _ = failwith "not implemented Vector.tabulate" + fun sub _ = failwith "not implemented Vector.sub" + end + +structure Bool = + struct + val toString = string_of_bool + end + +structure String = + struct + val size = String.length + fun substring (s, beg, len) = + String.sub s beg len handle Invalid_argument _ => raise Subscript + val concat = String.concat "" + fun sub (s, i) = String.get s i + val str = String.make 1 + fun compare (s1, s2) = + if s1 < s2 then LESS + else if s1 > s2 then GREATER + else EQUAL + fun isPrefix s1 s2 = + let fun loop i1 i2 = + if i1 >= String.length s1 then true + else if i2 >= String.length s2 then false + else if String.get s1 i1 = String.get s2 i2 then loop (i1 + 1) (i2 + 1) + else false + in + loop 0 0 + end + fun tokens p s = + let fun loop tok i = + if i >= String.length s then + if tok = "" then [] else [tok] + else if p (String.get s i) then + if tok <> "" then tok :: loop "" (i + 1) + else loop "" (i + 1) + else loop (tok ^ String.make 1 (String.get s i)) (i + 1) + in + loop "" 0 + end + fun extract _ = failwith "not implemented String.extract" + end + +structure Substring = + struct + type substring = string * int * int + fun string (s : substring) = String.substring s + fun all s : substring = (s, 0, String.size s) + fun splitl f ((s, beg, len) : substring) : substring * substring = + let fun loop di = + if di = len then ((s, beg, len), (s, 0, 0)) + else if f (String.sub (s, beg + di)) then loop (di + 1) + else ((s, beg, di), (s, beg + di, len - di)) + in + loop 0 + end + fun getc (s, i, len) = + if len > 0 andalso i < String.size s then + SOME (String.sub (s, i), (s, i+1, len-1)) + else NONE + fun slice _ = failwith "not implemented: Substring.slice" + fun isEmpty (s, beg, len) = len = 0 + fun concat sl = String.concat (List.map string sl) + end +type substring = Substring.substring + +structure StringCvt = + struct + datatype radix = BIN | OCT | DEC | HEX + type ('a, 'b) reader = 'b -> ('a * 'b) option + end + +structure ListPair = + struct + fun zip (a1::l1, a2::l2) = (a1, a2) :: zip (l1, l2) + | zip _ = [] + val unzip = List.split + fun all f (x1 :: l1, x2 :: l2) = f (x1, x2) andalso all f (l1, l2) + | all _ _ = true + fun map f (a1::l1, a2::l2) = + let val r = f (a1, a2) in r :: map f (l1, l2) end + | map _ _ = [] + end + +structure ListMergeSort = + struct + fun uniqueSort cmp l = + List.sort + (fn x => fn y => + case cmp (x, y) of + LESS => ~1 + | EQUAL => 0 + | GREATER => 1) + l + end + +structure List = + struct + exception Empty + fun hd [] = raise Empty + | hd (x :: l) = x + fun tl [] = raise Empty + | tl (x :: l) = l + fun foldr f a l = + let fun loop a [] = a + | loop a (x :: l) = loop (f (x, a)) l + in + loop a (List.rev l) + end + fun foldl f a l = List.fold_left (fn a => fn x => f (x, a)) a l + val concat = List.flatten + val exists = List.exists + val filter = List.filter + val length = List.length + val map = List.map + val rev = List.rev + val all = List.for_all + fun find f [] = NONE + | find f (x :: l) = if f x then SOME x else find f l + fun last s = + case List.rev s of + [] => raise Empty + | x :: _ => x + fun take _ = failwith "not implemented: List.take" + fun partition _ = failwith "not implemented: List.partition" + fun mapPartial f [] = [] + | mapPartial f (x :: l) = + case f x of + NONE => mapPartial f l + | SOME y => y :: mapPartial f l + fun op @ l1 l2 = List.rev_append (List.rev l1) l2 + end + +structure Int = + struct + type int1 = int + type int = int1 + val toString = string_of_int + fun fromString s = SOME (int_of_string s) handle Failure _ => NONE + fun min (x, y) = if x < y then x else y + fun max (x, y) = if x > y then x else y + fun scan radix getc src = failwith "not impl: Int.scan" + end + +val foldr = List.foldr +val exists = List.exists +val size = String.size +val substring = String.substring +val concat = String.concat +val length = List.length +val op @ = List.op @ +val hd = List.hd +val tl = List.tl +val map = List.map +val rev = List.rev +val use_hook = ref (fn (s : string) => (failwith "no defined directive use" : unit)) +fun use s = !use_hook s +fun isSome (SOME _) = true + | isSome NONE = false +fun valOf (SOME x) = x + | valOf NONE = failwith "valOf" +val print = TextIO.print |