Ekdohibs
/
ocaml
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Fusion des modifs faites sur la branche release jusqu'a la release 3.08.0 

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@6553 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
master
Xavier Leroy 2004-07-13 12:25:21 +00:00
parent 237006931a
commit 63c1789b5e
95 changed files with 9538 additions and 774 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

0
camlp4/unmaintained/format/.depend Normal file
View File

61
camlp4/unmaintained/format/Makefile Normal file
View File

@ -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

15
camlp4/unmaintained/format/README Normal file
View File

@ -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

52
camlp4/unmaintained/format/pa_format.ml Normal file
View File

@ -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;

0
camlp4/unmaintained/lefteval/.depend Normal file
View File

61
camlp4/unmaintained/lefteval/Makefile Normal file
View File

@ -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

15
camlp4/unmaintained/lefteval/README Normal file
View File

@ -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

241
camlp4/unmaintained/lefteval/pa_lefteval.ml Normal file
View File

@ -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;

59
camlp4/unmaintained/ocamllex/Makefile Normal file
View File

@ -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 $<

15
camlp4/unmaintained/ocamllex/README Normal file
View File

@ -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

356
camlp4/unmaintained/ocamllex/pa_ocamllex.ml Normal file
View File

@ -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."

0
camlp4/unmaintained/olabl/.depend Normal file
View File

61
camlp4/unmaintained/olabl/Makefile Normal file
View File

@ -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

15
camlp4/unmaintained/olabl/README Normal file
View File

@ -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

2022
camlp4/unmaintained/olabl/pa_olabl.ml Normal file
View File

File diff suppressed because it is too large Load Diff

0
camlp4/unmaintained/scheme/.depend Normal file
View File

85
camlp4/unmaintained/scheme/Makefile Normal file
View File

@ -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

15
camlp4/unmaintained/scheme/README Normal file
View File

@ -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

1093
camlp4/unmaintained/scheme/pa_scheme.ml Normal file
View File

File diff suppressed because it is too large Load Diff

1030
camlp4/unmaintained/scheme/pa_scheme.sc Normal file
View File

File diff suppressed because it is too large Load Diff

826
camlp4/unmaintained/scheme/pr_scheme.ml Normal file
View File

@ -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.";

132
camlp4/unmaintained/scheme/pr_schp_main.ml Normal file
View File

@ -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) ];

0
camlp4/unmaintained/sml/.depend Normal file
View File

68
camlp4/unmaintained/sml/Makefile Normal file
View File

@ -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

15
camlp4/unmaintained/sml/README Normal file
View File

@ -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

952
camlp4/unmaintained/sml/pa_sml.ml Normal file
View File

@ -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";

395
camlp4/unmaintained/sml/smllib.sml Normal file
View File

@ -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

2
debugger/.depend
View File

@ -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

4
lex/.depend
View File

@ -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

5
man/ocamlc.m
View File

@ -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

9
man/ocamldoc.m
View File

@ -300,6 +300,13 @@ Use
.I title
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

3
man/ocamlopt.m
View File

@ -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

2
man/ocamlprof.m
View File

@ -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

28
ocamldoc/.depend
View File

@ -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

122
ocamldoc/Changes.txt
View File

@ -1,66 +1,72 @@
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
ocamldocdescription environment
OK - 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
type definitions, and aournd arguments of exceptions in exception definitions.
OK - 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
name rather than their fully qualified name
OK - 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
(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
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
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
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
( ]} 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.
=====
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
- fix: when generating separated files in latex, generate them in
the same directory than the main file, (the one specified by -o)
- 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.
- fix: blank lines in verbatim, latex, code pre, code and ele ref modes
are now accepted
- fix: html generator: included module names were displayed with their simple
name rather than their fully qualified name
- fix: use a formatter from a buffer rather Format.str_formatter in
Odoc_mist.sting_of_module_type, to avoid too much blanks
- 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
- 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)
- 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)
- 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
- 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)
- 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
======
Release 3.05 :

11
ocamldoc/ocamldoc.hva
View File

@ -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}

4
ocamldoc/odoc.ml
View File

@ -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))

24
ocamldoc/odoc_args.ml
View File

@ -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 ;

1
ocamldoc/odoc_html.ml
View File

@ -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 ;

22
ocamldoc/odoc_latex.ml
View File

@ -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"
)
]

208
ocamldoc/odoc_messages.ml
View File

@ -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 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 = " 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 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 man_mini = " Generate man pages only for modules, module types,\n"^
" classes and class types "^man_only
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 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 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 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 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 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 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 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 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 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 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 default_latex_type_prefix = "type:"
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>\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>\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>\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>\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>\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>\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>\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)

87
ocamldoc/odoc_module.ml
View File

@ -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

13
ocamldoc/odoc_sig.ml
View File

@ -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 ->
(

25
ocamldoc/odoc_texi.ml
View File

@ -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"

2
ocamldoc/odoc_to_text.ml
View File

@ -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. *)

13
ocamldoc/odoc_value.ml
View File

@ -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

11
otherlibs/labltk/browser/searchpos.ml
View File

@ -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

2
otherlibs/labltk/camltk/Makefile.gen
View File

@ -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'; \

2
otherlibs/labltk/labltk/Makefile.gen
View File

@ -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

1
otherlibs/labltk/support/Makefile.common
View File

@ -24,3 +24,4 @@ COMPFLAGS=
LINKFLAGS=
CAMLOPTLIBR=$(CAMLOPT) -a
MKLIB=$(CAMLRUN) $(TOPDIR)/tools/ocamlmklib
CAMLRUNGEN=../../boot/ocamlrun

73
otherlibs/systhreads/posix.c
View File

@ -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
}

14
otherlibs/threads/pervasives.ml
View File

@ -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 *)

2
otherlibs/threads/thread.mli
View File

@ -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

1
otherlibs/threads/threadUnix.ml
View File

@ -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

1
otherlibs/threads/threadUnix.mli
View File

@ -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} *)

13
otherlibs/threads/unix.ml
View File

@ -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

550
otherlibs/unix/.depend
View File

@ -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 \
../../byterun/minor_gc.h unixsupport.h
dup2.o: dup2.c ../../byterun/config.h ../../config/m.h ../../config/s.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
dup.o: dup.c ../../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 \
../../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 \
../../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 \
../../byterun/misc.h unixsupport.h
fchmod.o: fchmod.c ../../byterun/config.h ../../config/m.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
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 \
../../byterun/misc.h unixsupport.h
fork.o: fork.c ../../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 \
../../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 \
../../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 \
../../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 \
../../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 \
../../byterun/minor_gc.h unixsupport.h
kill.o: kill.c ../../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 \
../../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 \
../../byterun/misc.h unixsupport.h
lseek.o: lseek.c ../../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 \
../../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 \
../../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 \
../../config/s.h ../../byterun/misc.h unixsupport.h
pipe.o: pipe.c ../../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 \
../../config/s.h ../../byterun/misc.h unixsupport.h
rmdir.o: rmdir.c ../../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 \
../../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 \
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
sleep.o: sleep.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
socketaddr.o: socketaddr.c ../../byterun/config.h ../../config/m.h \
../../config/s.h ../../byterun/misc.h ../../byterun/gc.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/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 socketaddr.h
socket.o: socket.c ../../byterun/config.h ../../config/m.h \
../../byterun/minor_gc.h unixsupport.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
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/mlvalues.h ../../byterun/compatibility.h \
../../byterun/config.h ../../config/m.h ../../config/s.h \
../../byterun/misc.h unixsupport.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
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
socketpair.o: socketpair.c ../../byterun/config.h ../../config/m.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
sockopt.o: sockopt.c ../../byterun/config.h ../../config/m.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/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
stat.o: stat.c ../../byterun/config.h ../../config/m.h ../../config/s.h \
../../byterun/misc.h ../../byterun/gc.h ../../byterun/major_gc.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/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/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/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
listen.o: listen.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
../../byterun/config.h ../../config/m.h ../../config/s.h \
../../byterun/misc.h unixsupport.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
mkfifo.o: mkfifo.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
../../byterun/config.h ../../config/m.h ../../config/s.h \
../../byterun/misc.h unixsupport.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
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
rewinddir.o: rewinddir.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/mlvalues.h ../../byterun/compatibility.h \
../../byterun/config.h ../../config/m.h ../../config/s.h \
../../byterun/misc.h unixsupport.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
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
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 \
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 \
../../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 \
../../byterun/misc.h unixsupport.h
unixsupport.o: unixsupport.c ../../byterun/config.h ../../config/m.h \
../../config/s.h ../../byterun/misc.h ../../byterun/gc.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 cst2constr.h
unlink.o: unlink.c ../../byterun/config.h ../../config/m.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
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
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
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
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 ../../byterun/fail.h unixsupport.h \
cst2constr.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
utimes.o: utimes.c ../../byterun/mlvalues.h ../../byterun/compatibility.h \
../../byterun/config.h ../../config/m.h ../../config/s.h \
../../byterun/misc.h unixsupport.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 ../../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

8
otherlibs/unix/unix.ml
View File

@ -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"

8
otherlibs/unix/unix.mli
View File

@ -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} *)

10
otherlibs/unix/unixLabels.mli
View File

@ -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} *)

31
otherlibs/unix/write.c
View File

@ -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);
}

2
otherlibs/win32graph/Makefile.nt
View File

@ -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)

154
otherlibs/win32graph/draw.c
View File

@ -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;

200
otherlibs/win32graph/events.c Executable file
View File

@ -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);
}

12
otherlibs/win32graph/libgraph.h
View File

@ -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);

66
otherlibs/win32graph/open.c
View File

@ -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;
}

20
otherlibs/win32unix/rename.c
View File

@ -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);
}

6
otherlibs/win32unix/unix.ml
View File

@ -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 *)

41
otherlibs/win32unix/write.c
View File

@ -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);
}

16
stdlib/.depend
View File

@ -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

16
stdlib/Compflags
View File

@ -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

2
stdlib/arg.ml
View File

@ -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" ->

36
stdlib/format.ml
View File

@ -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;;

13
stdlib/format.mli
View File

@ -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. *)

14
stdlib/pervasives.ml
View File

@ -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 *)

19
stdlib/pervasives.mli
View File

@ -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

7
stdlib/scanf.ml
View File

@ -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 =

3
stdlib/stdLabels.mli
View File

@ -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 :

8
stdlib/stringLabels.mli
View File

@ -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}. *)
(**/**)

2
stdlib/sys.ml
View File

@ -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)";;

18
test/Moretest/tscanf.ml
View File

@ -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

4
tools/.depend
View File

@ -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 \

2
tools/ocamlmklib.mlp
View File

@ -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

16
toplevel/topdirs.ml
View File

@ -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

1
typing/ctype.ml
View File

@ -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 ****)

10
typing/printtyp.ml
View File

@ -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

2
typing/typecore.ml
View File

@ -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

6
utils/misc.ml
View File

@ -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

3
utils/misc.mli
View File

@ -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

514
win32caml/editbuffer.c Normal file
View File

@ -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;
}

47
win32caml/editbuffer.h Normal file
View File

@ -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

98
win32caml/history.c Normal file
View File

@ -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 "";
}
}

35
win32caml/history.h Normal file
View File

@ -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

16
win32caml/resource.h Normal file
View File

@ -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

7
win32caml/startocaml.c
View File

@ -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(" ");