diff options
95 files changed, 9501 insertions, 737 deletions
diff --git a/camlp4/unmaintained/format/.depend b/camlp4/unmaintained/format/.depend new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/camlp4/unmaintained/format/.depend diff --git a/camlp4/unmaintained/format/Makefile b/camlp4/unmaintained/format/Makefile new file mode 100644 index 000000000..c38872097 --- /dev/null +++ b/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/camlp4/unmaintained/format/README b/camlp4/unmaintained/format/README new file mode 100644 index 000000000..809d42f2a --- /dev/null +++ b/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/camlp4/unmaintained/format/pa_format.ml b/camlp4/unmaintained/format/pa_format.ml new file mode 100644 index 000000000..22ecc2b78 --- /dev/null +++ b/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. *) +(* *) +(***********************************************************************) +(* $Id$ *) + +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/camlp4/unmaintained/lefteval/.depend b/camlp4/unmaintained/lefteval/.depend new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/camlp4/unmaintained/lefteval/.depend diff --git a/camlp4/unmaintained/lefteval/Makefile b/camlp4/unmaintained/lefteval/Makefile new file mode 100644 index 000000000..7e5cdd02e --- /dev/null +++ b/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/camlp4/unmaintained/lefteval/README b/camlp4/unmaintained/lefteval/README new file mode 100644 index 000000000..809d42f2a --- /dev/null +++ b/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/camlp4/unmaintained/lefteval/pa_lefteval.ml b/camlp4/unmaintained/lefteval/pa_lefteval.ml new file mode 100644 index 000000000..89a179f6e --- /dev/null +++ b/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. *) +(* *) +(***********************************************************************) +(* $Id$ *) + +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/camlp4/unmaintained/ocamllex/Makefile b/camlp4/unmaintained/ocamllex/Makefile new file mode 100644 index 000000000..b232023e5 --- /dev/null +++ b/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/camlp4/unmaintained/ocamllex/README b/camlp4/unmaintained/ocamllex/README new file mode 100644 index 000000000..809d42f2a --- /dev/null +++ b/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/camlp4/unmaintained/ocamllex/pa_ocamllex.ml b/camlp4/unmaintained/ocamllex/pa_ocamllex.ml new file mode 100644 index 000000000..94d553646 --- /dev/null +++ b/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. *) +(* *) +(***********************************************************************) +(* $Id$ *) + +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/camlp4/unmaintained/olabl/.depend b/camlp4/unmaintained/olabl/.depend new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/camlp4/unmaintained/olabl/.depend diff --git a/camlp4/unmaintained/olabl/Makefile b/camlp4/unmaintained/olabl/Makefile new file mode 100644 index 000000000..f928d4589 --- /dev/null +++ b/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/camlp4/unmaintained/olabl/README b/camlp4/unmaintained/olabl/README new file mode 100644 index 000000000..809d42f2a --- /dev/null +++ b/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/camlp4/unmaintained/olabl/pa_olabl.ml b/camlp4/unmaintained/olabl/pa_olabl.ml new file mode 100644 index 000000000..aba8bab4b --- /dev/null +++ b/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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +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 -> MLast.loc = "%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 MLast.loc and MLast.patt and option MLast.expr + | SpNtr of MLast.loc and MLast.patt and MLast.expr + | SpStr of MLast.loc and MLast.patt ] +; +type sexp_comp = + [ SeTrm of MLast.loc and MLast.expr | SeNtr of MLast.loc 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/camlp4/unmaintained/scheme/.depend b/camlp4/unmaintained/scheme/.depend new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/camlp4/unmaintained/scheme/.depend diff --git a/camlp4/unmaintained/scheme/Makefile b/camlp4/unmaintained/scheme/Makefile new file mode 100644 index 000000000..a26ed8b14 --- /dev/null +++ b/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; } ' $<`" -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/camlp4/unmaintained/scheme/README b/camlp4/unmaintained/scheme/README new file mode 100644 index 000000000..809d42f2a --- /dev/null +++ b/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/camlp4/unmaintained/scheme/pa_scheme.ml b/camlp4/unmaintained/scheme/pa_scheme.ml new file mode 100644 index 000000000..45b97e3c4 --- /dev/null +++ b/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) :] ep -> + 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 MLast.loc and sexpr and sexpr + | Schar of MLast.loc and string + | Sexpr of MLast.loc and list sexpr + | Sint of MLast.loc and string + | Sfloat of MLast.loc and string + | Slid of MLast.loc and string + | Slist of MLast.loc and list sexpr + | Sqid of MLast.loc and string + | Squot of MLast.loc and string and string + | Srec of MLast.loc and list sexpr + | Sstring of MLast.loc and string + | Stid of MLast.loc and string + | Suid of MLast.loc 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/camlp4/unmaintained/scheme/pa_scheme.sc b/camlp4/unmaintained/scheme/pa_scheme.sc new file mode 100644 index 000000000..be458594a --- /dev/null +++ b/camlp4/unmaintained/scheme/pa_scheme.sc @@ -0,0 +1,1030 @@ +; 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. +; +; ********************************************************************** +; $Id$ + +(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/camlp4/unmaintained/scheme/pr_scheme.ml b/camlp4/unmaintained/scheme/pr_scheme.ml new file mode 100644 index 000000000..149b6c7cf --- /dev/null +++ b/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. *) +(* *) +(***********************************************************************) +(* $Id$ *) + +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, []) as x -> + 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/camlp4/unmaintained/scheme/pr_schp_main.ml b/camlp4/unmaintained/scheme/pr_schp_main.ml new file mode 100644 index 000000000..52001a71b --- /dev/null +++ b/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. *) +(* *) +(***********************************************************************) +(* $Id$ *) + +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/camlp4/unmaintained/sml/.depend b/camlp4/unmaintained/sml/.depend new file mode 100644 index 000000000..e69de29bb --- /dev/null +++ b/camlp4/unmaintained/sml/.depend diff --git a/camlp4/unmaintained/sml/Makefile b/camlp4/unmaintained/sml/Makefile new file mode 100644 index 000000000..ea3980bef --- /dev/null +++ b/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/camlp4/unmaintained/sml/README b/camlp4/unmaintained/sml/README new file mode 100644 index 000000000..809d42f2a --- /dev/null +++ b/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/camlp4/unmaintained/sml/pa_sml.ml b/camlp4/unmaintained/sml/pa_sml.ml new file mode 100644 index 000000000..eb20019d3 --- /dev/null +++ b/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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +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/camlp4/unmaintained/sml/smllib.sml b/camlp4/unmaintained/sml/smllib.sml new file mode 100644 index 000000000..d0a8468f5 --- /dev/null +++ b/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. *) +(* *) +(***********************************************************************) + +(* $Id$ *) + +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 diff --git a/debugger/.depend b/debugger/.depend index 33eae2f14..930900400 100644 --- a/debugger/.depend +++ b/debugger/.depend @@ -10,8 +10,8 @@ frames.cmi: ../bytecomp/instruct.cmi primitives.cmi input_handling.cmi: primitives.cmi lexer.cmi: parser.cmi loadprinter.cmi: ../otherlibs/dynlink/dynlink.cmi ../parsing/longident.cmi -parser_aux.cmi: ../parsing/longident.cmi primitives.cmi parser.cmi: ../parsing/longident.cmi parser_aux.cmi +parser_aux.cmi: ../parsing/longident.cmi primitives.cmi pattern_matching.cmi: debugcom.cmi parser_aux.cmi ../typing/typedtree.cmi pos.cmi: ../bytecomp/instruct.cmi primitives.cmi: ../otherlibs/unix/unix.cmi diff --git a/lex/.depend b/lex/.depend index b21bfd936..f90d6dc6e 100644 --- a/lex/.depend +++ b/lex/.depend @@ -16,9 +16,9 @@ lexer.cmo: parser.cmi syntax.cmi lexer.cmi lexer.cmx: parser.cmx syntax.cmx lexer.cmi lexgen.cmo: cset.cmi syntax.cmi table.cmi lexgen.cmi lexgen.cmx: cset.cmx syntax.cmx table.cmx lexgen.cmi -main.cmo: common.cmi compact.cmi lexer.cmi lexgen.cmi output.cmi \ +main.cmo: common.cmi compact.cmi cset.cmi lexer.cmi lexgen.cmi output.cmi \ outputbis.cmi parser.cmi syntax.cmi -main.cmx: common.cmx compact.cmx lexer.cmx lexgen.cmx output.cmx \ +main.cmx: common.cmx compact.cmx cset.cmx lexer.cmx lexgen.cmx output.cmx \ outputbis.cmx parser.cmx syntax.cmx output.cmo: common.cmi compact.cmi lexgen.cmi syntax.cmi output.cmi output.cmx: common.cmx compact.cmx lexgen.cmx syntax.cmx output.cmi diff --git a/man/ocamlc.m b/man/ocamlc.m index 2f25d54e4..bc133e76f 100644 --- a/man/ocamlc.m +++ b/man/ocamlc.m @@ -44,7 +44,8 @@ These executable files are then run by the bytecode interpreter The .BR ocamlc (1) command has a command-line interface similar to the one of -most C compilers. It accepts several types of arguments: +most C compilers. It accepts several types of arguments and processes them +sequentially: Arguments ending in .mli are taken to be source files for compilation unit interfaces. Interfaces specify the names exported by @@ -118,7 +119,7 @@ flag is set (see the description of .B \-custom below). -Arguments ending in .o or.a are assumed to be C object files and +Arguments ending in .o or .a are assumed to be C object files and libraries. They are passed to the C linker when linking in .B \-custom mode (see the description of diff --git a/man/ocamldoc.m b/man/ocamldoc.m index 26000f37d..fbffa7496 100644 --- a/man/ocamldoc.m +++ b/man/ocamldoc.m @@ -301,6 +301,13 @@ Use as the title for the generated documentation. .TP +.BI \-intro \ file +Use content of +.I file +as ocamldoc text to use as introduction (HTML, \LaTeX and TeXinfo only). +For HTML, the file is used to create the whole "index.html" file. + +.TP .B \-v Verbose mode. Display progress information. @@ -490,7 +497,7 @@ option: .TP .B \-man-mini -Generate man pages only for modules, module types, clases and class types, +Generate man pages only for modules, module types, classes and class types, instead of pages for all elements. .TP diff --git a/man/ocamlopt.m b/man/ocamlopt.m index 6ef10f811..da7c59974 100644 --- a/man/ocamlopt.m +++ b/man/ocamlopt.m @@ -44,7 +44,8 @@ The command has a command-line interface very close to that of .BR ocamlc (1). -It accepts the same types of arguments: +It accepts the same types of arguments and processes them +sequentially: Arguments ending in .mli are taken to be source files for compilation unit interfaces. Interfaces specify the names exported by diff --git a/man/ocamlprof.m b/man/ocamlprof.m index 0e1a68092..abc5301dd 100644 --- a/man/ocamlprof.m +++ b/man/ocamlprof.m @@ -41,7 +41,7 @@ The default is the file ocamlprof.dump in the current directory. Specifies an additional string to be output with profiling information. By default, .B ocamlprof -will annotate progams with comments of the form +will annotate programs with comments of the form .BI (* \ n \ *) where .I n diff --git a/ocamldoc/.depend b/ocamldoc/.depend index 46b98481e..d8c49f427 100644 --- a/ocamldoc/.depend +++ b/ocamldoc/.depend @@ -1,3 +1,11 @@ +odoc.cmo: ../utils/clflags.cmo ../utils/config.cmi ../utils/misc.cmi \ + odoc_analyse.cmi odoc_args.cmi odoc_config.cmi odoc_dot.cmo \ + odoc_global.cmi odoc_html.cmo odoc_info.cmi odoc_latex.cmo odoc_man.cmo \ + odoc_messages.cmo odoc_texi.cmo ../typing/typedtree.cmi +odoc.cmx: ../utils/clflags.cmx ../utils/config.cmx ../utils/misc.cmx \ + odoc_analyse.cmx odoc_args.cmx odoc_config.cmx odoc_dot.cmx \ + odoc_global.cmx odoc_html.cmx odoc_info.cmx odoc_latex.cmx odoc_man.cmx \ + odoc_messages.cmx odoc_texi.cmx ../typing/typedtree.cmx odoc_analyse.cmo: ../utils/ccomp.cmi ../utils/clflags.cmo ../utils/config.cmi \ ../typing/ctype.cmi ../typing/env.cmi ../typing/includemod.cmi \ ../parsing/lexer.cmi ../parsing/location.cmi ../utils/misc.cmi \ @@ -44,14 +52,14 @@ odoc_class.cmo: odoc_name.cmi odoc_parameter.cmo odoc_types.cmi \ odoc_value.cmo ../typing/types.cmi odoc_class.cmx: odoc_name.cmx odoc_parameter.cmx odoc_types.cmx \ odoc_value.cmx ../typing/types.cmx -odoc_comments_global.cmo: odoc_comments_global.cmi -odoc_comments_global.cmx: odoc_comments_global.cmi odoc_comments.cmo: odoc_comments_global.cmi odoc_global.cmi odoc_lexer.cmo \ odoc_messages.cmo odoc_parser.cmi odoc_see_lexer.cmo odoc_text.cmi \ odoc_types.cmi odoc_comments.cmi odoc_comments.cmx: odoc_comments_global.cmx odoc_global.cmx odoc_lexer.cmx \ odoc_messages.cmx odoc_parser.cmx odoc_see_lexer.cmx odoc_text.cmx \ odoc_types.cmx odoc_comments.cmi +odoc_comments_global.cmo: odoc_comments_global.cmi +odoc_comments_global.cmx: odoc_comments_global.cmi odoc_config.cmo: ../utils/config.cmi odoc_config.cmi odoc_config.cmx: ../utils/config.cmx odoc_config.cmi odoc_cross.cmo: odoc_class.cmo odoc_exception.cmo odoc_messages.cmo \ @@ -122,14 +130,6 @@ odoc_misc.cmo: ../typing/btype.cmi ../typing/ctype.cmi ../typing/ident.cmi \ odoc_misc.cmx: ../typing/btype.cmx ../typing/ctype.cmx ../typing/ident.cmx \ ../parsing/longident.cmx odoc_messages.cmx odoc_types.cmx \ ../typing/path.cmx ../typing/types.cmx odoc_misc.cmi -odoc.cmo: ../utils/clflags.cmo ../utils/config.cmi ../utils/misc.cmi \ - odoc_analyse.cmi odoc_args.cmi odoc_config.cmi odoc_dot.cmo \ - odoc_global.cmi odoc_html.cmo odoc_info.cmi odoc_latex.cmo odoc_man.cmo \ - odoc_messages.cmo odoc_texi.cmo ../typing/typedtree.cmi -odoc.cmx: ../utils/clflags.cmx ../utils/config.cmx ../utils/misc.cmx \ - odoc_analyse.cmx odoc_args.cmx odoc_config.cmx odoc_dot.cmx \ - odoc_global.cmx odoc_html.cmx odoc_info.cmx odoc_latex.cmx odoc_man.cmx \ - odoc_messages.cmx odoc_texi.cmx ../typing/typedtree.cmx odoc_module.cmo: odoc_class.cmo odoc_exception.cmo odoc_name.cmi \ odoc_type.cmo odoc_types.cmi odoc_value.cmo ../typing/types.cmi odoc_module.cmx: odoc_class.cmx odoc_exception.cmx odoc_name.cmx \ @@ -188,14 +188,14 @@ odoc_test.cmo: odoc_info.cmi odoc_test.cmx: odoc_info.cmx odoc_texi.cmo: odoc_info.cmi odoc_messages.cmo odoc_to_text.cmo odoc_texi.cmx: odoc_info.cmx odoc_messages.cmx odoc_to_text.cmx -odoc_text_lexer.cmo: odoc_text_parser.cmi -odoc_text_lexer.cmx: odoc_text_parser.cmx odoc_text.cmo: odoc_text_lexer.cmo odoc_text_parser.cmi odoc_types.cmi \ odoc_text.cmi odoc_text.cmx: odoc_text_lexer.cmx odoc_text_parser.cmx odoc_types.cmx \ odoc_text.cmi -odoc_text_parser.cmo: odoc_types.cmi odoc_text_parser.cmi -odoc_text_parser.cmx: odoc_types.cmx odoc_text_parser.cmi +odoc_text_lexer.cmo: odoc_text_parser.cmi +odoc_text_lexer.cmx: odoc_text_parser.cmx +odoc_text_parser.cmo: odoc_misc.cmi odoc_types.cmi odoc_text_parser.cmi +odoc_text_parser.cmx: odoc_misc.cmx odoc_types.cmx odoc_text_parser.cmi odoc_to_text.cmo: odoc_info.cmi odoc_messages.cmo odoc_to_text.cmx: odoc_info.cmx odoc_messages.cmx odoc_type.cmo: odoc_name.cmi odoc_types.cmi ../typing/types.cmi diff --git a/ocamldoc/Changes.txt b/ocamldoc/Changes.txt index 1f9a41d05..e4b6bfe5b 100644 --- a/ocamldoc/Changes.txt +++ b/ocamldoc/Changes.txt @@ -1,65 +1,71 @@ -Current : -OK - latex: style latex pour indenter dans les module kind et les class kind -OK - latex: il manque la génération des paramètres de classe -OK - parse des {!modules: } et {!indexlist} -OK - gestion des Module_list et Index_list -OK - no need to Dynlink.add_available_units any more -OK - generate html from module_kind rather than from module_type -OK + same for classes and class types -OK - add the kind to module parameters (the way the parameter was build in the parsetree) -OK - fix: the generated ocamldoc.sty is more robust for paragraphs in +TODO: + - need to fix display of type parameters for inherited classes/class types + - latex: types variant polymorphes dépassent de la page quand ils sont trop longs + - utilisation nouvelles infos de Xavier: "début de rec", etc. + +===== +Release 3.08: + - fix: method parameters names in signature are now retrieved correctly + (fix of Odoc_value.parameter_list_from_arrows to handle Tpoly for methods) + - ajout à la doc de Module_list et Index_list (utilisé dans le html seulement) + - ajout à la doc: fichier de l'option -intro utilisé pour l'index en html + - fix: create a Module_with instead of a Module_alias when we encounter + module A : Foo in a signature + - latex: style latex pour indenter dans les module kind et les class kind + - latex: il manque la génération des paramètres de classe + - parse des {!modules: } et {!indexlist} + - gestion des Module_list et Index_list + - no need to Dynlink.add_available_units any more + - generate html from module_kind rather than from module_type + + same for classes and class types + - add the kind to module parameters (the way the parameter was build in the parsetree) + - fix: the generated ocamldoc.sty is more robust for paragraphs in ocamldocdescription environment -OK - fix: when generating separated files in latex, generate them in + - fix: when generating separated files in latex, generate them in the same directory than the main file, (the one specified by -o) -OK - mod: one section per to module in latex output + improve latex output -OK - mod: odoc_latex: use buffers instead of string concatenation -OK - add: new ocamldoc man page, thanks to Samuel Mimram -OK - fix: useless parenthesis around agruments of arguments of a type constructor in + - mod: one section per to module in latex output + improve latex output + - mod: odoc_latex: use buffers instead of string concatenation + - add: new ocamldoc man page, thanks to Samuel Mimram + - fix: useless parenthesis around agruments of arguments of a type constructor in type definitions, and aournd arguments of exceptions in exception definitions. -OK - fix: blank lines in verbatim, latex, code pre, code and ele ref modes + - fix: blank lines in verbatim, latex, code pre, code and ele ref modes are now accepted -OK - fix: html generator: included module names were displayed with their simple + - fix: html generator: included module names were displayed with their simple name rather than their fully qualified name -OK - fix: use a formatter from a buffer rather Format.str_formatter in + - fix: use a formatter from a buffer rather Format.str_formatter in Odoc_mist.sting_of_module_type, to avoid too much blanks -OK - new module odoc_print, will work when Format.pp_print_flush is fixed -OK - odoc_html: use buffers instead of string concatenation -OK - odoc_man: use buffers instead of string concatenation -OK - odoc_cross.ml: use hash tables modified on the fly to resolve + - new module odoc_print, will work when Format.pp_print_flush is fixed + - odoc_html: use buffers instead of string concatenation + - odoc_man: use buffers instead of string concatenation + - odoc_cross.ml: use hash tables modified on the fly to resolve (module | module type | exception) name aliases -OK - odoc_html: replace some calls to Str. by specific functions on strings -OK - odoc_cross.ml: use a Map to associate a complete name to + - odoc_html: replace some calls to Str. by specific functions on strings + - odoc_cross.ml: use a Map to associate a complete name to the known elements with this name, instead of searching each time through the whole list of modules -> a gain of more than 90% in speed for cross-referencing (Odoc_cross.associate) -OK - fix: Odoc_name.cut printed a '(' instead of a '.' OK - add: new option -customdir -OK - add: new option -i (to add a path to the directory where + - fix: Odoc_name.cut printed a '(' instead of a '.' + - add: new option -customdir + - add: new option -i (to add a path to the directory where to look for custom generators) -OK - add: add odoc_config.ml{,i} -OK - add: keep_code in Odoc_info.Args interface -OK - add: m_code_intf and m_code fields for modules, fit when the + - add: add odoc_config.ml{,i} + - add: keep_code in Odoc_info.Args interface + - add: m_code_intf and m_code fields for modules, fit when the Odoc_args.keep_code option is set, and fit for all modules, not only toplevel ones -OK - fix: bug preventing to get the code in a .mli -OK - fix: missing spaces after carriage return in types (Odoc_misc.string_of_type_expr) -OK - fixes: some bugs in the text parser + - fix: bug preventing to get the code in a .mli + - fix: missing spaces after carriage return in types (Odoc_misc.string_of_type_expr) + - fixes: some bugs in the text parser ( ]} meaning end of code and somehting else instead of end of precode) -OK - add: in Odoc_info: text_of_string, text_string_of_text, info_of_string -OK - fix: better output of titles in html (use more the style) -OK - add: -intro option to use a file content as ocamldoc comment to use as -OK introduction for LaTeX document and HTML index page -OK - add: the HTML generator generates the code of the module if available -OK - add: field m_code for modules, to keep the code of top modules -OK - fix: display "include Foo" instead of "include module Foo" in Latex, Man, Texi -OK - fix: not display comments associated to include directives -OK - fix: bad display of type parameters for class and class types - -TODO: - - need to fix display of type parameters for inherited classes/class types - - latex: types variant polymorphes dépassent de la page quand ils sont trop longs - - ajout à la doc de Module_list et Index_list (utilisé dans le html seulement) - - ajout ds la doc: fichier de l'option -intro utilisé pour l'index en html - - utilisation nouvelles infos de Xavier: "début de rec", etc. + - add: in Odoc_info: text_of_string, text_string_of_text, info_of_string + - fix: better output of titles in html (use more the style) + - add: -intro option to use a file content as ocamldoc comment to use as + introduction for LaTeX document and HTML index page + - add: the HTML generator generates the code of the module if available + - add: field m_code for modules, to keep the code of top modules + - fix: display "include Foo" instead of "include module Foo" in Latex, Man, Texi + - fix: not display comments associated to include directives + - fix: bad display of type parameters for class and class types ====== diff --git a/ocamldoc/ocamldoc.hva b/ocamldoc/ocamldoc.hva index c78417f36..454cee9e7 100644 --- a/ocamldoc/ocamldoc.hva +++ b/ocamldoc/ocamldoc.hva @@ -7,4 +7,13 @@ \newcommand\textasciicircum{\^{}} \newcommand\sharp{#} - +\let\ocamldocvspace\vspace +\newenvironment{ocamldocindent}{\list{}{}\item\relax}{\endlist} +\newenvironment{ocamldocsigend} + {\noindent\quad\texttt{sig}\ocamldocindent} + {\endocamldocindent\vskip -\lastskip + \noindent\quad\texttt{end}\medskip} +\newenvironment{ocamldocobjectend} + {\noindent\quad\texttt{object}\ocamldocindent} + {\endocamldocindent\vskip -\lastskip + \noindent\quad\texttt{end}\medskip} diff --git a/ocamldoc/odoc.ml b/ocamldoc/odoc.ml index f4970bfd5..1d4df9c6a 100644 --- a/ocamldoc/odoc.ml +++ b/ocamldoc/odoc.ml @@ -38,7 +38,7 @@ let (cmo_or_cma_opt, paths) = | _ :: q -> iter (f_opt, inc) q in - iter (None, [Odoc_config.custom_generators_path]) arg_list + iter (None, []) arg_list let _ = print_DEBUG "Fin analyse des arguments pour le dynamic load" @@ -50,7 +50,7 @@ let get_real_filename name = name else ( - let paths = Filename.current_dir_name :: paths in + let paths = Filename.current_dir_name :: paths @ [Odoc_config.custom_generators_path] in try let d = List.find (fun d -> Sys.file_exists (Filename.concat d name)) diff --git a/ocamldoc/odoc_args.ml b/ocamldoc/odoc_args.ml index 518e7f69b..7b8554305 100644 --- a/ocamldoc/odoc_args.ml +++ b/ocamldoc/odoc_args.ml @@ -12,6 +12,7 @@ (* cvsid $Id$ *) (** Command-line arguments. *) + open Clflags module M = Odoc_messages @@ -37,7 +38,7 @@ let dot_types = ref false let dot_reduce = ref false -let dot_colors = ref M.default_dot_colors +let dot_colors = ref (List.flatten M.default_dot_colors) let man_suffix = ref M.default_man_suffix @@ -224,7 +225,9 @@ let options = ref [ "-t", Arg.String (fun s -> title := Some s), M.option_title ; "-intro", Arg.String (fun s -> intro_file := Some s), M.option_intro ; "-hide", Arg.String add_hidden_modules, M.hide_modules ; - "-m", Arg.String (fun s -> merge_options := !merge_options @ (analyse_merge_options s)), M.merge_options^"\n" ; + "-m", Arg.String (fun s -> merge_options := !merge_options @ (analyse_merge_options s)), + M.merge_options ^ + "\n\n *** choosing a generator ***\n"; (* generators *) "-html", Arg.Unit (fun () -> set_doc_generator !default_html_generator), M.generate_html ; @@ -237,13 +240,15 @@ let options = ref [ "-i", Arg.String (fun s -> if !bytecode_mode then () else (prerr_endline (M.option_not_in_native_code "-i"); exit 1)), M.add_load_dir ; "-g", Arg.String (fun s -> if !bytecode_mode then () else (prerr_endline (M.option_not_in_native_code "-g"); exit 1)), - M.load_file^"\n" ; + M.load_file ^ + "\n\n *** HTML options ***\n"; (* html only options *) "-all-params", Arg.Set with_parameter_list, M.with_parameter_list ; "-css-style", Arg.String (fun s -> css_style := Some s), M.css_style ; "-index-only", Arg.Set index_only, M.index_only ; - "-colorize-code", Arg.Set colorize_code, M.colorize_code^"\n" ; + "-colorize-code", Arg.Set colorize_code, M.colorize_code ^ + "\n\n *** LaTeX options ***\n"; (* latex only options *) "-noheader", Arg.Unit (fun () -> with_header := false), M.no_header ; @@ -259,19 +264,24 @@ let options = ref [ "-latex-module-type-prefix", Arg.String (fun s -> latex_module_type_prefix := s), M.latex_module_type_prefix ; "-latex-class-prefix", Arg.String (fun s -> latex_class_prefix := s), M.latex_class_prefix ; "-latex-class-type-prefix", Arg.String (fun s -> latex_class_type_prefix := s), M.latex_class_type_prefix ; - "-notoc", Arg.Unit (fun () -> with_toc := false), M.no_toc^"\n" ; + "-notoc", Arg.Unit (fun () -> with_toc := false), + M.no_toc ^ + "\n\n *** texinfo options ***\n"; (* tex only options *) "-noindex", Arg.Clear with_index, M.no_index ; "-esc8", Arg.Set esc_8bits, M.esc_8bits ; "-info-section", Arg.String ((:=) info_section), M.info_section ; - "-info-entry", Arg.String (fun s -> info_entry := !info_entry @ [ s ]), M.info_entry ; + "-info-entry", Arg.String (fun s -> info_entry := !info_entry @ [ s ]), + M.info_entry ^ + "\n\n *** dot options ***\n"; (* dot only options *) "-dot-colors", Arg.String (fun s -> dot_colors := Str.split (Str.regexp_string ",") s), M.dot_colors ; "-dot-include-all", Arg.Set dot_include_all, M.dot_include_all ; "-dot-types", Arg.Set dot_types, M.dot_types ; - "-dot-reduce", Arg.Set dot_reduce, M.dot_reduce ; + "-dot-reduce", Arg.Set dot_reduce, M.dot_reduce^ + "\n\n *** man pages options ***\n"; (* man only options *) "-man-mini", Arg.Set man_mini, M.man_mini ; diff --git a/ocamldoc/odoc_html.ml b/ocamldoc/odoc_html.ml index cbba5228f..98fb090ee 100644 --- a/ocamldoc/odoc_html.ml +++ b/ocamldoc/odoc_html.ml @@ -2408,7 +2408,6 @@ class html = (fun acc mt -> StringSet.add mt.mt_name acc) known_modules_names module_types ; - (* generate html for each module *) if not !Args.index_only then self#generate_elements self#generate_for_module module_list ; diff --git a/ocamldoc/odoc_latex.ml b/ocamldoc/odoc_latex.ml index 757b83797..2363ea127 100644 --- a/ocamldoc/odoc_latex.ml +++ b/ocamldoc/odoc_latex.ml @@ -560,7 +560,7 @@ class latex = e :: (iter q) in (iter defs2) @ - [Latex ("\\index{"^(self#type_label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ (self#text_of_info t.ty_info) in self#latex_of_text fmt @@ -700,16 +700,18 @@ class latex = self#latex_of_text fmt [Latex "\\end{ocamldocobjectend}\n"] method latex_for_module_index fmt m = + let s_name = Name.simple m.m_name in self#latex_of_text fmt - [Latex ("\\index{"^(self#module_label m.m_name)^"@\\verb`"^ - (self#label ~no_:false m.m_name)^"`}\n" + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^ + (self#label ~no_:false s_name)^"`}\n" ) ] method latex_for_module_type_index fmt mt = + let s_name = Name.simple mt.mt_name in self#latex_of_text fmt - [Latex ("\\index{"^(self#module_type_label mt.mt_name)^"@\\verb`"^ - (self#label ~no_:false mt.mt_name)^"`}\n" + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^ + (self#label ~no_:false (Name.simple s_name))^"`}\n" ) ] @@ -721,16 +723,18 @@ class latex = method latex_for_class_index fmt c = + let s_name = Name.simple c.cl_name in self#latex_of_text fmt - [Latex ("\\index{"^(self#class_label c.cl_name)^"@\\verb`"^ - (self#label ~no_:false c.cl_name)^"`}\n" + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^ + (self#label ~no_:false s_name)^"`}\n" ) ] method latex_for_class_type_index fmt ct = + let s_name = Name.simple ct.clt_name in self#latex_of_text fmt - [Latex ("\\index{"^(self#class_type_label ct.clt_name)^"@\\verb`"^ - (self#label ~no_:false ct.clt_name)^"`}\n" + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^ + (self#label ~no_:false s_name)^"`}\n" ) ] diff --git a/ocamldoc/odoc_messages.ml b/ocamldoc/odoc_messages.ml index bac8df08f..bb5d73d42 100644 --- a/ocamldoc/odoc_messages.ml +++ b/ocamldoc/odoc_messages.ml @@ -23,7 +23,7 @@ let message_version = software^" "^config_version let usage = "Usage : "^(Sys.argv.(0))^" [options] <files>\n" let options_are = "Options are :" -let option_version = " Print version and exit" +let option_version = "\tPrint version and exit" let bytecode_only = "(bytecode version only)" let latex_only = "(LaTeX only)" let texi_only = "(TeXinfo only)" @@ -32,100 +32,130 @@ let html_only = "(HTML only)" let html_latex_only = "(HTML and LaTeX only)" let html_latex_texi_only = "(HTML, LaTeX and TeXinfo only)" let man_only = "(man only)" -let verbose_mode = " verbose mode" -let include_dirs = "<dir> Add <dir> to the list of include directories" -let rectypes = " Allow arbitrary recursive types" -let preprocess = "<command> Pipe sources through preprocessor <command>" -let display_custom_generators_dir = " Display custom generators standard directory and exit" -let add_load_dir = "<dir> Add the given directory to the search path for custom generators "^bytecode_only -let load_file = "<file.cm[o|a]> Load file defining a new documentation generator "^bytecode_only -let nolabels = " Ignore non-optional labels in types" -let werr = "Treat ocamldoc warnings as errors" -let target_dir = "<dir> Generate files in directory <dir>, rather than in current directory (for man and HTML generators)" -let dump = "<file> Dump collected information into <file>" -let load = "<file> Load information from <file> ; may be used several times" -let css_style = "<file> Use content of <file> as CSS style definition "^html_only -let index_only = " Generate index files only "^html_only -let colorize_code = "Colorize code even in documentation pages "^html_only -let generate_html = " Generate HTML documentation" -let generate_latex = " Generate LaTeX documentation" -let generate_texinfo = " Generate TeXinfo documentation" -let generate_man = " Generate man pages" -let generate_dot = " Generate dot code of top modules dependencies" +let verbose_mode = "\t\tverbose mode" +let include_dirs = "<dir>\tAdd <dir> to the list of include directories" +let rectypes = "\tAllow arbitrary recursive types" +let preprocess = "<command>\tPipe sources through preprocessor <command>" +let display_custom_generators_dir = "\tDisplay custom generators standard directory and exit" +let add_load_dir = "<dir>\tAdd the given directory to the search path for custom\n"^ + "\t\tgenerators "^bytecode_only +let load_file = "<file.cm[o|a]>\n\t\tLoad file defining a new documentation generator\n\t\t"^bytecode_only +let nolabels = "\tIgnore non-optional labels in types" +let werr = "\tTreat ocamldoc warnings as errors" +let target_dir = "<dir>\tGenerate files in directory <dir>, rather than in current\n"^ + "\t\tdirectory (for man and HTML generators)" +let dump = "<file>\tDump collected information into <file>" +let load = "<file>\tLoad information from <file> ; may be used several times" +let css_style = "<file>\n\t\tUse content of <file> as CSS style definition "^html_only +let index_only = "\tGenerate index files only "^html_only +let colorize_code = "\n\t\tColorize code even in documentation pages "^html_only +let generate_html = "\tGenerate HTML documentation" +let generate_latex = "\tGenerate LaTeX documentation" +let generate_texinfo = "\tGenerate TeXinfo documentation" +let generate_man = "\t\tGenerate man pages" +let generate_dot = "\t\tGenerate dot code of top modules dependencies" let option_not_in_native_code op = "Option "^op^" not available in native code version." let default_out_file = "ocamldoc.out" -let out_file = "<file> Set the ouput file name, used by texi, latex and dot generators "^ - "(default is "^default_out_file^")" - -let dot_include_all = " include all modules in the dot output,\n"^ - " not only the modules given on the command line" -let dot_types = " generate dependency graph for types instead of modules" -let default_dot_colors = [ "darkturquoise" ; "darkgoldenrod2" ; "cyan" ; "green" ; "magenta" ; "yellow" ; - "burlywood1" ; "aquamarine" ; "floralwhite" ; "lightpink" ; - "lightblue" ; "mediumturquoise" ; "salmon" ; "slategray3" ; - ] -let dot_colors = "<c1,c2,...,cn> use colors c1,c1,...,cn in the dot output\n"^ - " (default list is "^(String.concat "," default_dot_colors)^")" -let dot_reduce = " perform a transitive reduction on the selected dependency graph before the dot output\n" - -let man_mini = " Generate man pages only for modules, module types,\n"^ - " classes and class types "^man_only +let out_file = + "<file>\tSet the ouput file name, used by texi, latex and dot generators\n"^ + "\t\t(default is "^default_out_file^")" + +let dot_include_all = + "\n\t\tInclude all modules in the dot output, not only the\n"^ + "\t\tmodules given on the command line" +let dot_types = "\tGenerate dependency graph for types instead of modules" +let default_dot_colors = + [ [ "darkturquoise" ; "darkgoldenrod2" ; "cyan" ; "green" ; ] ; + [ "magenta" ; "yellow" ; "burlywood1" ; "aquamarine" ; "floralwhite" ; "lightpink" ] ; + [ "lightblue" ; "mediumturquoise" ; "salmon" ; "slategray3"] ; + ] + +let dot_colors = + "<c1,c2,...,cn>\n\t\tUse colors c1,c1,...,cn in the dot output\n"^ + "\t\t(default list is "^ + (String.concat ",\n\t\t" (List.map (String.concat ", ") default_dot_colors))^")" + +let dot_reduce = + "\tPerform a transitive reduction on the selected dependency graph\n"^ + "\t\tbefore the dot output" + +let man_mini = "\tGenerate man pages only for modules, module types, classes\n"^ + "\t\tand class types "^man_only let default_man_suffix = "o" -let man_suffix = "<suffix> use <suffix> for man page files "^ +let man_suffix = "<suffix>\n\t\tUse <suffix> for man page files "^ "(default is "^default_man_suffix^") "^man_only^"\n" -let option_title = "<title> use <title> as title for the generated documentation" +let option_title = "<title>\tUse <title> as title for the generated documentation" let option_intro = - "<file> use content of <file> as ocamldoc text to use as introduction "^(html_latex_texi_only) -let with_parameter_list = " display the complete list of parameters for functions and methods "^html_only -let hide_modules = " <M1,M2.M3,...> Hide the given complete module names in generated doc" -let no_header = " Suppress header in generated documentation "^latex_texi_only -let no_trailer = " Suppress trailer in generated documentation "^latex_texi_only -let separate_files = " Generate one file per toplevel module "^latex_only + "<file>\tUse content of <file> as ocamldoc text to use as introduction\n"^ + "\t\t"^(html_latex_texi_only) +let with_parameter_list = "\tDisplay the complete list of parameters for functions and\n"^ + "\t\tmethods "^html_only +let hide_modules = "<M1,M2.M3,...>\n\t\tHide the given complete module names in generated doc" +let no_header = "\tSuppress header in generated documentation\n\t\t"^latex_texi_only +let no_trailer = "\tSuppress trailer in generated documentation\n\t\t"^latex_texi_only +let separate_files = "\tGenerate one file per toplevel module "^latex_only let latex_title ref_titles = - "n,style associate {n } to the given sectionning style\n"^ - " (e.g. 'section') in the latex output "^latex_only^"\n"^ - " Default sectionning is:\n"^ - (String.concat "\n" - (List.map (fun (n,t) -> Printf.sprintf " %d -> %s" n t) !ref_titles)) + "n,style\n\t\tAssociate {n } to the given sectionning style\n"^ + "\t\t(e.g. 'section') in the latex output "^latex_only^"\n"^ + "\t\tDefault sectionning is:\n\t\t"^ + (String.concat "\n\t\t" + (List.map (fun (n,t) -> Printf.sprintf " %d -> %s" n t) !ref_titles)) let default_latex_value_prefix = "val:" -let latex_value_prefix = "<string> use <string> as prefix for the LaTeX labels of values. "^ - "(default is \""^default_latex_value_prefix^"\")" +let latex_value_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of values.\n"^ + "\t\t(default is \""^default_latex_value_prefix^"\")" + let default_latex_type_prefix = "type:" -let latex_type_prefix = "<string> use <string> as prefix for the LaTeX labels of types. "^ - "(default is \""^default_latex_type_prefix^"\")" +let latex_type_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of types.\n"^ + "\t\t(default is \""^default_latex_type_prefix^"\")" + let default_latex_exception_prefix = "exception:" -let latex_exception_prefix = "<string> use <string> as prefix for the LaTeX labels of exceptions. "^ - "(default is \""^default_latex_exception_prefix^"\")" +let latex_exception_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of exceptions.\n"^ + "\t\t(default is \""^default_latex_exception_prefix^"\")" + let default_latex_module_prefix = "module:" -let latex_module_prefix = "<string> use <string> as prefix for the LaTeX labels of modules. "^ - "(default is \""^default_latex_module_prefix^"\")" +let latex_module_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of modules.\n"^ + "\t\t(default is \""^default_latex_module_prefix^"\")" + let default_latex_module_type_prefix = "moduletype:" -let latex_module_type_prefix = "<string> use <string> as prefix for the LaTeX labels of module types. "^ - "(default is \""^default_latex_module_type_prefix^"\")" +let latex_module_type_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of module types.\n"^ + "\t\t(default is \""^default_latex_module_type_prefix^"\")" + let default_latex_class_prefix = "class:" -let latex_class_prefix = "<string> use <string> as prefix for the LaTeX labels of classes. "^ - "(default is \""^default_latex_class_prefix^"\")" +let latex_class_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of classes.\n"^ + "\t\t(default is \""^default_latex_class_prefix^"\")" + let default_latex_class_type_prefix = "classtype:" -let latex_class_type_prefix = "<string> use <string> as prefix for the LaTeX labels of class types. "^ - "(default is \""^default_latex_class_type_prefix^"\")" +let latex_class_type_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of class types.\n"^ + "\t\t(default is \""^default_latex_class_type_prefix^"\")" + let default_latex_attribute_prefix = "val:" -let latex_attribute_prefix = "<string> use <string> as prefix for the LaTeX labels of attributes. "^ - "(default is \""^default_latex_attribute_prefix^"\")" +let latex_attribute_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of attributes.\n"^ + "\t\t(default is \""^default_latex_attribute_prefix^"\")" + let default_latex_method_prefix = "method:" -let latex_method_prefix = "<string> use <string> as prefix for the LaTeX labels of methods. "^ - "(default is \""^default_latex_method_prefix^"\")" - -let no_toc = " Do not generate table of contents "^latex_only -let sort_modules = " Sort the list of top modules before generating the documentation" -let no_stop = " Do not stop at (**/**) comments" -let no_custom_tags = " Do not allow custom @-tags" -let remove_stars = " Remove beginning blanks of comment lines, until the first '*'" -let keep_code = " Always keep code when available" -let inverse_merge_ml_mli = "Inverse implementations and interfaces when merging" +let latex_method_prefix = + "<string>\n\t\tUse <string> as prefix for the LaTeX labels of methods.\n"^ + "\t\t(default is \""^default_latex_method_prefix^"\")" + +let no_toc = "\tDo not generate table of contents "^latex_only +let sort_modules = "\tSort the list of top modules before generating the documentation" +let no_stop = "\tDo not stop at (**/**) comments" +let no_custom_tags = "\n\t\tDo not allow custom @-tags" +let remove_stars = "\tRemove beginning blanks of comment lines, until the first '*'" +let keep_code = "\tAlways keep code when available" +let inverse_merge_ml_mli = "\n\t\tInverse implementations and interfaces when merging" let merge_description = ('d', "merge description") let merge_author = ('a', "merge @author") let merge_version = ('v', "merge @version") @@ -138,19 +168,19 @@ let merge_return_value = ('r', "merge @return") let merge_custom = ('c', "merge custom @-tags") let merge_all = ('A', "merge all") -let no_index = " Do not build index for Info files "^texi_only -let esc_8bits = " Escape accentuated characters in Info files "^texi_only +let no_index = "\tDo not build index for Info files "^texi_only +let esc_8bits = "\tEscape accentuated characters in Info files "^texi_only let info_section = "Specify section of Info directory "^texi_only -let info_entry = "Specify Info directory entry "^texi_only^"\n" +let info_entry = "\tSpecify Info directory entry "^texi_only -let options_can_be = " <options> can be one or more of the following characters:" +let options_can_be = "<options> can be one or more of the following characters:" let string_of_options_list l = - List.fold_left (fun acc -> fun (c, m) -> acc^"\n "^(String.make 1 c)^" "^m) + List.fold_left (fun acc -> fun (c, m) -> acc^"\n\t\t"^(String.make 1 c)^" "^m) "" l let merge_options = - "<options> specify merge options between .mli and .ml\n"^ + "<options>\tspecify merge options between .mli and .ml\n\t\t"^ options_can_be^ (string_of_options_list [ merge_description ; @@ -179,7 +209,7 @@ let bad_magic_number = "This dump was not created by this version of OCamldoc." let not_a_module_name s = s^" is not a valid module name" -let load_file_error f e = "Error while loading file "^f^":\n"^e^"\n" +let load_file_error f e = "Error while loading file "^f^":\n"^e let wrong_format s = "Wrong format for \""^s^"\"" let errors_occured n = (string_of_int n)^" error(s) encountered" let parse_error = "Parse error" @@ -191,7 +221,7 @@ let text_parse_error l c s = (String.make c ' ')^"^" let file_not_found_in_paths paths name = - Printf.sprintf "No file %s was found in the load paths: \n%s\n" + Printf.sprintf "No file %s found in the load paths: \n%s" name (String.concat "\n" paths) diff --git a/ocamldoc/odoc_module.ml b/ocamldoc/odoc_module.ml index a12545b23..f2f457299 100644 --- a/ocamldoc/odoc_module.ml +++ b/ocamldoc/odoc_module.ml @@ -205,48 +205,55 @@ let included_modules l = @param trans indicates if, for aliased modules, we must perform a transitive search.*) let rec module_elements ?(trans=true) m = let rec iter_kind = function - Module_struct l -> l - | Module_alias ma -> - if trans then - match ma.ma_module with - None -> [] - | Some (Mod m) -> module_elements m - | Some (Modtype mt) -> module_type_elements mt - else - [] - | Module_functor (_, k) - | Module_apply (k, _) -> iter_kind k - | Module_with (tk,_) -> - module_type_elements ~trans: trans - { mt_name = "" ; mt_info = None ; mt_type = None ; - mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ; - mt_loc = Odoc_types.dummy_loc ; - } - | Module_constraint (k, tk) -> + Module_struct l -> + print_DEBUG "Odoc_module.module_element: Module_struct"; + l + | Module_alias ma -> + print_DEBUG "Odoc_module.module_element: Module_alias"; + if trans then + match ma.ma_module with + None -> [] + | Some (Mod m) -> module_elements m + | Some (Modtype mt) -> module_type_elements mt + else + [] + | Module_functor (_, k) + | Module_apply (k, _) -> + print_DEBUG "Odoc_module.module_element: Module_functor ou Module_apply"; + iter_kind k + | Module_with (tk,_) -> + print_DEBUG "Odoc_module.module_element: Module_with"; + module_type_elements ~trans: trans + { mt_name = "" ; mt_info = None ; mt_type = None ; + mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ; + mt_loc = Odoc_types.dummy_loc ; + } + | Module_constraint (k, tk) -> + print_DEBUG "Odoc_module.module_element: Module_constraint"; (* A VOIR : utiliser k ou tk ? *) - module_elements ~trans: trans - { m_name = "" ; - m_info = None ; - m_type = Types.Tmty_signature [] ; - m_is_interface = false ; m_file = "" ; m_kind = k ; - m_loc = Odoc_types.dummy_loc ; - m_top_deps = [] ; - m_code = None ; - m_code_intf = None ; - } + module_elements ~trans: trans + { m_name = "" ; + m_info = None ; + m_type = Types.Tmty_signature [] ; + m_is_interface = false ; m_file = "" ; m_kind = k ; + m_loc = Odoc_types.dummy_loc ; + m_top_deps = [] ; + m_code = None ; + m_code_intf = None ; + } (* - module_type_elements ~trans: trans - { mt_name = "" ; mt_info = None ; mt_type = None ; - mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ; - mt_loc = Odoc_types.dummy_loc } + module_type_elements ~trans: trans + { mt_name = "" ; mt_info = None ; mt_type = None ; + mt_is_interface = false ; mt_file = "" ; mt_kind = Some tk ; + mt_loc = Odoc_types.dummy_loc } *) in iter_kind m.m_kind (** Returns the list of elements of a module type. - @param trans indicates if, for aliased modules, we must perform a transitive search.*) + @param trans indicates if, for aliased modules, we must perform a transitive search.*) and module_type_elements ?(trans=true) mt = - let rec iter_kind = function + let rec iter_kind = function | None -> [] | Some (Module_type_struct l) -> l | Some (Module_type_functor (_, k)) -> iter_kind (Some k) @@ -256,12 +263,12 @@ and module_type_elements ?(trans=true) mt = else [] | Some (Module_type_alias mta) -> - if trans then - match mta.mta_module with - None -> [] - | Some mt -> module_type_elements mt - else - [] + if trans then + match mta.mta_module with + None -> [] + | Some mt -> module_type_elements mt + else + [] in iter_kind mt.mt_kind diff --git a/ocamldoc/odoc_sig.ml b/ocamldoc/odoc_sig.ml index 20ee0ed69..278afad84 100644 --- a/ocamldoc/odoc_sig.ml +++ b/ocamldoc/odoc_sig.ml @@ -332,7 +332,6 @@ module Analyser = met.met_value.val_info <- merge_infos met.met_value.val_info info_after_opt ; (* update the parameter description *) Odoc_value.update_value_parameters_text met.met_value; - (met, maybe_more) in let rec f last_pos class_type_field_list = @@ -1121,15 +1120,9 @@ module Analyser = (** Analyse of a Parsetree.module_type and a Types.module_type.*) and analyse_module_kind env current_module_name module_type sig_module_type = match module_type.Parsetree.pmty_desc with - Parsetree.Pmty_ident longident (*of Longident.t*) -> - let name = - match sig_module_type with - Types.Tmty_ident path -> Name.from_path path - | _ -> - Name.from_longident longident - in - Module_alias { ma_name = Odoc_env.full_module_or_module_type_name env name ; - ma_module = None } + Parsetree.Pmty_ident longident -> + let k = analyse_module_type_kind env current_module_name module_type sig_module_type in + Module_with ( k, "" ) | Parsetree.Pmty_signature signature -> ( diff --git a/ocamldoc/odoc_texi.ml b/ocamldoc/odoc_texi.ml index 5eb18ca60..dabf769f6 100644 --- a/ocamldoc/odoc_texi.ml +++ b/ocamldoc/odoc_texi.ml @@ -372,7 +372,7 @@ class text = end - +exception Aliased_node (** This class is used to create objects which can generate a simple Texinfo documentation. *) @@ -391,7 +391,15 @@ class texi = val mutable indices_to_build = [ `Module ] + (** Keep a set of nodes we create. If we try to create one + a second time, that means it is some kind of alias, so + don't do it, just link to the previous one *) + val node_tbl = Hashtbl.create 37 + method node depth name = + if Hashtbl.mem node_tbl name + then raise Aliased_node ; + Hashtbl.add node_tbl name () ; if depth <= maxdepth then Verbatim ("@node " ^ (Texi.fix_nodename name) ^ ",\n") else nothing @@ -414,7 +422,8 @@ class texi = (function | Newline -> Raw "\n" | Raw s -> Raw (Str.global_replace re "\n" s) - | List tel | Enum tel -> List (List.map self#fix_linebreaks tel) + | List tel -> List (List.map self#fix_linebreaks tel) + | Enum tel -> Enum (List.map self#fix_linebreaks tel) | te -> te) t method private soft_fix_linebreaks = @@ -863,6 +872,7 @@ class texi = (** Generate the Texinfo code for the given class, in the given out channel. *) method generate_for_class chanout c = + try Odoc_info.reset_type_names () ; let depth = Name.depth c.cl_name in let title = [ @@ -888,11 +898,13 @@ class texi = (fun ele -> puts chanout (self#texi_of_class_element c.cl_name ele)) (Class.class_elements ~trans:false c) + with Aliased_node -> () (** Generate the Texinfo code for the given class type, in the given out channel. *) method generate_for_class_type chanout ct = + try Odoc_info.reset_type_names () ; let depth = Name.depth ct.clt_name in let title = [ @@ -918,12 +930,13 @@ class texi = (fun ele -> puts chanout (self#texi_of_class_element ct.clt_name ele)) (Class.class_type_elements ~trans:false ct) - + with Aliased_node -> () (** Generate the Texinfo code for the given module type, in the given out channel. *) method generate_for_module_type chanout mt = + try let depth = Name.depth mt.mt_name in let title = [ self#node depth mt.mt_name ; @@ -966,11 +979,12 @@ class texi = | `Class c -> self#generate_for_class chanout c | `Class_type ct -> self#generate_for_class_type chanout ct) subparts - + with Aliased_node -> () (** Generate the Texinfo code for the given module, in the given out channel. *) method generate_for_module chanout m = + try Odoc_info.verbose ("Generate for module " ^ m.m_name) ; let depth = Name.depth m.m_name in let title = [ @@ -1015,7 +1029,7 @@ class texi = | `Class c -> self#generate_for_class chanout c | `Class_type ct -> self#generate_for_class_type chanout ct ) subparts - + with Aliased_node -> () (** Writes the header of the TeXinfo document. *) @@ -1169,6 +1183,7 @@ class texi = (** Generate the Texinfo file from a module list, in the {!Odoc_info.Args.out_file} file. *) method generate module_list = + Hashtbl.clear node_tbl ; let filename = if !Args.out_file = Odoc_messages.default_out_file then "ocamldoc.texi" diff --git a/ocamldoc/odoc_to_text.ml b/ocamldoc/odoc_to_text.ml index 426432a65..057b0d89f 100644 --- a/ocamldoc/odoc_to_text.ml +++ b/ocamldoc/odoc_to_text.ml @@ -269,7 +269,7 @@ class virtual to_text = Format.flush_str_formatter () in [ CodePre s ] @ - [Latex ("\\index{"^(self#label name)^"@\\verb`"^(self#label ~no_:false name)^"`}\n")] @ + [Latex ("\\index{"^(self#label s_name)^"@\\verb`"^(self#label ~no_:false s_name)^"`}\n")] @ (self#text_of_info v.val_info) (** @return [text] value for a class attribute. *) diff --git a/ocamldoc/odoc_value.ml b/ocamldoc/odoc_value.ml index b001f1464..62cf0ccf4 100644 --- a/ocamldoc/odoc_value.ml +++ b/ocamldoc/odoc_value.ml @@ -72,7 +72,18 @@ let parameter_list_from_arrows typ = match t.Types.desc with Types.Tarrow (l, t1, t2, _) -> (l, t1) :: (iter t2) - | _ -> + | Types.Tlink texp + | Types.Tsubst texp -> + iter texp + | Types.Tpoly (texp, _) -> iter texp + | Types.Tvar + | Types.Ttuple _ + | Types.Tconstr _ + | Types.Tobject _ + | Types.Tfield _ + | Types.Tnil + | Types.Tunivar + | Types.Tvariant _ -> [] in iter typ diff --git a/otherlibs/labltk/browser/searchpos.ml b/otherlibs/labltk/browser/searchpos.ml index 5e543e83c..7567d7362 100644 --- a/otherlibs/labltk/browser/searchpos.ml +++ b/otherlibs/labltk/browser/searchpos.ml @@ -316,6 +316,8 @@ let edit_source ~file ~path ~sign = (* List of windows to destroy by Close All *) let top_widgets = ref [] +let dummy_item = Tsig_modtype (Ident.create "dummy", Tmodtype_abstract) + let rec view_signature ?title ?path ?(env = !start_env) ?(detach=false) sign = let env = match path with None -> env @@ -451,7 +453,8 @@ and view_type_decl path ~env = {desc = Tobject _} -> let clt = find_cltype path env in view_signature_item ~path ~env - [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first)] + [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first); + dummy_item; dummy_item] | _ -> raise Not_found with Not_found -> view_signature_item ~path ~env @@ -464,12 +467,14 @@ and view_type_id li ~env = and view_class_id li ~env = let path, cl = lookup_class li env in view_signature_item ~path ~env - [Tsig_class(ident_of_path path ~default:"c", cl, Trec_first)] + [Tsig_class(ident_of_path path ~default:"c", cl, Trec_first); + dummy_item; dummy_item; dummy_item] and view_cltype_id li ~env = let path, clt = lookup_cltype li env in view_signature_item ~path ~env - [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first)] + [Tsig_cltype(ident_of_path path ~default:"ct", clt, Trec_first); + dummy_item; dummy_item] and view_modtype_id li ~env = let path, td = lookup_modtype li env in diff --git a/otherlibs/labltk/camltk/Makefile.gen b/otherlibs/labltk/camltk/Makefile.gen index 1e4f50a10..d0d81230c 100644 --- a/otherlibs/labltk/camltk/Makefile.gen +++ b/otherlibs/labltk/camltk/Makefile.gen @@ -3,7 +3,7 @@ include ../support/Makefile.common all: cTk.ml camltk.ml .depend _tkgen.ml: ../Widgets.src ../compiler/tkcompiler - cd ..; ../../boot/ocamlrun compiler/tkcompiler -camltk -outdir camltk + cd ..; $(CAMLRUNGEN) compiler/tkcompiler -camltk -outdir camltk cTk.ml camltk.ml .depend: _tkgen.ml ../builtin/report.ml ../compiler/pp #../builtin/builtin_*.ml (echo '##define CAMLTK'; \ diff --git a/otherlibs/labltk/labltk/Makefile.gen b/otherlibs/labltk/labltk/Makefile.gen index a7f85082e..a93fe155b 100644 --- a/otherlibs/labltk/labltk/Makefile.gen +++ b/otherlibs/labltk/labltk/Makefile.gen @@ -3,7 +3,7 @@ include ../support/Makefile.common all: tk.ml labltk.ml .depend _tkgen.ml: ../Widgets.src ../compiler/tkcompiler - cd ..; ../../boot/ocamlrun compiler/tkcompiler -outdir labltk + cd ..; $(CAMLRUNGEN) compiler/tkcompiler -outdir labltk # dependencies are broken: wouldn't work with gmake 3.77 diff --git a/otherlibs/labltk/support/Makefile.common b/otherlibs/labltk/support/Makefile.common index 8745fee80..7e8bfadba 100644 --- a/otherlibs/labltk/support/Makefile.common +++ b/otherlibs/labltk/support/Makefile.common @@ -24,3 +24,4 @@ COMPFLAGS= LINKFLAGS= CAMLOPTLIBR=$(CAMLOPT) -a MKLIB=$(CAMLRUN) $(TOPDIR)/tools/ocamlmklib +CAMLRUNGEN=../../boot/ocamlrun diff --git a/otherlibs/systhreads/posix.c b/otherlibs/systhreads/posix.c index b65534f61..a34266dfa 100644 --- a/otherlibs/systhreads/posix.c +++ b/otherlibs/systhreads/posix.c @@ -27,6 +27,7 @@ #include <sys/time.h> #ifdef __linux__ #include <unistd.h> +#include <sys/utsname.h> #endif #include "alloc.h" #include "backtrace.h" @@ -96,12 +97,20 @@ struct caml_thread_struct { typedef struct caml_thread_struct * caml_thread_t; /* The descriptor for the currently executing thread */ - static caml_thread_t curr_thread = NULL; -/* The global mutex used to ensure that at most one thread is running - Caml code */ -static pthread_mutex_t caml_mutex; +/* Track whether one thread is running Caml code. There can be + at most one such thread at any time. */ +static volatile int caml_runtime_busy = 1; + +/* Number of threads waiting to run Caml code. */ +static volatile int caml_runtime_waiters = 0; + +/* Mutex that protects the two variables above. */ +static pthread_mutex_t caml_runtime_mutex = PTHREAD_MUTEX_INITIALIZER; + +/* Condition signaled when caml_runtime_busy becomes 0 */ +static pthread_cond_t caml_runtime_is_free = PTHREAD_COND_INITIALIZER; /* The key used for storing the thread descriptor in the specific data of the corresponding Posix thread. */ @@ -113,11 +122,15 @@ static pthread_key_t last_channel_locked_key; /* Identifier for next thread creation */ static long thread_next_ident = 0; +/* Whether to use sched_yield() or not */ +static int broken_sched_yield = 0; + /* Forward declarations */ value caml_threadstatus_new (void); void caml_threadstatus_terminate (value); int caml_threadstatus_wait (value); static void caml_pthread_check (int, char *); +static void caml_thread_sysdeps_initialize(void); /* Imports for the native-code compiler */ extern struct longjmp_buffer caml_termination_jmpbuf; @@ -182,14 +195,24 @@ static void caml_thread_enter_blocking_section(void) curr_thread->backtrace_buffer = backtrace_buffer; curr_thread->backtrace_last_exn = backtrace_last_exn; #endif - /* Release the global mutex */ - pthread_mutex_unlock(&caml_mutex); + /* Tell other threads that the runtime is free */ + pthread_mutex_lock(&caml_runtime_mutex); + caml_runtime_busy = 0; + pthread_mutex_unlock(&caml_runtime_mutex); + pthread_cond_signal(&caml_runtime_is_free); } static void caml_thread_leave_blocking_section(void) { - /* Re-acquire the global mutex */ - pthread_mutex_lock(&caml_mutex); + /* Wait until the runtime is free */ + pthread_mutex_lock(&caml_runtime_mutex); + while (caml_runtime_busy) { + caml_runtime_waiters++; + pthread_cond_wait(&caml_runtime_is_free, &caml_runtime_mutex); + caml_runtime_waiters--; + } + caml_runtime_busy = 1; + pthread_mutex_unlock(&caml_runtime_mutex); /* Update curr_thread to point to the thread descriptor corresponding to the thread currently executing */ curr_thread = pthread_getspecific(thread_descriptor_key); @@ -314,10 +337,8 @@ value caml_thread_initialize(value unit) /* ML */ /* Protect against repeated initialization (PR#1325) */ if (curr_thread != NULL) return Val_unit; Begin_root (mu); - /* Initialize the main mutex */ - caml_pthread_check(pthread_mutex_init(&caml_mutex, NULL), - "Thread.init"); - pthread_mutex_lock(&caml_mutex); + /* OS-specific initialization */ + caml_thread_sysdeps_initialize(); /* Initialize the keys */ pthread_key_create(&thread_descriptor_key, NULL); pthread_key_create(&last_channel_locked_key, NULL); @@ -378,9 +399,12 @@ static void caml_thread_stop(void) /* Remove th from the doubly-linked list of threads */ th->next->prev = th->prev; th->prev->next = th->next; - /* Release the main mutex (forever) */ + /* Release the runtime system */ async_signal_mode = 1; - pthread_mutex_unlock(&caml_mutex); + pthread_mutex_lock(&caml_runtime_mutex); + caml_runtime_busy = 0; + pthread_mutex_unlock(&caml_runtime_mutex); + pthread_cond_signal(&caml_runtime_is_free); #ifndef NATIVE_CODE /* Free the memory resources */ stat_free(th->stack_low); @@ -539,8 +563,9 @@ value caml_thread_exit(value unit) /* ML */ value caml_thread_yield(value unit) /* ML */ { + if (caml_runtime_waiters == 0) return Val_unit; enter_blocking_section(); - sched_yield(); + if (! broken_sched_yield) sched_yield(); leave_blocking_section(); return Val_unit; } @@ -820,3 +845,21 @@ static void caml_pthread_check(int retcode, char *msg) memmove (&Byte(str, msglen + 2), err, errlen); raise_sys_error(str); } + +/* OS-specific initialization */ + +static void caml_thread_sysdeps_initialize(void) +{ +#ifdef __linux__ + /* sched_yield() doesn't do what we want in kernel 2.6 and up (PR#2663) */ + struct utsname un; + if (uname(&un) == -1) return; + broken_sched_yield = + un.release[1] != '.' || un.release[0] >= '3' /* version 3 and up */ + || (un.release[0] == '2' && + (un.release[3] != '.' || un.release[2] >= '6')); /* 2.6 and up */ + caml_gc_message(0x100, "POSIX threads. Avoid sched_yield: %d\n", + broken_sched_yield); +#endif +} + diff --git a/otherlibs/threads/pervasives.ml b/otherlibs/threads/pervasives.ml index 5d6fd60e0..10320bb60 100644 --- a/otherlibs/threads/pervasives.ml +++ b/otherlibs/threads/pervasives.ml @@ -499,12 +499,20 @@ module LargeFile = type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 external format_of_string : ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity" -external string_of_format : ('a, 'b, 'c, 'd) format4 -> string = "%identity" - +external string_of_format_sys : + ('a, 'b, 'c, 'd) format4 -> string = "%identity" external string_to_format : string -> ('a, 'b, 'c, 'd) format4 = "%identity" + let (( ^^ ) : ('a, 'b, 'c, 'd) format4 -> ('d, 'b, 'c, 'e) format4 -> ('a, 'b, 'c, 'e) format4) = fun fmt1 fmt2 -> - string_to_format (string_of_format fmt1 ^ string_of_format fmt2);; + string_to_format (string_of_format_sys fmt1 ^ string_of_format_sys fmt2);; + +let string_of_format f = + let s = string_of_format_sys f in + let l = string_length s in + let r = string_create l in + string_blit s 0 r 0 l; + r (* Miscellaneous *) diff --git a/otherlibs/threads/thread.mli b/otherlibs/threads/thread.mli index 17a6260b3..8da968a80 100644 --- a/otherlibs/threads/thread.mli +++ b/otherlibs/threads/thread.mli @@ -70,7 +70,7 @@ val wait_write : Unix.file_descr -> unit on the given Unix file descriptor. *) val wait_timed_read : Unix.file_descr -> float -> bool -(** See {!Thread.wait_timed_read}.*) +(** See {!Thread.wait_timed_write}.*) val wait_timed_write : Unix.file_descr -> float -> bool (** Same as {!Thread.wait_read} and {!Thread.wait_write}, but wait for at most diff --git a/otherlibs/threads/threadUnix.ml b/otherlibs/threads/threadUnix.ml index 2510bdd99..66a3704c1 100644 --- a/otherlibs/threads/threadUnix.ml +++ b/otherlibs/threads/threadUnix.ml @@ -23,6 +23,7 @@ let waitpid = Unix.waitpid let system = Unix.system let read = Unix.read let write = Unix.write +let single_write = Unix.single_write let select = Unix.select let pipe = Unix.pipe let open_process_in = Unix.open_process_in diff --git a/otherlibs/threads/threadUnix.mli b/otherlibs/threads/threadUnix.mli index e0a4a82b7..1b4dde29b 100644 --- a/otherlibs/threads/threadUnix.mli +++ b/otherlibs/threads/threadUnix.mli @@ -34,6 +34,7 @@ val system : string -> Unix.process_status val read : Unix.file_descr -> string -> int -> int -> int val write : Unix.file_descr -> string -> int -> int -> int +val single_write : Unix.file_descr -> string -> int -> int -> int (** {6 Input/output with timeout} *) diff --git a/otherlibs/threads/unix.ml b/otherlibs/threads/unix.ml index beec810aa..30c2c58c6 100644 --- a/otherlibs/threads/unix.ml +++ b/otherlibs/threads/unix.ml @@ -201,7 +201,10 @@ external openfile : string -> open_flag list -> file_perm -> file_descr external close : file_descr -> unit = "unix_close" external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" -external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" +external unsafe_write : file_descr -> string -> int -> int -> int + = "unix_write" +external unsafe_single_write : file_descr -> string -> int -> int -> int + = "unix_single_write" let rec read fd buf ofs len = try @@ -219,6 +222,14 @@ let rec write fd buf ofs len = with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> wait_write fd; write fd buf ofs len +let rec single_write fd buf ofs len = + try + if ofs < 0 || len < 0 || ofs > String.length buf - len + then invalid_arg "Unix.partial_write" + else unsafe_single_write fd buf ofs len + with Unix_error((EAGAIN | EWOULDBLOCK), _, _) -> + wait_write fd; single_write fd buf ofs len + external in_channel_of_descr : file_descr -> in_channel = "caml_ml_open_descriptor_in" external out_channel_of_descr : file_descr -> out_channel diff --git a/otherlibs/unix/.depend b/otherlibs/unix/.depend index 4179e3e9b..045cd7f71 100644 --- a/otherlibs/unix/.depend +++ b/otherlibs/unix/.depend @@ -1,233 +1,359 @@ -accept.o: accept.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h socketaddr.h -access.o: access.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -addrofstr.o: addrofstr.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h -alarm.o: alarm.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +accept.o: accept.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h \ + socketaddr.h +access.o: access.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h +addrofstr.o: addrofstr.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ + unixsupport.h socketaddr.h +alarm.o: alarm.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -bind.o: bind.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +bind.o: bind.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h socketaddr.h -chdir.o: chdir.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +chdir.o: chdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -chmod.o: chmod.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +chmod.o: chmod.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -chown.o: chown.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +chown.o: chown.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -chroot.o: chroot.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -close.o: close.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +chroot.o: chroot.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -closedir.o: closedir.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -connect.o: connect.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h -cst2constr.o: cst2constr.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h cst2constr.h -cstringv.o: cstringv.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ +close.o: close.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h unixsupport.h +closedir.o: closedir.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h unixsupport.h +connect.o: connect.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/signals.h \ + unixsupport.h socketaddr.h +cst2constr.o: cst2constr.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h cst2constr.h +cstringv.o: cstringv.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h -dup2.o: dup2.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +dup.o: dup.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -dup.o: dup.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +dup2.o: dup2.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -envir.o: envir.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h -errmsg.o: errmsg.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h -execv.o: execv.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h -execve.o: execve.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ +envir.o: envir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h +errmsg.o: errmsg.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h +execv.o: execv.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h -execvp.o: execvp.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ +execve.o: execve.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h -exit.o: exit.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +execvp.o: execvp.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h +exit.o: exit.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -fchmod.o: fchmod.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -fchown.o: fchown.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -fcntl.o: fcntl.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +fchmod.o: fchmod.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -fork.o: fork.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +fchown.o: fchown.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -ftruncate.o: ftruncate.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -getaddrinfo.o: getaddrinfo.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h cst2constr.h socketaddr.h -getcwd.o: getcwd.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -getegid.o: getegid.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -geteuid.o: geteuid.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -getgid.o: getgid.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -getgr.o: getgr.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \ +fcntl.o: fcntl.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h unixsupport.h +fork.o: fork.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h unixsupport.h +ftruncate.o: ftruncate.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/io.h unixsupport.h +getaddrinfo.o: getaddrinfo.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \ + ../../byterun/signals.h unixsupport.h cst2constr.h socketaddr.h +getcwd.o: getcwd.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h +getegid.o: getegid.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h unixsupport.h +geteuid.o: geteuid.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h unixsupport.h +getgid.o: getgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h unixsupport.h +getgr.o: getgr.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/fail.h ../../byterun/alloc.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h -getgroups.o: getgroups.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -gethost.o: gethost.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h socketaddr.h -gethostname.o: gethostname.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -getlogin.o: getlogin.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -getnameinfo.o: getnameinfo.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h socketaddr.h -getpeername.o: getpeername.c ../../byterun/config.h ../../config/m.h \ +getgroups.o: getgroups.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + unixsupport.h +gethost.o: gethost.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \ + ../../byterun/signals.h unixsupport.h socketaddr.h +gethostname.o: gethostname.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + unixsupport.h +getlogin.o: getlogin.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + unixsupport.h +getnameinfo.o: getnameinfo.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \ + ../../byterun/signals.h unixsupport.h socketaddr.h +getpeername.o: getpeername.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h -getpid.o: getpid.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -getppid.o: getppid.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -getproto.o: getproto.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h -getpw.o: getpw.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h -getserv.o: getserv.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h -getsockname.o: getsockname.c ../../byterun/config.h ../../config/m.h \ +getpid.o: getpid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h unixsupport.h +getppid.o: getppid.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h unixsupport.h +getproto.o: getproto.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \ + unixsupport.h +getpw.o: getpw.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h +getserv.o: getserv.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h ../../byterun/fail.h \ + unixsupport.h +getsockname.o: getsockname.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h -gettimeofday.o: gettimeofday.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -getuid.o: getuid.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -gmtime.o: gmtime.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ +gettimeofday.o: gettimeofday.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + unixsupport.h +getuid.o: getuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h unixsupport.h +gmtime.o: gmtime.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h -itimer.o: itimer.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ +itimer.o: itimer.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h -kill.o: kill.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +kill.o: kill.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/fail.h unixsupport.h \ + ../../byterun/signals.h +link.o: link.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -link.o: link.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +listen.o: listen.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -listen.o: listen.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -lockf.o: lockf.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +lockf.o: lockf.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/signals.h unixsupport.h +lseek.o: lseek.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/io.h \ + unixsupport.h +mkdir.o: mkdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -lseek.o: lseek.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +mkfifo.o: mkfifo.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -mkdir.o: mkdir.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +nice.o: nice.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -mkfifo.o: mkfifo.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -nice.o: nice.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +open.o: open.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h +opendir.o: opendir.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + unixsupport.h +pipe.o: pipe.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h +putenv.o: putenv.c ../../byterun/memory.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/gc.h ../../byterun/mlvalues.h ../../byterun/misc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h unixsupport.h +read.o: read.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ + ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h +readdir.o: readdir.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/fail.h \ + ../../byterun/alloc.h unixsupport.h +readlink.o: readlink.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + unixsupport.h +rename.o: rename.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -open.o: open.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h -opendir.o: opendir.c ../../byterun/config.h ../../config/m.h \ +rewinddir.o: rewinddir.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ ../../config/s.h ../../byterun/misc.h unixsupport.h -pipe.o: pipe.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +rmdir.o: rmdir.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -putenv.o: putenv.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/gc.h ../../byterun/mlvalues.h \ - ../../byterun/misc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h -read.o: read.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h -readdir.o: readdir.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -readlink.o: readlink.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -rename.o: rename.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -rewinddir.o: rewinddir.c ../../byterun/config.h ../../config/m.h \ +select.o: select.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h +sendrecv.o: sendrecv.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h \ + ../../byterun/signals.h unixsupport.h socketaddr.h +setgid.o: setgid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h unixsupport.h +setsid.o: setsid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h unixsupport.h +setuid.o: setuid.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h unixsupport.h +shutdown.o: shutdown.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ ../../config/s.h ../../byterun/misc.h unixsupport.h -rmdir.o: rmdir.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +signals.o: signals.c ../../byterun/alloc.h ../../byterun/compatibility.h \ + ../../byterun/misc.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/mlvalues.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h +sleep.o: sleep.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/signals.h unixsupport.h +socket.o: socket.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -select.o: select.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ - ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h -sendrecv.o: sendrecv.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ +socketaddr.o: socketaddr.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/memory.h ../../byterun/gc.h ../../byterun/major_gc.h \ + ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h \ + socketaddr.h +socketpair.o: socketpair.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + unixsupport.h +sockopt.o: sockopt.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + unixsupport.h socketaddr.h +stat.o: stat.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h socketaddr.h -setgid.o: setgid.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -setsid.o: setsid.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -setuid.o: setuid.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -shutdown.o: shutdown.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -signals.o: signals.c ../../byterun/misc.h ../../byterun/config.h \ - ../../config/m.h ../../config/s.h ../../byterun/mlvalues.h \ + ../../byterun/minor_gc.h ../../byterun/alloc.h unixsupport.h \ + cst2constr.h ../../byterun/io.h +strofaddr.o: strofaddr.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + unixsupport.h socketaddr.h +symlink.o: symlink.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h unixsupport.h +termios.o: termios.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + unixsupport.h +time.o: time.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h unixsupport.h +times.o: times.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \ ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ ../../byterun/minor_gc.h unixsupport.h -sleep.o: sleep.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +truncate.o: truncate.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/io.h unixsupport.h +umask.o: umask.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -socketaddr.o: socketaddr.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ +unixsupport.o: unixsupport.c ../../byterun/mlvalues.h \ + ../../byterun/compatibility.h ../../byterun/config.h ../../config/m.h \ + ../../config/s.h ../../byterun/misc.h ../../byterun/alloc.h \ + ../../byterun/callback.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h socketaddr.h -socket.o: socket.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -socketpair.o: socketpair.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -sockopt.o: sockopt.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h -stat.o: stat.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h \ + ../../byterun/minor_gc.h ../../byterun/fail.h unixsupport.h \ cst2constr.h -strofaddr.o: strofaddr.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h socketaddr.h -symlink.o: symlink.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -termios.o: termios.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -time.o: time.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +unlink.o: unlink.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -times.o: times.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h -truncate.o: truncate.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -umask.o: umask.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ +utimes.o: utimes.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ ../../byterun/misc.h unixsupport.h -unixsupport.o: unixsupport.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h ../../byterun/gc.h \ +wait.o: wait.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/alloc.h ../../byterun/memory.h \ + ../../byterun/gc.h ../../byterun/major_gc.h ../../byterun/freelist.h \ + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h +write.o: write.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \ + ../../byterun/config.h ../../config/m.h ../../config/s.h \ + ../../byterun/misc.h ../../byterun/memory.h ../../byterun/gc.h \ ../../byterun/major_gc.h ../../byterun/freelist.h \ - ../../byterun/minor_gc.h unixsupport.h cst2constr.h -unlink.o: unlink.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -utimes.o: utimes.c ../../byterun/config.h ../../config/m.h \ - ../../config/s.h ../../byterun/misc.h unixsupport.h -wait.o: wait.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h -write.o: write.c ../../byterun/config.h ../../config/m.h ../../config/s.h \ - ../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.h \ - ../../byterun/freelist.h ../../byterun/minor_gc.h unixsupport.h + ../../byterun/minor_gc.h ../../byterun/signals.h unixsupport.h unixLabels.cmi: unix.cmi -unixLabels.cmo: unix.cmi unixLabels.cmi -unixLabels.cmx: unix.cmx unixLabels.cmi unix.cmo: unix.cmi unix.cmx: unix.cmi +unixLabels.cmo: unix.cmi unixLabels.cmi +unixLabels.cmx: unix.cmx unixLabels.cmi diff --git a/otherlibs/unix/unix.ml b/otherlibs/unix/unix.ml index e7f0b38b6..1ffb7eeff 100644 --- a/otherlibs/unix/unix.ml +++ b/otherlibs/unix/unix.ml @@ -161,6 +161,7 @@ external openfile : string -> open_flag list -> file_perm -> file_descr external close : file_descr -> unit = "unix_close" external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" +external unsafe_single_write : file_descr -> string -> int -> int -> int = "unix_single_write" let read fd buf ofs len = if ofs < 0 || len < 0 || ofs > String.length buf - len @@ -170,6 +171,13 @@ let write fd buf ofs len = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.write" else unsafe_write fd buf ofs len +(* write misbehaves because it attempts to write all data by making repeated + calls to the Unix write function (see comment in write.c and unix.mli). + partial_write fixes this by never calling write twice. *) +let single_write fd buf ofs len = + if ofs < 0 || len < 0 || ofs > String.length buf - len + then invalid_arg "Unix.single_write" + else unsafe_single_write fd buf ofs len external in_channel_of_descr : file_descr -> in_channel = "caml_ml_open_descriptor_in" diff --git a/otherlibs/unix/unix.mli b/otherlibs/unix/unix.mli index f82cd88bd..ee08a2760 100644 --- a/otherlibs/unix/unix.mli +++ b/otherlibs/unix/unix.mli @@ -260,9 +260,13 @@ val write : file_descr -> string -> int -> int -> int (** [write fd buff ofs len] writes [len] characters to descriptor [fd], taking them from string [buff], starting at position [ofs] in string [buff]. Return the number of characters actually - written. *) - + written. [write] repeats the writing operation until all characters + have been written or an error occurs. *) +val single_write : file_descr -> string -> int -> int -> int +(** Same as [write], but attempts to write only once. + Thus, if an error occurs, [single_write] guarantees that no data + has been written. *) (** {6 Interfacing with the standard input/output library} *) diff --git a/otherlibs/unix/unixLabels.mli b/otherlibs/unix/unixLabels.mli index 3ab7e6289..1f081c81f 100644 --- a/otherlibs/unix/unixLabels.mli +++ b/otherlibs/unix/unixLabels.mli @@ -263,7 +263,15 @@ val write : file_descr -> buf:string -> pos:int -> len:int -> int (** [write fd buff ofs len] writes [len] characters to descriptor [fd], taking them from string [buff], starting at position [ofs] in string [buff]. Return the number of characters actually - written. *) + written. + + When an error is reported some characters might have already been + written. Use [single_write] instead to ensure that this is not the + case. *) + +val single_write : file_descr -> buf:string -> pos:int -> len:int -> int +(** Same as [write] but ensures that all errors are reported and + that no character has ever been written when an error is reported. *) (** {6 Interfacing with the standard input/output library} *) diff --git a/otherlibs/unix/write.c b/otherlibs/unix/write.c index 0e02437b8..633f05fc0 100644 --- a/otherlibs/unix/write.c +++ b/otherlibs/unix/write.c @@ -54,3 +54,34 @@ CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) End_roots(); return Val_long(written); } + +/* When an error occurs after the first loop, unix_write reports the + error and discards the number of already written characters. + In this case, it would be better to discard the error and return the + number of bytes written, since most likely, unix_write will be call again, + and the error will be reproduced and this time will be reported. + This problem is avoided in unix_single_write, which is faithful to the + Unix system call. */ + +CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) +{ + long ofs, len; + int numbytes, ret; + char iobuf[UNIX_BUFFER_SIZE]; + + Begin_root (buf); + ofs = Long_val(vofs); + len = Long_val(vlen); + ret = 0; + if (len > 0) { + numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; + memmove (iobuf, &Byte(buf, ofs), numbytes); + enter_blocking_section(); + ret = write(Int_val(fd), iobuf, numbytes); + leave_blocking_section(); + if (ret == -1) uerror("single_write", Nothing); + } + End_roots(); + return Val_int(ret); +} + diff --git a/otherlibs/win32graph/Makefile.nt b/otherlibs/win32graph/Makefile.nt index 127418261..18c6410cb 100644 --- a/otherlibs/win32graph/Makefile.nt +++ b/otherlibs/win32graph/Makefile.nt @@ -22,7 +22,7 @@ CAMLC=../../boot/ocamlrun ../../ocamlc -I ../../stdlib CAMLOPT=../../boot/ocamlrun ../../ocamlopt -I ../../stdlib COMPFLAGS=-warn-error A -COBJS=open.$(O) draw.$(O) dib.$(O) +COBJS=open.$(O) draw.$(O) events.$(O) dib.$(O) CAMLOBJS=graphics.cmo WIN32LIBS=$(call SYSLIB,kernel32) $(call SYSLIB,gdi32) $(call SYSLIB,user32) diff --git a/otherlibs/win32graph/draw.c b/otherlibs/win32graph/draw.c index c4f1224b2..1bebe0208 100644 --- a/otherlibs/win32graph/draw.c +++ b/otherlibs/win32graph/draw.c @@ -15,9 +15,11 @@ #include <math.h> #include "mlvalues.h" #include "alloc.h" +#include "fail.h" #include "libgraph.h" #include "custom.h" #include "memory.h" + HDC gcMetaFile; int grdisplay_mode; int grremember_mode; @@ -84,38 +86,18 @@ CAMLprim value caml_gr_lineto(value vx, value vy) CAMLprim value caml_gr_draw_rect(value vx, value vy, value vw, value vh) { -#if 0 - int x = Int_val(vx); - int y = Int_val(vy); - int w = Int_val(vw); - int h = Int_val(vh); - - gr_check_open(); - if(grdisplay_mode) { - Rectangle(grwindow.gc,x, Wcvt(y) , x+w, Wcvt(y+h)); - } - if(grremember_mode) { - Rectangle(grwindow.gcBitmap,x, Wcvt(y), x+w, Wcvt(h+y)); - } - return Val_unit; -#else int x, y, w, h; POINT pt[5]; x=Int_val(vx); - y=Int_val(vy); + y=Wcvt(Int_val(vy)); w=Int_val(vw); h=Int_val(vh); - pt[0].x = x; - pt[0].y = Wcvt(y-1); - pt[1].x = x+w; - pt[1].y = pt[0].y; - pt[2].x = pt[1].x; - pt[2].y = Wcvt(y+h-1); - pt[3].x = pt[0].x; - pt[3].y = pt[2].y; - pt[4].x = pt[0].x; - pt[4].y = pt[0].y; + pt[0].x = x; pt[0].y = y - h; + pt[1].x = x + w; pt[1].y = y - h; + pt[2].x = x + w; pt[2].y = y; + pt[3].x = x; pt[3].y = y; + pt[4].x = x; pt[4].y = y - h; if (grremember_mode) { Polyline(grwindow.gcBitmap,pt, 5); } @@ -123,7 +105,6 @@ CAMLprim value caml_gr_draw_rect(value vx, value vy, value vw, value vh) Polyline(grwindow.gc,pt, 5); } return Val_unit; -#endif } CAMLprim value caml_gr_draw_text(value text,value x) @@ -405,125 +386,6 @@ CAMLprim value caml_gr_text_size(value str) return res; } -#if 0 -static unsigned char gr_queue[SIZE_QUEUE]; -static int gr_head = 0; /* position of next read */ -static int gr_tail = 0; /* position of next write */ - -#define QueueIsEmpty (gr_head == gr_tail) -#define QueueIsFull (gr_head == gr_tail + 1) - -void gr_enqueue_char(unsigned char c) -{ - if (QueueIsFull) return; - gr_queue[gr_tail] = c; - gr_tail++; - if (gr_tail >= SIZE_QUEUE) gr_tail = 0; -} -#endif - -#define Button_down 1 -#define Button_up 2 -#define Key_pressed 4 -#define Mouse_motion 8 -#define Poll 16 -MSG * InspectMessages = NULL; - -CAMLprim value caml_gr_wait_event(value eventlist) -{ - value res; - int mask; - BOOL poll; - int mouse_x, mouse_y, button, key; - int root_x, root_y, win_x, win_y; - int r,i,stop; - unsigned int modifiers; - POINT pt; - MSG msg; - - gr_check_open(); - mask = 0; - poll = FALSE; - while (eventlist != Val_int(0)) { - switch (Int_val(Field(eventlist,0))) { - case 0: /* Button_down */ - mask |= Button_down; - break; - case 1: /* Button_up */ - mask |= Button_up; - break; - case 2: /* Key_pressed */ - mask |= Key_pressed; - break; - case 3: /* Mouse_motion */ - mask |= Mouse_motion; - break; - case 4: /* Poll */ - poll = TRUE; - break; - } - eventlist = Field(eventlist,1); - } - mouse_x = -1; - mouse_y = -1; - button = 0; - key = -1; - - if (poll) { - // Poll uses info on last event stored in global variables - mouse_x = MouseLastX; - mouse_y = MouseLastY; - button = MouseLbuttonDown | MouseMbuttonDown | MouseRbuttonDown; - key = LastKey; - } - else { // Not polled. Block for a message - InspectMessages = &msg; - do { - WaitForSingleObject(EventHandle,INFINITE); - stop = 0; - switch (msg.message) { - case WM_LBUTTONDOWN: - case WM_MBUTTONDOWN: - case WM_RBUTTONDOWN: - button = 1; - if (mask&Button_down) stop = 1; - break; - case WM_LBUTTONUP: - case WM_MBUTTONUP: - case WM_RBUTTONUP: - button = 0; - if (mask&Button_up) stop = 1; - break; - case WM_MOUSEMOVE: - if (mask&Mouse_motion) stop = 1; - break; - case WM_CHAR: - key = msg.wParam & 0xFF; - if (mask&Key_pressed) stop = 1; - break; - case WM_CLOSE: - stop = 1; - break; - } - if (stop) { - pt = msg.pt; - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - mouse_x = pt.x; - mouse_y = grwindow.height- 1 - pt.y; - } - SetEvent(EventProcessedHandle); - } while (! stop); - InspectMessages = NULL; - } - res = alloc_small(5, 0); - Field(res, 0) = Val_int(mouse_x); - Field(res, 1) = Val_int(mouse_y); - Field(res, 2) = Val_bool(button); - Field(res, 3) = Val_bool(key != -1); - Field(res, 4) = Val_int(key & 0xFF); - return res; -} - CAMLprim value caml_gr_fill_poly(value vect) { int n_points, i; diff --git a/otherlibs/win32graph/events.c b/otherlibs/win32graph/events.c new file mode 100755 index 000000000..9e0791c38 --- /dev/null +++ b/otherlibs/win32graph/events.c @@ -0,0 +1,200 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Xavier Leroy, projet Cristal, INRIA Rocquencourt */ +/* */ +/* Copyright 2004 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. */ +/* */ +/***********************************************************************/ + +/* $Id$ */ + +#include "mlvalues.h" +#include "alloc.h" +#include "libgraph.h" +#include <windows.h> + +enum { + EVENT_BUTTON_DOWN = 1, + EVENT_BUTTON_UP = 2, + EVENT_KEY_PRESSED = 4, + EVENT_MOUSE_MOTION = 8 +}; + +struct event_data { + short mouse_x, mouse_y; + unsigned char kind; + unsigned char button; + unsigned char key; +}; + +static struct event_data caml_gr_queue[SIZE_QUEUE]; +static unsigned int caml_gr_head = 0; /* position of next read */ +static unsigned int caml_gr_tail = 0; /* position of next write */ + +static int caml_gr_event_mask = EVENT_KEY_PRESSED; +static int last_button = 0; +static LPARAM last_pos = 0; + +HANDLE caml_gr_queue_semaphore = NULL; +CRITICAL_SECTION caml_gr_queue_mutex; + +void caml_gr_init_event_queue(void) +{ + if (caml_gr_queue_semaphore == NULL) { + caml_gr_queue_semaphore = CreateSemaphore(NULL, 0, SIZE_QUEUE, NULL); + InitializeCriticalSection(&caml_gr_queue_mutex); + } +} + +#define QueueIsEmpty (caml_gr_tail == caml_gr_head) + +static void caml_gr_enqueue_event(int kind, LPARAM mouse_xy, + int button, int key) +{ + struct event_data * ev; + + if ((caml_gr_event_mask & kind) == 0) return; + EnterCriticalSection(&caml_gr_queue_mutex); + ev = &(caml_gr_queue[caml_gr_tail]); + ev->kind = kind; + ev->mouse_x = GET_X_LPARAM(mouse_xy); + ev->mouse_y = GET_Y_LPARAM(mouse_xy); + ev->button = (button != 0); + ev->key = key; + caml_gr_tail = (caml_gr_tail + 1) % SIZE_QUEUE; + /* If queue was full, it now appears empty; + drop oldest entry from queue. */ + if (QueueIsEmpty) { + caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE; + } else { + /* One more event in queue */ + ReleaseSemaphore(caml_gr_queue_semaphore, 1, NULL); + } + LeaveCriticalSection(&caml_gr_queue_mutex); +} + +void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam) +{ + switch (msg) { + case WM_LBUTTONDOWN: + case WM_RBUTTONDOWN: + case WM_MBUTTONDOWN: + last_button = 1; + last_pos = lParam; + caml_gr_enqueue_event(EVENT_BUTTON_DOWN, lParam, 1, 0); + break; + + case WM_LBUTTONUP: + case WM_RBUTTONUP: + case WM_MBUTTONUP: + last_button = 0; + last_pos = lParam; + caml_gr_enqueue_event(EVENT_BUTTON_UP, lParam, 0, 0); + break; + + case WM_CHAR: + caml_gr_enqueue_event(EVENT_KEY_PRESSED, last_pos, last_button, wParam); + break; + + case WM_MOUSEMOVE: + last_pos = lParam; + caml_gr_enqueue_event(EVENT_MOUSE_MOTION, lParam, last_button, 0); + break; + } +} + +static value caml_gr_wait_allocate_result(int mouse_x, int mouse_y, + int button, + int keypressed, int key) +{ + value res = alloc_small(5, 0); + Field(res, 0) = Val_int(mouse_x); + Field(res, 1) = Val_int(grwindow.height - 1 - mouse_y); + Field(res, 2) = Val_bool(button); + Field(res, 3) = Val_bool(keypressed); + Field(res, 4) = Val_int(key & 0xFF); + return res; +} + +static value caml_gr_wait_event_poll(void) +{ + int key, keypressed, i; + + /* Look inside event queue for pending KeyPress events */ + EnterCriticalSection(&caml_gr_queue_mutex); + key = 0; + keypressed = 0; + for (i = caml_gr_head; i != caml_gr_tail; i = (i + 1) % SIZE_QUEUE) { + if (caml_gr_queue[i].kind == EVENT_KEY_PRESSED) { + keypressed = 1; + key = caml_gr_queue[i].key; + break; + } + } + LeaveCriticalSection(&caml_gr_queue_mutex); + /* Use global vars for mouse position and buttons */ + return caml_gr_wait_allocate_result(GET_X_LPARAM(last_pos), + GET_Y_LPARAM(last_pos), + last_button, + keypressed, key); +} + +static value caml_gr_wait_event_blocking(int mask) +{ + struct event_data ev; + + /* Increase the selected events if needed */ + caml_gr_event_mask |= mask; + /* Pop events from queue until one matches */ + do { + /* Wait for event queue to be non-empty */ + WaitForSingleObject(caml_gr_queue_semaphore, INFINITE); + /* Pop oldest event in queue */ + EnterCriticalSection(&caml_gr_queue_mutex); + ev = caml_gr_queue[caml_gr_head]; + /* Queue should never be empty at this point, but just in case... */ + if (QueueIsEmpty) { + ev.kind = 0; + } else { + caml_gr_head = (caml_gr_head + 1) % SIZE_QUEUE; + } + LeaveCriticalSection(&caml_gr_queue_mutex); + /* Check if it matches */ + } while ((ev.kind & mask) == 0); + return caml_gr_wait_allocate_result(ev.mouse_x, ev.mouse_y, ev.button, + ev.kind == EVENT_KEY_PRESSED, + ev.key); +} + +CAMLprim value caml_gr_wait_event(value eventlist) /* ML */ +{ + int mask, poll; + + gr_check_open(); + mask = 0; + poll = 0; + while (eventlist != Val_int(0)) { + switch (Int_val(Field(eventlist, 0))) { + case 0: /* Button_down */ + mask |= EVENT_BUTTON_DOWN; break; + case 1: /* Button_up */ + mask |= EVENT_BUTTON_UP; break; + case 2: /* Key_pressed */ + mask |= EVENT_KEY_PRESSED; break; + case 3: /* Mouse_motion */ + mask |= EVENT_MOUSE_MOTION; break; + case 4: /* Poll */ + poll = 1; break; + } + eventlist = Field(eventlist, 1); + } + if (poll) + return caml_gr_wait_event_poll(); + else + return caml_gr_wait_event_blocking(mask); +} diff --git a/otherlibs/win32graph/libgraph.h b/otherlibs/win32graph/libgraph.h index acbe29cc1..6c32f15df 100644 --- a/otherlibs/win32graph/libgraph.h +++ b/otherlibs/win32graph/libgraph.h @@ -45,9 +45,6 @@ extern int bits_per_pixel; #define BORDER_WIDTH 2 #define WINDOW_NAME "Caml graphics" #define ICON_NAME "Caml graphics" -#define DEFAULT_EVENT_MASK \ - (ExposureMask | KeyPressMask | StructureNotifyMask) -#define DEFAULT_FONT "fixed" #define SIZE_QUEUE 256 void gr_fail(char *fmt, char *arg); @@ -77,10 +74,5 @@ typedef struct tagWindow { extern GR_WINDOW grwindow; HFONT CreationFont(char *name); -extern int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown; -extern HANDLE EventHandle, EventProcessedHandle; -extern MSG * InspectMessages; -extern int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown; -extern int MouseLastX, MouseLastY; -extern int LastKey; - +extern void caml_gr_init_event_queue(void); +extern void caml_gr_handle_event(UINT msg, WPARAM wParam, LPARAM lParam); diff --git a/otherlibs/win32graph/open.c b/otherlibs/win32graph/open.c index 654f550bf..6376e5abe 100644 --- a/otherlibs/win32graph/open.c +++ b/otherlibs/win32graph/open.c @@ -15,12 +15,11 @@ #include <fcntl.h> #include <signal.h> #include "mlvalues.h" +#include "fail.h" #include "libgraph.h" #include <windows.h> + static value gr_reset(void); -int MouseLbuttonDown,MouseMbuttonDown,MouseRbuttonDown; -int MouseLastX, MouseLastY; -int LastKey = -1; static long tid; static HANDLE threadHandle; HWND grdisplay = NULL; @@ -36,11 +35,11 @@ int grcolor; extern HFONT * grfont; MSG msg; -HANDLE EventHandle, EventProcessedHandle; static char *szOcamlWindowClass = "OcamlWindowClass"; static BOOL gr_initialized = 0; CAMLprim value caml_gr_clear_graph(void); HANDLE hInst; + HFONT CreationFont(char *name) { LOGFONT CurrentFont; @@ -65,8 +64,11 @@ void SetCoordinates(HWND hwnd) void ResetForClose(HWND hwnd) { + DeleteDC(grwindow.tempDC); + DeleteDC(grwindow.gcBitmap); DeleteObject(grwindow.hBitmap); memset(&grwindow,0,sizeof(grwindow)); + gr_initialized = 0; } @@ -98,44 +100,9 @@ static LRESULT CALLBACK GraphicsWndProc(HWND hwnd,UINT msg,WPARAM wParam,LPARAM case WM_DESTROY: ResetForClose(hwnd); break; - case WM_LBUTTONDOWN: - MouseLbuttonDown = 1; - break; - case WM_LBUTTONUP: - MouseLbuttonDown = 0; - break; - case WM_RBUTTONDOWN: - MouseRbuttonDown = 1; - break; - case WM_RBUTTONUP: - MouseRbuttonDown = 0; - break; - case WM_MBUTTONDOWN: - MouseMbuttonDown = 1; - break; - case WM_MBUTTONUP: - MouseMbuttonDown = 0; - break; - case WM_CHAR: - LastKey = wParam & 0xFF; - break; - case WM_KEYUP: - LastKey = -1; - break; - case WM_MOUSEMOVE: -#if 0 - pt.x = GET_X_LPARAM(lParam); - pt.y = GET_Y_LPARAM(lParam); - MapWindowPoints(HWND_DESKTOP,grwindow.hwnd,&pt,1); - MouseLastX = pt.x; - MouseLastY = grwindow.height - 1 - pt.y; -#else - MouseLastX = GET_X_LPARAM(lParam); - MouseLastY = grwindow.height - 1 - GET_Y_LPARAM(lParam); -#endif - break; } - return DefWindowProc(hwnd,msg,wParam,lParam); + caml_gr_handle_event(msg, wParam, lParam); + return DefWindowProc(hwnd, msg, wParam, lParam); } int DoRegisterClass(void) @@ -266,8 +233,7 @@ static DWORD WINAPI gr_open_graph_internal(value arg) grwindow.grx = 0; grwindow.gry = 0; - EventHandle = CreateEvent(NULL,0,0,NULL); - EventProcessedHandle = CreateEvent(NULL,0,0,NULL); + caml_gr_init_event_queue(); /* The global data structures are now correctly initialized. Restart the Caml main thread. */ @@ -276,17 +242,10 @@ static DWORD WINAPI gr_open_graph_internal(value arg) /* Enter the message handling loop */ while (GetMessage(&msg,NULL,0,0)) { - if (InspectMessages != NULL) { - *InspectMessages = msg; - SetEvent(EventHandle); - } TranslateMessage(&msg); // Translates virtual key codes DispatchMessage(&msg); // Dispatches message to window if (!IsWindow(grwindow.hwnd)) break; - if (InspectMessages != NULL) { - WaitForSingleObject(EventProcessedHandle,INFINITE); - } } return 0; } @@ -310,11 +269,8 @@ CAMLprim value caml_gr_open_graph(value arg) CAMLprim value caml_gr_close_graph(void) { if (gr_initialized) { - DeleteDC(grwindow.tempDC); - DeleteDC(grwindow.gcBitmap); - DestroyWindow(grwindow.hwnd); - memset(&grwindow,0,sizeof(grwindow)); - gr_initialized = 0; + PostMessage(grwindow.hwnd, WM_CLOSE, 0, 0); + WaitForSingleObject(threadHandle, INFINITE); } return Val_unit; } diff --git a/otherlibs/win32unix/rename.c b/otherlibs/win32unix/rename.c index d84bcd66a..3bfdf4770 100644 --- a/otherlibs/win32unix/rename.c +++ b/otherlibs/win32unix/rename.c @@ -19,9 +19,23 @@ CAMLprim value unix_rename(value path1, value path2) { - if (MoveFileEx(String_val(path1), String_val(path2), - MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH | - MOVEFILE_COPY_ALLOWED) == 0) { + static int supports_MoveFileEx = -1; /* don't know yet */ + BOOL ok; + + if (supports_MoveFileEx < 0) { + OSVERSIONINFO VersionInfo; + VersionInfo.dwOSVersionInfoSize = sizeof(OSVERSIONINFO); + supports_MoveFileEx = + (GetVersionEx(&VersionInfo) != 0) + && (VersionInfo.dwPlatformId == VER_PLATFORM_WIN32_NT); + } + if (supports_MoveFileEx > 0) + ok = MoveFileEx(String_val(path1), String_val(path2), + MOVEFILE_REPLACE_EXISTING | MOVEFILE_WRITE_THROUGH | + MOVEFILE_COPY_ALLOWED); + else + ok = MoveFile(String_val(path1), String_val(path2)); + if (! ok) { win32_maperr(GetLastError()); uerror("rename", path1); } diff --git a/otherlibs/win32unix/unix.ml b/otherlibs/win32unix/unix.ml index 0f100ed7e..240857943 100644 --- a/otherlibs/win32unix/unix.ml +++ b/otherlibs/win32unix/unix.ml @@ -180,6 +180,8 @@ external unsafe_read : file_descr -> string -> int -> int -> int = "unix_read" external unsafe_write : file_descr -> string -> int -> int -> int = "unix_write" +external unsafe_single_write : file_descr -> string -> int -> int -> int + = "unix_single_write" let read fd buf ofs len = if ofs < 0 || len < 0 || ofs > String.length buf - len @@ -189,6 +191,10 @@ let write fd buf ofs len = if ofs < 0 || len < 0 || ofs > String.length buf - len then invalid_arg "Unix.write" else unsafe_write fd buf ofs len +let single_write fd buf ofs len = + if ofs < 0 || len < 0 || ofs > String.length buf - len + then invalid_arg "Unix.single_write" + else unsafe_single_write fd buf ofs len (* Interfacing with the standard input/output library *) diff --git a/otherlibs/win32unix/write.c b/otherlibs/win32unix/write.c index 8571ff679..862e50791 100644 --- a/otherlibs/win32unix/write.c +++ b/otherlibs/win32unix/write.c @@ -62,3 +62,44 @@ CAMLprim value unix_write(value fd, value buf, value vofs, value vlen) End_roots(); return Val_long(written); } + +CAMLprim value unix_single_write(value fd, value buf, value vofs, value vlen) +{ + long ofs, len, written; + DWORD numbytes, numwritten; + char iobuf[UNIX_BUFFER_SIZE]; + + Begin_root (buf); + ofs = Long_val(vofs); + len = Long_val(vlen); + written = 0; + if (len > 0) { + numbytes = len > UNIX_BUFFER_SIZE ? UNIX_BUFFER_SIZE : len; + memmove (iobuf, &Byte(buf, ofs), numbytes); + if (Descr_kind_val(fd) == KIND_SOCKET) { + int ret; + SOCKET s = Socket_val(fd); + enter_blocking_section(); + ret = send(s, iobuf, numbytes, 0); + leave_blocking_section(); + if (ret == SOCKET_ERROR) { + win32_maperr(WSAGetLastError()); + uerror("single_write", Nothing); + } + numwritten = ret; + } else { + BOOL ret; + HANDLE h = Handle_val(fd); + enter_blocking_section(); + ret = WriteFile(h, iobuf, numbytes, &numwritten, NULL); + leave_blocking_section(); + if (! ret) { + win32_maperr(GetLastError()); + uerror("single_write", Nothing); + } + } + written = numwritten; + } + End_roots(); + return Val_long(written); +} diff --git a/stdlib/.depend b/stdlib/.depend index 0d15561d0..82a3ead49 100644 --- a/stdlib/.depend +++ b/stdlib/.depend @@ -17,10 +17,10 @@ buffer.cmo: string.cmi sys.cmi buffer.cmi buffer.cmx: string.cmx sys.cmx buffer.cmi callback.cmo: obj.cmi callback.cmi callback.cmx: obj.cmx callback.cmi -camlinternalOO.cmo: array.cmi hashtbl.cmi list.cmi map.cmi obj.cmi random.cmi \ - sort.cmi sys.cmi camlinternalOO.cmi -camlinternalOO.cmx: array.cmx hashtbl.cmx list.cmx map.cmx obj.cmx random.cmx \ - sort.cmx sys.cmx camlinternalOO.cmi +camlinternalOO.cmo: array.cmi char.cmi list.cmi map.cmi obj.cmi string.cmi \ + sys.cmi camlinternalOO.cmi +camlinternalOO.cmx: array.cmx char.cmx list.cmx map.cmx obj.cmx string.cmx \ + sys.cmx camlinternalOO.cmi char.cmo: char.cmi char.cmx: char.cmi complex.cmo: complex.cmi @@ -67,8 +67,8 @@ parsing.cmo: array.cmi lexing.cmi obj.cmi parsing.cmi parsing.cmx: array.cmx lexing.cmx obj.cmx parsing.cmi pervasives.cmo: pervasives.cmi pervasives.cmx: pervasives.cmi -printexc.cmo: obj.cmi printf.cmi sys.cmi printexc.cmi -printexc.cmx: obj.cmx printf.cmx sys.cmx printexc.cmi +printexc.cmo: obj.cmi printf.cmi printexc.cmi +printexc.cmx: obj.cmx printf.cmx printexc.cmi printf.cmo: buffer.cmi char.cmi list.cmi obj.cmi string.cmi printf.cmi printf.cmx: buffer.cmx char.cmx list.cmx obj.cmx string.cmx printf.cmi queue.cmo: obj.cmi queue.cmi @@ -78,9 +78,9 @@ random.cmo: array.cmi char.cmi digest.cmi int32.cmi int64.cmi nativeint.cmi \ random.cmx: array.cmx char.cmx digest.cmx int32.cmx int64.cmx nativeint.cmx \ pervasives.cmx string.cmx random.cmi scanf.cmo: buffer.cmi hashtbl.cmi list.cmi obj.cmi printf.cmi string.cmi \ - sys.cmi scanf.cmi + scanf.cmi scanf.cmx: buffer.cmx hashtbl.cmx list.cmx obj.cmx printf.cmx string.cmx \ - sys.cmx scanf.cmi + scanf.cmi set.cmo: set.cmi set.cmx: set.cmi sort.cmo: array.cmi sort.cmi diff --git a/stdlib/Compflags b/stdlib/Compflags index e263fbcf2..697f38dca 100755 --- a/stdlib/Compflags +++ b/stdlib/Compflags @@ -15,12 +15,12 @@ # $Id$ case $1 in - pervasives.cm[iox]|pervasives.p.cmx) echo '-nopervasives';; - camlinternalOO.cmi) echo '-nopervasives';; - camlinternalOO.cmx|camlinternalOO.p.cmx) echo '-inline 0';; - arrayLabels.cm[ox]|arrayLabels.p.cmx) echo '-nolabels';; - listLabels.cm[ox]|listLabels.p.cmx) echo '-nolabels';; - stringLabels.cm[ox]|stringLabels.p.cmx) echo '-nolabels';; - moreLabels.cm[ox]|moreLabels.p.cmx) echo '-nolabels';; - *) echo '';; + pervasives.cm[iox]|pervasives.p.cmx) echo ' -nopervasives';; + camlinternalOO.cmi) echo ' -nopervasives';; + camlinternalOO.cmx|camlinternalOO.p.cmx) echo ' -inline 0';; + arrayLabels.cm[ox]|arrayLabels.p.cmx) echo ' -nolabels';; + listLabels.cm[ox]|listLabels.p.cmx) echo ' -nolabels';; + stringLabels.cm[ox]|stringLabels.p.cmx) echo ' -nolabels';; + moreLabels.cm[ox]|moreLabels.p.cmx) echo ' -nolabels';; + *) echo ' ';; esac diff --git a/stdlib/arg.ml b/stdlib/arg.ml index 9514b9557..dd6c51753 100644 --- a/stdlib/arg.ml +++ b/stdlib/arg.ml @@ -133,7 +133,7 @@ let parse_argv ?(current=current) argv speclist anonfun errmsg = begin try let rec treat_action = function | Unit f -> f (); - | Bool f -> + | Bool f when !current + 1 < l -> let arg = argv.(!current + 1) in begin try f (bool_of_string arg) with Invalid_argument "bool_of_string" -> diff --git a/stdlib/format.ml b/stdlib/format.ml index dcee1a491..0c345137d 100644 --- a/stdlib/format.ml +++ b/stdlib/format.ml @@ -184,10 +184,25 @@ let pp_clear_queue state = state.pp_left_total <- 1; state.pp_right_total <- 1; clear_queue state.pp_queue;; -(* Large value for default tokens size. *) -(* Could be 1073741823 that is 2^30 - 1, that is the minimal upper bound - of integers; now that max_int is defined, could also be max_int - 1. *) -let pp_infinity = 1000000000;; +(* Pp_infinity: large value for default tokens size. + + Pp_infinity is documented as being greater than 1e10; to avoid + confusion about the word ``greater'' we shoose pp_infinity greater + than 1e10 + 1; for correct handling of tests in the algorithm + pp_infinity must be even one more than that; let's stand on the + safe side by choosing 1.e10+10. + + Pp_infinity could probably be 1073741823 that is 2^30 - 1, that is + the minimal upper bound of integers; now that max_int is defined, + could also be defined as max_int - 1. + + We must carefully double-check all the integer arithmetic + operations that involve pp_infinity before setting pp_infinity to + something around max_int: otherwise any overflow would wreck havoc + the pretty-printing algorithm's invariants. + Is it worth the burden ? *) + +let pp_infinity = 1000000010;; (* Output functions for the formatter. *) let pp_output_string state s = state.pp_output_function s 0 (String.length s) @@ -632,11 +647,15 @@ let pp_set_ellipsis_text state s = state.pp_ellipsis <- s and pp_get_ellipsis_text state () = state.pp_ellipsis;; (* To set the margin of pretty-printer. *) +let pp_limit n = + if n < pp_infinity then n else pred pp_infinity;; + let pp_set_min_space_left state n = - if n >= 1 && n < pp_infinity then begin + if n >= 1 then + let n = pp_limit n in state.pp_min_space_left <- n; state.pp_max_indent <- state.pp_margin - state.pp_min_space_left; - pp_rinit state end;; + pp_rinit state;; (* Initially, we have : pp_max_indent = pp_margin - pp_min_space_left, and @@ -646,7 +665,8 @@ let pp_set_max_indent state n = let pp_get_max_indent state () = state.pp_max_indent;; let pp_set_margin state n = - if n >= 1 && n < pp_infinity then begin + if n >= 1 then + let n = pp_limit n in state.pp_margin <- n; let new_max_indent = (* Try to maintain max_indent to its actual value. *) @@ -658,7 +678,7 @@ let pp_set_margin state n = max (max (state.pp_margin - state.pp_min_space_left) (state.pp_margin / 2)) 1 in (* Rebuild invariants. *) - pp_set_max_indent state new_max_indent end;; + pp_set_max_indent state new_max_indent;; let pp_get_margin state () = state.pp_margin;; diff --git a/stdlib/format.mli b/stdlib/format.mli index 3526e2365..09f9badf1 100644 --- a/stdlib/format.mli +++ b/stdlib/format.mli @@ -162,8 +162,9 @@ val set_margin : int -> unit;; (** [set_margin d] sets the value of the right margin to [d] (in characters): this value is used to detect line overflows that leads to split lines. - Nothing happens if [d] is smaller than 2 or - bigger than 999999999. *) + Nothing happens if [d] is smaller than 2. + If [d] is too large, the right margin is set to the maximum + admissible value (which is greater than [10^10]). *) val get_margin : unit -> int;; (** Returns the position of the right margin. *) @@ -176,13 +177,13 @@ val set_max_indent : int -> unit;; indentation limit to [d] (in characters): once this limit is reached, boxes are rejected to the left, if they do not fit on the current line. - Nothing happens if [d] is smaller than 2 or - bigger than 999999999. *) + Nothing happens if [d] is smaller than 2. + If [d] is too large, the limit is set to the maximum + admissible value (which is greater than [10^10]). *) val get_max_indent : unit -> int;; (** Return the value of the maximum indentation limit (in characters). *) - (** {6 Formatting depth: maximum number of boxes allowed before ellipsis} *) val set_max_boxes : int -> unit;; @@ -191,7 +192,7 @@ val set_max_boxes : int -> unit;; Material inside boxes nested deeper is printed as an ellipsis (more precisely as the text returned by [get_ellipsis_text ()]). - Nothing happens if [max] is not greater than 1. *) + Nothing happens if [max] is smaller than 2. *) val get_max_boxes : unit -> int;; (** Returns the maximum number of boxes allowed before ellipsis. *) diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml index 514adeee7..7cdfe9325 100644 --- a/stdlib/pervasives.ml +++ b/stdlib/pervasives.ml @@ -401,12 +401,20 @@ external decr: int ref -> unit = "%decr" type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 external format_of_string : ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity" -external string_of_format : ('a, 'b, 'c, 'd) format4 -> string = "%identity" - +external string_of_format_sys : + ('a, 'b, 'c, 'd) format4 -> string = "%identity" external string_to_format : string -> ('a, 'b, 'c, 'd) format4 = "%identity" + let (( ^^ ) : ('a, 'b, 'c, 'd) format4 -> ('d, 'b, 'c, 'e) format4 -> ('a, 'b, 'c, 'e) format4) = fun fmt1 fmt2 -> - string_to_format (string_of_format fmt1 ^ string_of_format fmt2);; + string_to_format (string_of_format_sys fmt1 ^ string_of_format_sys fmt2);; + +let string_of_format f = + let s = string_of_format_sys f in + let l = string_length s in + let r = string_create l in + string_blit s 0 r 0 l; + r (* Miscellaneous *) diff --git a/stdlib/pervasives.mli b/stdlib/pervasives.mli index 0b678ca28..430d1d7ab 100644 --- a/stdlib/pervasives.mli +++ b/stdlib/pervasives.mli @@ -630,9 +630,9 @@ val pos_out : out_channel -> int unspecified results). *) val out_channel_length : out_channel -> int -(** Return the total length (number of characters) of the - given channel. This works only for regular files. On files of - other kinds, the result is meaningless. *) +(** Return the size (number of characters) of the regular file + on which the given channel is opened. If the channel is opened + on a file that is not a regular file, the result is meaningless. *) val close_out : out_channel -> unit (** Close the given channel, flushing all buffered write operations. @@ -738,9 +738,12 @@ val pos_in : in_channel -> int (** Return the current reading position for the given channel. *) val in_channel_length : in_channel -> int -(** Return the total length (number of characters) of the - given channel. This works only for regular files. On files of - other kinds, the result is meaningless. *) +(** Return the size (number of characters) of the regular file + on which the given channel is opened. If the channel is opened + on a file that is not a regular file, the result is meaningless. + The returned size does not take into account the end-of-line + translations that can be performed when reading from a channel + opened in text mode. *) val close_in : in_channel -> unit (** Close the given channel. Input functions raise a [Sys_error] @@ -819,9 +822,9 @@ type ('a, 'b, 'c) format = ('a, 'b, 'c, 'c) format4 and ['b] is the type of the first argument given to [%a] and [%t] printing functions. *) -external string_of_format : - ('a, 'b, 'c, 'd) format4 -> string = "%identity" +val string_of_format : ('a, 'b, 'c, 'd) format4 -> string (** Converts a format string into a string. *) + external format_of_string : ('a, 'b, 'c, 'd) format4 -> ('a, 'b, 'c, 'd) format4 = "%identity" (** [format_of_string s] returns a format string read from the string diff --git a/stdlib/scanf.ml b/stdlib/scanf.ml index 78adcc706..cb0291b20 100644 --- a/stdlib/scanf.ml +++ b/stdlib/scanf.ml @@ -256,6 +256,7 @@ let bad_float () = bad_input "no dot or exponent part found in float token";; (* Checking that the current char is indeed one of range, then skip it. *) let check_char_in range ib = + if range <> [] && not (Scanning.end_of_input ib) then let ci = Scanning.checked_peek_char ib in if List.memq ci range then Scanning.next_char ib else let sr = String.concat "" (List.map (String.make 1) range) in @@ -486,7 +487,7 @@ let scan_Float max ib = characters has been read.*) let scan_string stp max ib = let rec loop max = - if max = 0 || Scanning.eof ib then max else + if max = 0 || Scanning.end_of_input ib then max else let c = Scanning.checked_peek_char ib in if stp == [] then match c with @@ -495,7 +496,7 @@ let scan_string stp max ib = if List.mem c stp then max else loop (Scanning.store_char ib c max) in let max = loop max in - if stp != [] then check_char_in stp ib; + check_char_in stp ib; max;; (* Scan a char: peek strictly one character in the input, whatsoever. *) @@ -795,7 +796,7 @@ let scan_chars_in_char_set stp char_set max ib = | 2 -> loop_neg2 set.[0] set.[1] max | 3 when set.[1] != '-' -> loop_neg3 set.[0] set.[1] set.[2] max | n -> loop (find_setp stp char_set) max end in - if stp != [] then check_char_in stp ib; + check_char_in stp ib; max;; let get_count t ib = diff --git a/stdlib/stdLabels.mli b/stdlib/stdLabels.mli index fbda4b7a4..73f72dc68 100644 --- a/stdlib/stdLabels.mli +++ b/stdlib/stdLabels.mli @@ -99,6 +99,7 @@ module List : val sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list val stable_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list val fast_sort : cmp:('a -> 'a -> int) -> 'a list -> 'a list + val merge : cmp:('a -> 'a -> int) -> 'a list -> 'a list -> 'a list end module String : @@ -128,6 +129,8 @@ module String : val lowercase : string -> string val capitalize : string -> string val uncapitalize : string -> string + type t = string + val compare: t -> t -> int external unsafe_get : string -> int -> char = "%string_unsafe_get" external unsafe_set : string -> int -> char -> unit = "%string_unsafe_set" external unsafe_blit : diff --git a/stdlib/stringLabels.mli b/stdlib/stringLabels.mli index b1f957751..7ea72bafe 100644 --- a/stdlib/stringLabels.mli +++ b/stdlib/stringLabels.mli @@ -142,6 +142,14 @@ val capitalize : string -> string val uncapitalize : string -> string (** Return a copy of the argument, with the first letter set to lowercase. *) +type t = string +(** An alias for the type of strings. *) + +val compare: t -> t -> int +(** The comparison function for strings, with the same specification as + {!Pervasives.compare}. Along with the type [t], this function [compare] + allows the module [String] to be passed as argument to the functors + {!Set.Make} and {!Map.Make}. *) (**/**) diff --git a/stdlib/sys.ml b/stdlib/sys.ml index f11f2929e..9554a82a1 100644 --- a/stdlib/sys.ml +++ b/stdlib/sys.ml @@ -78,4 +78,4 @@ let catch_break on = (* OCaml version string, must be in the format described in sys.mli. *) -let ocaml_version = "3.09+dev0 (2004-06-22)";; +let ocaml_version = "3.09+dev0 (2004-07-13)";; diff --git a/test/Moretest/tscanf.ml b/test/Moretest/tscanf.ml index 0cb7658f7..70b35bfc8 100644 --- a/test/Moretest/tscanf.ml +++ b/test/Moretest/tscanf.ml @@ -267,10 +267,24 @@ let test11 () = prenom = "Daniel" && nom = "de Rauglaudre" && poids = 66) ;; +(* Empty string (end of input) testing. *) let test110 () = sscanf "" " " (fun x -> x) "" = "" && - sscanf "" "%[^\n]" (fun x -> x) = "" && - sscanf "" "%[^\n] " (fun x -> x) = "";; + sscanf "" "%s" (fun x -> x = "") && + sscanf "" "%s%s" (fun x y -> x = "" && y = "") && + sscanf "" "%s " (fun x -> x = "") && + sscanf "" " %s" (fun x -> x = "") && + sscanf "" " %s " (fun x -> x = "") && + sscanf "" "%[^\n]" (fun x -> x = "") && + sscanf "" "%[^\n] " (fun x -> x = "") && + sscanf " " "%s" (fun x -> x = "") && + sscanf " " "%s%s" (fun x y -> x = "" && y = "") && + sscanf " " " %s " (fun x -> x = "") && + sscanf " " " %s %s" (fun x y -> x = "" && x = y) && + sscanf " " " %s@ %s" (fun x y -> x = "" && x = y) && + sscanf " poi !" " %s@ %s@." (fun x y -> x = "" && y = "poi!") && + sscanf " poi !" " %s@ %s@." (fun x y -> x = "poi" && y = "!") && + sscanf " poi !" "%s@ %s@." (fun x y -> x = "" && y = "poi !");; let test111 () = try (sscanf "" "%[^\n]@\n") (fun x -> false) with diff --git a/tools/.depend b/tools/.depend index d04026c44..035fd88b9 100644 --- a/tools/.depend +++ b/tools/.depend @@ -19,14 +19,10 @@ dumpobj.cmx: ../parsing/asttypes.cmi ../bytecomp/bytesections.cmx \ ../utils/config.cmx ../bytecomp/emitcode.cmx ../typing/ident.cmx \ ../bytecomp/instruct.cmx ../bytecomp/lambda.cmx ../bytecomp/opcodes.cmx \ opnames.cmx ../utils/tbl.cmx -lexer299.cmo: ../parsing/location.cmi ../utils/misc.cmi ../utils/warnings.cmi -lexer299.cmx: ../parsing/location.cmx ../utils/misc.cmx ../utils/warnings.cmx lexer301.cmo: ../parsing/location.cmi ../utils/misc.cmi ../utils/warnings.cmi lexer301.cmx: ../parsing/location.cmx ../utils/misc.cmx ../utils/warnings.cmx objinfo.cmo: ../utils/config.cmi ../bytecomp/emitcode.cmi objinfo.cmx: ../utils/config.cmx ../bytecomp/emitcode.cmx -ocaml299to3.cmo: lexer299.cmo -ocaml299to3.cmx: lexer299.cmx ocamlcp.cmo: ../driver/main_args.cmi ocamlcp.cmx: ../driver/main_args.cmx ocamldep.cmo: ../utils/clflags.cmo ../utils/config.cmi depend.cmi \ diff --git a/tools/ocamlmklib.mlp b/tools/ocamlmklib.mlp index a97ba47a5..352f1da3e 100644 --- a/tools/ocamlmklib.mlp +++ b/tools/ocamlmklib.mlp @@ -143,7 +143,7 @@ Options are: -ocamlc <cmd> Use <cmd> in place of \"ocamlc\" -ocamlopt <cmd> Use <cmd> in place of \"ocamlopt\" -o <name> Generated Caml library is named <name>.cma or <name>.cmxa - -oc <name> Generated C library is named lib<name>.so or lib<name>.a + -oc <name> Generated C library is named dll<name>.so or lib<name>.a -rpath <dir> Same as -dllpath <dir> -R<dir> Same as -rpath -verbose Print commands before executing them diff --git a/toplevel/topdirs.ml b/toplevel/topdirs.ml index 2c951cc7f..eac3581f0 100644 --- a/toplevel/topdirs.ml +++ b/toplevel/topdirs.ml @@ -102,12 +102,16 @@ let load_file ppf name = let toc_pos = input_binary_int ic in (* Go to table of contents *) seek_in ic toc_pos; let lib = (input_value ic : library) in - begin try - Dll.open_dlls (List.map Dll.extract_dll_name lib.lib_dllibs) - with Failure reason -> - fprintf ppf "Cannot load required shared library: %s.@." reason; - raise Load_failed - end; + List.iter + (fun dllib -> + let name = Dll.extract_dll_name dllib in + try Dll.open_dlls [name] + with Failure reason -> + fprintf ppf + "Cannot load required shared library %s.@.Reason: %s.@." + name reason; + raise Load_failed) + lib.lib_dllibs; List.iter (load_compunit ic filename ppf) lib.lib_units; true end else begin diff --git a/typing/ctype.ml b/typing/ctype.ml index 415a7d9f9..4918b50ff 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -224,6 +224,7 @@ let rec opened_object ty = Tobject (t, _) -> opened_object t | Tfield(_, _, _, t) -> opened_object t | Tvar -> true + | Tunivar -> true | _ -> false (**** Close an object ****) diff --git a/typing/printtyp.ml b/typing/printtyp.ml index eef9ea778..c40b707fc 100644 --- a/typing/printtyp.ml +++ b/typing/printtyp.ml @@ -24,16 +24,6 @@ open Types open Btype open Outcometree -(* Redefine it here since goal differs *) - -let rec opened_object ty = - match (repr ty).desc with - Tobject (t, _) -> opened_object t - | Tfield(_, _, _, t) -> opened_object t - | Tvar -> true - | Tunivar -> true - | _ -> false - (* Print a long identifier *) let rec longident ppf = function diff --git a/typing/typecore.ml b/typing/typecore.ml index 0c3ccc87b..b3017a193 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -720,7 +720,7 @@ let type_format loc fmt = | _ -> if c = 'l' || c = 'n' then conversion (j - 1) Predef.type_int - else invalid i (j - i) + else invalid i (j - 1) end | c -> invalid i j in scan_width i j in diff --git a/utils/misc.ml b/utils/misc.ml index 989c313bb..3c66443f5 100644 --- a/utils/misc.ml +++ b/utils/misc.ml @@ -61,6 +61,12 @@ let rec split_last = function let (lst, last) = split_last tl in (hd :: lst, last) +let rec samelist pred l1 l2 = + match (l1, l2) with + | ([], []) -> true + | (hd1 :: tl1, hd2 :: tl2) -> pred hd1 hd2 && samelist pred tl1 tl2 + | (_, _) -> false + (* Options *) let may f = function diff --git a/utils/misc.mli b/utils/misc.mli index 4f92077e7..faaa109a8 100644 --- a/utils/misc.mli +++ b/utils/misc.mli @@ -35,6 +35,9 @@ val list_remove: 'a -> 'a list -> 'a list element equal to [x] removed. *) val split_last: 'a list -> 'a list * 'a (* Return the last element and the other elements of the given list. *) +val samelist: ('a -> 'a -> bool) -> 'a list -> 'a list -> bool + (* Like [List.for_all2] but returns [false] if the two + lists have different length. *) val may: ('a -> unit) -> 'a option -> unit val may_map: ('a -> 'b) -> 'a option -> 'b option diff --git a/win32caml/editbuffer.c b/win32caml/editbuffer.c new file mode 100644 index 000000000..480d22d86 --- /dev/null +++ b/win32caml/editbuffer.c @@ -0,0 +1,514 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Developed by Jacob Navia. */ +/* Copyright 2001 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. */ +/* */ +/***********************************************************************/ + +/***********************************************************************/ +/* Changes made by Chris Watford to enhance the source editor */ +/* Began 14 Sept 2003 - watford@uiuc.edu */ +/***********************************************************************/ + +#include <string.h> +#include <stdlib.h> +#include "inriares.h" +#include "inria.h" + +/*------------------------------------------------------------------------ + Procedure: editbuffer_addline ID:1 + Author: Chris Watford watford@uiuc.edu + Purpose: Adds a line to the current edit buffer + Input: Line of text to append to the end + Output: + Errors: +-------------------------------------------------------------------------- + Edit History: + 18 Sept 2003 - Chris Watford watford@uiuc.edu + - Corrected doubly linked list issue +------------------------------------------------------------------------*/ +BOOL editbuffer_addline(EditBuffer* edBuf, char* line) +{ + LineList *tail = NULL; //head of the edit buffer line list + LineList *newline = NULL; + + // sanity check + if(edBuf == NULL) + { + return FALSE; + } + + // perform edit buffer sanity checks + if((edBuf->LineCount < 0) || (edBuf->Lines == NULL)) + { + edBuf->LineCount = 0; + } + + // move to the end of the line list in the edit buffer + if((tail = edBuf->Lines) != NULL) + for( ; tail->Next != NULL; tail = tail->Next); + + // create the new line entry + newline = (LineList*)SafeMalloc(sizeof(LineList)); + newline->Next = NULL; + newline->Prev = tail; + newline->Text = (char*)SafeMalloc(strlen(line)+1); + strncpy(newline->Text, line, strlen(line)+1); + newline->Text[strlen(line)] = '\0'; + + // add it to the list as the head or the tail + if(tail != NULL) + { + tail->Next = newline; + } else { + edBuf->Lines = newline; + } + + // update the number of lines in the buffer + edBuf->LineCount++; + + return TRUE; +} + +/*------------------------------------------------------------------------ + Procedure: editbuffer_updateline ID:1 + Author: Chris Watford watford@uiuc.edu + Purpose: Updates the edit buffer's internal contents for a line + Input: idx - Line index + line - String to add + Output: if the line was updated or not + Errors: +------------------------------------------------------------------------*/ +BOOL editbuffer_updateline(EditBuffer* edBuf, int idx, char* line) +{ + LineList *update = edBuf->Lines; //head of the edit buffer line list + LineList *newline = NULL; + int i; + + // sanity checks + if(edBuf == NULL) + { + return FALSE; + } else if( (edBuf->LineCount == 0) || + (edBuf->Lines == NULL) || + (idx >= edBuf->LineCount) || + (idx < 0) ) { + return FALSE; + } + + // move to the index in the line list + // i left in update != NULL as a sanity check + for(i = 0; ((update != NULL) && (i != idx)); update = update->Next, i++); + + // did things mess up? + if( (update == NULL) || (i != idx) ) + { + return FALSE; + } + + // get rid of the old line + free(update->Text); + + // get the new line updated + update->Text = (char*)SafeMalloc(strlen(line)+1); + strncpy(update->Text, line, strlen(line)+1); + update->Text[strlen(line)] = '\0'; + + return TRUE; +} + +/*------------------------------------------------------------------------ + Procedure: editbuffer_updateoraddline ID:1 + Author: Chris Watford watford@uiuc.edu + Purpose: Updates the edit buffer's internal contents for a line + Input: idx - Line index + line - String to add + Output: if the line was updated or not + Errors: +------------------------------------------------------------------------*/ +BOOL editbuffer_updateoraddline(EditBuffer* edBuf, int idx, char* line) +{ + LineList *update; + + // sanity checks + if(edBuf == NULL) + { + return FALSE; + } else if((idx > edBuf->LineCount) || (idx < 0)) { + return FALSE; + } + + update = edBuf->Lines; //head of the edit buffer line list + + // do we update or add? + if((idx < edBuf->LineCount) && (edBuf->Lines != NULL)) + { //interior line, update + return editbuffer_updateline(edBuf, idx, line); + } else { + //fence line, add + return editbuffer_addline(edBuf, line); + } +} + +/*------------------------------------------------------------------------ + Procedure: editbuffer_removeline ID:1 + Author: Chris Watford watford@uiuc.edu + Purpose: Removes a line from the edit buffer + Input: idx - Line index to remove + Output: if the line was removed or not + Errors: +-------------------------------------------------------------------------- + Edit History: + 18 Sept 2003 - Chris Watford watford@uiuc.edu + - Added to allow backspace and delete support + - Corrected doubly linked list issue +------------------------------------------------------------------------*/ +BOOL editbuffer_removeline(EditBuffer* edBuf, int idx) +{ + LineList *update = NULL; + int i = 0; + + // sanity checks + if(edBuf == NULL) + { + return FALSE; + } else if( (edBuf->LineCount == 0) || + (edBuf->Lines == NULL) || + (idx >= edBuf->LineCount) || + (idx < 0) ) { + return FALSE; + } + + // move to the index in the line list + // i left in update != NULL as a sanity check + for(i = 0, update = edBuf->Lines; ((update != NULL) && (i != idx)); update = update->Next, i++); + + // remove this line + if(update != NULL) + { + // break links, removing our line + if(update->Prev != NULL) + { + // we're not the first so just break the link + update->Prev->Next = update->Next; + + // fix the prev check + if(update->Next != NULL) + update->Next->Prev = update->Prev; + } else { + // we're the first, attach the next guy to lines + edBuf->Lines = update->Next; + } + + // one less line to worry about + edBuf->LineCount--; + + // get rid of the text + if(update->Text != NULL) + free(update->Text); + + // get rid of us + free(update); + + return TRUE; + } + + return FALSE; +} + +/*------------------------------------------------------------------------ + Procedure: editbuffer_getasline ID:1 + Author: Chris Watford watford@uiuc.edu + Purpose: Returns the edit buffer as one big line, \n's and \t's + become spaces. + Input: + Output: + Errors: +------------------------------------------------------------------------*/ +char* editbuffer_getasline(EditBuffer* edBuf) +{ + LineList *line = NULL; //head of the edit buffer line list + char* retline = (char*)realloc(NULL, 1); + unsigned int i = 0; + + // fix retline bug + retline[0] = '\0'; + + // sanity checks + if(edBuf == NULL) + { + return NULL; + } else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) { + // fix any possible errors that may come from this + edBuf->LineCount = 0; + edBuf->Lines = NULL; + return NULL; + } + + // get the big line + for(line = edBuf->Lines; line != NULL; line = line->Next) + { + if(line->Text != NULL) + { + retline = (char*)realloc(retline, (strlen(retline) + strlen(line->Text) + (strlen(retline) > 0 ? 2 : 1))); + + if(strlen(retline) > 0) + retline = strcat(retline, " "); + + retline = strcat(retline, line->Text); + + //concat in the hoouuusssseee! + } + } + + // now we have the big line, so lets ditch all \n's \t's and \r's + for(i = 0; i < strlen(retline); i++) + { + switch(retline[i]) + { + case '\n': + case '\t': + case '\r': + retline[i] = ' '; + } + } + + return retline; +} + +/*------------------------------------------------------------------------ + Procedure: editbuffer_getasbuffer ID:1 + Author: Chris Watford watford@uiuc.edu + Purpose: Returns the edit buffer as one big line, \n's and \t's + become spaces. + Input: + Output: + Errors: +------------------------------------------------------------------------*/ +char* editbuffer_getasbuffer(EditBuffer* edBuf) +{ + LineList *line = NULL; //head of the edit buffer line list + char* retbuf = (char*)realloc(NULL, 1); + unsigned int i = 0; + + // fix retline bug + retbuf[0] = '\0'; + + // sanity checks + if(edBuf == NULL) + { + return NULL; + } else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) { + // fix any possible errors that may come from this + edBuf->LineCount = 0; + edBuf->Lines = NULL; + return NULL; + } + + // get the big line + for(line = edBuf->Lines; line != NULL; line = line->Next) + { + if(line->Text != NULL) + { + int len = strlen(retbuf); + len += strlen(line->Text) + (len > 0 ? 3 : 1); + + retbuf = (char*)realloc(retbuf, len); + + if(strlen(retbuf) > 0) + retbuf = strcat(retbuf, "\r\n"); + + retbuf = strcat(retbuf, line->Text); + + retbuf[len-1] = '\0'; + + //concat in the hoouuusssseee! + } + } + + return retbuf; +} + +/*------------------------------------------------------------------------ + Procedure: editbuffer_lastline ID:1 + Author: Chris Watford watford@uiuc.edu + Purpose: Returns the last line in the edit buffer + Input: + Output: + Errors: +------------------------------------------------------------------------*/ +char* editbuffer_lastline(EditBuffer* edBuf) +{ + LineList *line = NULL; //head of the edit buffer line list + + // sanity checks + if(edBuf == NULL) + { + return NULL; + } else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) { + // fix any possible errors that may come from this + edBuf->LineCount = 0; + edBuf->Lines = NULL; + return NULL; + } + + // go to the last line + for(line = edBuf->Lines; line->Next != NULL; line = line->Next); + + return line->Text; +} + +/*------------------------------------------------------------------------ + Procedure: editbuffer_copy ID:1 + Author: Chris Watford watford@uiuc.edu + Purpose: Makes an exact copy of an edit buffer + Input: + Output: + Errors: +-------------------------------------------------------------------------- + Edit History: + 16 Sept 2003 - Chris Watford watford@uiuc.edu + - Added to make copies of history entries + 18 Sept 2003 - Chris Watford watford@uiuc.edu + - Corrected doubly linked list issue + 06 Oct 2003 - Chris Watford watford@uiuc.edu + - Added isCorrect flag +------------------------------------------------------------------------*/ +EditBuffer* editbuffer_copy(EditBuffer* edBuf) +{ + // sanity checks + if(edBuf == NULL) + { + return NULL; + } else { + EditBuffer* copy = (EditBuffer*)SafeMalloc(sizeof(EditBuffer)); + LineList* lines = edBuf->Lines; + LineList* lastLine = NULL; + + // clear its initial values + copy->LineCount = 0; + copy->Lines = NULL; + copy->isCorrect = FALSE; + + // well we don't have to copy much + if((lines == NULL) || (edBuf->LineCount <= 0)) + { + return copy; + } + + // get if its correct + copy->isCorrect = edBuf->isCorrect; + + // go through each line, malloc it and add it + for( ; lines != NULL; lines = lines->Next) + { + LineList* curline = (LineList*)SafeMalloc(sizeof(LineList)); + curline->Next = NULL; + curline->Prev = NULL; + + // if there was a last line, link them to us + if(lastLine != NULL) + { + lastLine->Next = curline; + curline->Prev = lastLine; + } + + // are we the first line? add us to the edit buffer as the first + if(copy->Lines == NULL) + { + copy->Lines = curline; + } + + // check if there is text on the line + if(lines->Text == NULL) + { // no text, make it blankz0r + curline->Text = (char*)SafeMalloc(sizeof(char)); + curline->Text[0] = '\0'; + } else { + // there is text, copy it and null-terminate + curline->Text = (char*)SafeMalloc(strlen(lines->Text) + 1); + strncpy(curline->Text, lines->Text, strlen(lines->Text)); + curline->Text[strlen(lines->Text)] = '\0'; + } + + // up the line count and make us the last line + copy->LineCount++; + lastLine = curline; + } + + // return our new copy + return copy; + } +} + +/*------------------------------------------------------------------------ + Procedure: editbuffer_destroy ID:1 + Author: Chris Watford watford@uiuc.edu + Purpose: Destroys an edit buffer + Input: + Output: + Errors: +------------------------------------------------------------------------*/ +void editbuffer_destroy(EditBuffer* edBuf) +{ + // sanity checks + if(edBuf == NULL) + { // nothing to do + return; + } else if(edBuf->Lines != NULL) { + LineList* lastline = NULL; + + // loop through each line free'ing its text + for( ; edBuf->Lines != NULL; edBuf->Lines = edBuf->Lines->Next) + { + if(edBuf->Lines->Text != NULL) + free(edBuf->Lines->Text); + + // if there was a line before us, free it + if(lastline != NULL) + { + free(lastline); + lastline = NULL; + } + + lastline = edBuf->Lines; + } + + // free the last line + free(lastline); + } + + // free ourself + free(edBuf); +} + +/*------------------------------------------------------------------------ + Procedure: editbuffer_new ID:1 + Author: Chris Watford watford@uiuc.edu + Purpose: Creates an edit buffer + Input: + Output: + Errors: +-------------------------------------------------------------------------- + Edit History: + 06 Oct 2003 - Chris Watford watford@uiuc.edu + - Added isCorrect flag +------------------------------------------------------------------------*/ +EditBuffer* editbuffer_new(void) +{ + // create a new one + EditBuffer *edBuf = (EditBuffer*)SafeMalloc(sizeof(EditBuffer)); + + // default vals + edBuf->LineCount = 0; + edBuf->Lines = NULL; + edBuf->isCorrect = FALSE; + + // return it + return edBuf; +} diff --git a/win32caml/editbuffer.h b/win32caml/editbuffer.h new file mode 100644 index 000000000..91e2999c3 --- /dev/null +++ b/win32caml/editbuffer.h @@ -0,0 +1,47 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Jacob Navia, after Xavier Leroy */ +/* */ +/* Copyright 2001 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. */ +/* */ +/***********************************************************************/ + +/***********************************************************************/ +/* Changes made by Chris Watford to enhance the source editor */ +/* Began 14 Sept 2003 - watford@uiuc.edu */ +/***********************************************************************/ + +#ifndef _EDITBUFFER_H_ +#define _EDITBUFFER_H_ + +// All the below was added by Chris Watford watford@uiuc.edu + +typedef struct tagLineList { + struct tagLineList *Next; + struct tagLineList *Prev; + char *Text; +} LineList; + +typedef struct tagEditBuffer { + int LineCount; + struct tagLineList *Lines; + BOOL isCorrect; +} EditBuffer; + +BOOL editbuffer_addline (EditBuffer* edBuf, char* line); +BOOL editbuffer_updateline (EditBuffer* edBuf, int idx, char* line); +BOOL editbuffer_updateoraddline (EditBuffer* edBuf, int idx, char* line); +BOOL editbuffer_removeline (EditBuffer* edBuf, int idx); +char* editbuffer_getasline (EditBuffer* edBuf); +char* editbuffer_getasbuffer (EditBuffer* edBuf); +char* editbuffer_lastline (EditBuffer* edBuf); +EditBuffer* editbuffer_copy (EditBuffer* edBuf); +void editbuffer_destroy (EditBuffer* edBuf); +EditBuffer* editbuffer_new (void); + +#endif diff --git a/win32caml/history.c b/win32caml/history.c new file mode 100644 index 000000000..11397ac66 --- /dev/null +++ b/win32caml/history.c @@ -0,0 +1,98 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Jacob Navia, after Xavier Leroy */ +/* */ +/* Copyright 2001 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. */ +/* */ +/***********************************************************************/ + +/***********************************************************************/ +/* Changes made by Chris Watford to enhance the source editor */ +/* Began 14 Sept 2003 - watford@uiuc.edu */ +/***********************************************************************/ + +#include "inria.h" +#include "history.h" + +/*------------------------------------------------------------------------ +Procedure: AddToHistory ID:2 +Author: Chris Watford watford@uiuc.edu +Purpose: Adds an edit buffer to the history control +Input: Pointer to the edit buffer to add +Output: +Errors: +-------------------------------------------------------------------------- +Edit History: + 15 Sept 2003 - Chris Watford watford@uiuc.edu + - Complete rewrite + - Got it to add the edit buffer to the history + 17 Sept 2003 - Chris Watford watford@uiuc.edu + - Added doubly link list support +------------------------------------------------------------------------*/ +void AddToHistory(EditBuffer *edBuf) +{ + StatementHistory *newLine; + + // sanity checks + if(edBuf == NULL) + { + return; + } else if (edBuf->LineCount == 0 || edBuf->Lines == NULL) { + // fix any possible errors that may come from this + edBuf->LineCount = 0; + edBuf->Lines = NULL; + return; + } + + // setup newline and add as the front of the linked list + newLine = SafeMalloc(sizeof(StatementHistory)); + newLine->Next = History; + newLine->Prev = NULL; + newLine->Statement = edBuf; + + // setup back linking + if(History != NULL) + History->Prev = newLine; + + // set the history up + History = newLine; + + // search for the new history tail + for(HistoryTail = (HistoryTail != NULL ? HistoryTail : History); HistoryTail->Next != NULL; HistoryTail = HistoryTail->Next); +} + +/*------------------------------------------------------------------------ +Procedure: GetHistoryLine ID:2 +Author: Chris Watford watford@uiuc.edu +Purpose: Returns an entry from the history table +Input: Index of the history entry to return +Output: The history entry as a single line +Errors: +-------------------------------------------------------------------------- +Edit History: + 15 Sept 2003 - Chris Watford watford@uiuc.edu + - Complete rewrite + 17 Sept 2003 - Chris Watford watford@uiuc.edu + - Added doubly link list support +------------------------------------------------------------------------*/ +char *GetHistoryLine(int n) +{ + StatementHistory *histentry = History; + int i; + + // traverse linked list looking for member n + for (i = 0; ((i < n) && (histentry != NULL)); i++, histentry = histentry->Next); + + // figure out what to return + if (histentry != NULL) + { + return editbuffer_getasline(histentry->Statement); + } else { + return ""; + } +} diff --git a/win32caml/history.h b/win32caml/history.h new file mode 100644 index 000000000..a9ba85841 --- /dev/null +++ b/win32caml/history.h @@ -0,0 +1,35 @@ +/***********************************************************************/ +/* */ +/* Objective Caml */ +/* */ +/* Jacob Navia, after Xavier Leroy */ +/* */ +/* Copyright 2001 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. */ +/* */ +/***********************************************************************/ + +/***********************************************************************/ +/* Changes made by Chris Watford to enhance the source editor */ +/* Began 14 Sept 2003 - watford@uiuc.edu */ +/***********************************************************************/ + +#ifndef _HISTORY_H_ +#define _HISTORY_H_ + +#include "editbuffer.h" + +// Simple linked list for holding the history lines +typedef struct tagStatementHistory { + struct tagStatementHistory *Next; + struct tagStatementHistory *Prev; + EditBuffer *Statement; +} StatementHistory; + +void AddToHistory (EditBuffer *edBuf); +char *GetHistoryLine (int n); +static BOOL CALLBACK HistoryDlgProc(HWND hDlg, UINT message, WPARAM wParam, LPARAM lParam); + +#endif diff --git a/win32caml/resource.h b/win32caml/resource.h new file mode 100644 index 000000000..67625979c --- /dev/null +++ b/win32caml/resource.h @@ -0,0 +1,16 @@ +//{{NO_DEPENDENCIES}} +// Microsoft Visual C++ generated include file. +// Used by ocaml.rc +// + +// Next default values for new objects +// +#ifdef APSTUDIO_INVOKED +#ifndef APSTUDIO_READONLY_SYMBOLS +#define _APS_NO_MFC 1 +#define _APS_NEXT_RESOURCE_VALUE 101 +#define _APS_NEXT_COMMAND_VALUE 40001 +#define _APS_NEXT_CONTROL_VALUE 1000 +#define _APS_NEXT_SYMED_VALUE 101 +#endif +#endif diff --git a/win32caml/startocaml.c b/win32caml/startocaml.c index 578d407cb..491fab8ca 100644 --- a/win32caml/startocaml.c +++ b/win32caml/startocaml.c @@ -22,7 +22,7 @@ #include <io.h> #include <direct.h> #include "inria.h" -extern int _get_osfhandle(int); + PROCESS_INFORMATION pi; #define BUFSIZE 4096 STARTUPINFO startInfo; @@ -222,8 +222,9 @@ Output: None visible Errors: If any system call for whatever reason fails, the thread will exit. No error message is shown. ------------------------------------------------------------------------*/ -int _stdcall DoStartOcaml(HWND hwndParent) +DWORD WINAPI DoStartOcaml(LPVOID param) { + HWND hwndParent = (HWND) param; char *cmdline; int processStarted; LPSECURITY_ATTRIBUTES lpsa=NULL; @@ -364,7 +365,7 @@ void InterruptOcaml(void) { if (!GenerateConsoleCtrlEvent(CTRL_BREAK_EVENT, pi.dwProcessId)) { char message[1024]; - sprintf(message, "GenerateConsole failed: %d\n", GetLastError()); + sprintf(message, "GenerateConsole failed: %lu\n", GetLastError()); MessageBox(NULL, message, "Ocaml", MB_OK); } WriteToPipe(" "); |