diff --git a/Makefile b/Makefile index 1f94ad5..647b163 100644 --- a/Makefile +++ b/Makefile @@ -96,6 +96,7 @@ $(BOOT)/stdlib: $(OCAMLSRC)/stdlib $(CONFIG) $(GENERATED) patches/compflags.patc awk -f $(BOOT)/stdlib/expand_module_aliases.awk < $(BOOT)/stdlib/stdlib.mli > $(BOOT)/stdlib/stdlib.pp.mli awk -f $(BOOT)/stdlib/expand_module_aliases.awk < $(BOOT)/stdlib/stdlib.ml > $(BOOT)/stdlib/stdlib.pp.ml cp $(OCAMLSRC)/asmrun/libasmrun.a $(BOOT)/stdlib/ + cp Makefile.stdlib $(BOOT)/stdlib/Makefile COPY_TARGETS=\ $(BOOT)/bytecomp \ @@ -108,6 +109,7 @@ COPY_TARGETS=\ .PHONY: copy copy: $(COPY_TARGETS) + cp Makefile.ocamlc $(BOOT)/Makefile .PHONY: ocamlrun ocamlrun: $(OCAMLRUN) @@ -115,9 +117,11 @@ ocamlrun: $(OCAMLRUN) $(BOOT)/ocamlc: $(COPY_TARGETS) make -C $(OCAMLSRC)/yacc all make -C miniml/interp interpopt.opt - cd $(BOOT)/stdlib && ../../timed.sh ../../compile_stdlib.sh + ./timed.sh make -C _boot/stdlib all + # cd $(BOOT)/stdlib && ../../timed.sh ../../compile_stdlib.sh mkdir -p $(BOOT)/compilerlibs - cd $(BOOT) && ../timed.sh ../compile_ocamlc.sh + ./timed.sh make -C _boot all + # cd $(BOOT) && ../timed.sh ../compile_ocamlc.sh .PHONY: test-compiler test-compiler: $(OCAMLRUN) diff --git a/Makefile.ocamlc b/Makefile.ocamlc new file mode 100644 index 0000000..9be9790 --- /dev/null +++ b/Makefile.ocamlc @@ -0,0 +1,120 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +#* * +#* Copyright 1999 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +COMPILER=../miniml/interp/interp.opt -g -nostdlib -I stdlib +INCLUDES=-I utils -I parsing -I typing -I bytecomp -I driver + +COMPFLAGS=-strict-sequence -principal -absname -w +a-4-9-41-42-44-45-48 \ + -warn-error A \ + -bin-annot -safe-string -strict-formats $(INCLUDES) +LINKFLAGS= + +DEPEND=../miniml/interp/depend.sh +DEPFLAGS=$(INCLUDES) + +UTILS=utils/config.cmx utils/misc.cmx \ + utils/identifiable.cmx utils/numbers.cmx utils/arg_helper.cmx \ + utils/clflags.cmx utils/tbl.cmx utils/profile.cmx \ + utils/terminfo.cmx utils/ccomp.cmx utils/warnings.cmx \ + utils/consistbl.cmx \ + utils/strongly_connected_components.cmx \ + utils/build_path_prefix_map.cmx \ + utils/targetint.cmx + +PARSING=parsing/location.cmx parsing/longident.cmx \ + parsing/docstrings.cmx parsing/syntaxerr.cmx \ + parsing/ast_helper.cmx parsing/parser.cmx \ + parsing/lexer.cmx parsing/parse.cmx parsing/printast.cmx \ + parsing/pprintast.cmx \ + parsing/ast_mapper.cmx parsing/ast_iterator.cmx parsing/attr_helper.cmx \ + parsing/builtin_attributes.cmx parsing/ast_invariants.cmx parsing/depend.cmx + +TYPING=typing/ident.cmx typing/path.cmx \ + typing/primitive.cmx typing/types.cmx \ + typing/btype.cmx typing/oprint.cmx \ + typing/subst.cmx typing/predef.cmx \ + typing/datarepr.cmx typing/cmi_format.cmx typing/env.cmx \ + typing/typedtree.cmx typing/printtyped.cmx typing/ctype.cmx \ + typing/printtyp.cmx typing/includeclass.cmx \ + typing/mtype.cmx typing/envaux.cmx typing/includecore.cmx \ + typing/typedtreeIter.cmx typing/typedtreeMap.cmx \ + typing/tast_mapper.cmx \ + typing/cmt_format.cmx typing/untypeast.cmx \ + typing/includemod.cmx typing/typetexp.cmx typing/printpat.cmx \ + typing/parmatch.cmx typing/stypes.cmx typing/typedecl.cmx typing/typeopt.cmx \ + typing/typecore.cmx typing/typeclass.cmx typing/typemod.cmx + +COMP=bytecomp/lambda.cmx bytecomp/printlambda.cmx \ + bytecomp/semantics_of_primitives.cmx \ + bytecomp/switch.cmx bytecomp/matching.cmx \ + bytecomp/translobj.cmx bytecomp/translattribute.cmx \ + bytecomp/translprim.cmx bytecomp/translcore.cmx \ + bytecomp/translclass.cmx bytecomp/translmod.cmx \ + bytecomp/simplif.cmx bytecomp/runtimedef.cmx \ + bytecomp/meta.cmx bytecomp/opcodes.cmx \ + bytecomp/bytesections.cmx bytecomp/dll.cmx \ + bytecomp/symtable.cmx \ + driver/pparse.cmx driver/main_args.cmx \ + driver/compenv.cmx driver/compmisc.cmx \ + driver/compdynlink.cmx driver/compplugin.cmx driver/makedepend.cmx + +COMMON=$(UTILS) $(PARSING) $(TYPING) $(COMP) + +BYTECOMP=bytecomp/instruct.cmx bytecomp/bytegen.cmx \ + bytecomp/printinstr.cmx bytecomp/emitcode.cmx \ + bytecomp/bytelink.cmx bytecomp/bytelibrarian.cmx bytecomp/bytepackager.cmx \ + driver/errors.cmx driver/compile.cmx + +BYTESTART=driver/main.cmx + +all: ocamlc + +# Shared parts of the system compiled with the native-code compiler + +compilerlibs/ocamlcommon.cmxa: $(COMMON) + $(COMPILER) -a -linkall -o $@ $^ + +# The bytecode compiler compiled with the native-code compiler + +compilerlibs/ocamlbytecomp.cmxa: $(BYTECOMP) + $(COMPILER) -a -o $@ $^ + +ocamlc: compilerlibs/ocamlcommon.cmxa compilerlibs/ocamlbytecomp.cmxa \ + $(BYTESTART) + $(COMPILER) $(LINKFLAGS) -o $@ $^ -cclib "$(BYTECCLIBS)" + +# Compiler Plugins + +driver/compdynlink.cmx: driver/compdynlink.mlno driver/compdynlink.cmi + $(COMPILER) $(COMPFLAGS) -c -impl $< + +# Default rules + +.SUFFIXES: .ml .mli .cmi .cmx + +.mli.cmi: + $(COMPILER) $(COMPFLAGS) -c $< + +.ml.cmx: + $(COMPILER) $(COMPFLAGS) -c $< + +.PHONY: depend +depend: + (for d in utils parsing typing bytecomp driver; \ + do $(DEPEND) $(DEPFLAGS) $$d/*.mli $$d/*.ml || exit; \ + done) > .depend + $(DEPEND) $(DEPFLAGS) -impl driver/compdynlink.mlno >> .depend + +include .depend diff --git a/Makefile.stdlib b/Makefile.stdlib new file mode 100644 index 0000000..1ab9a25 --- /dev/null +++ b/Makefile.stdlib @@ -0,0 +1,98 @@ +#************************************************************************** +#* * +#* OCaml * +#* * +#* Xavier Leroy, projet Cristal, INRIA Rocquencourt * +#* * +#* Copyright 1999 Institut National de Recherche en Informatique et * +#* en Automatique. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +CAMLRUN = ../../ocaml-src/byterun/ocamlrun +TARGET_BINDIR ?= $(BINDIR) + +COMPFLAGS=-strict-sequence -absname -w +a-4-9-41-42-44-45-48 \ + -g -warn-error A -bin-annot -nostdlib \ + -safe-string -strict-formats +COMPILER=../../miniml/interp/interp.opt +DEPEND=../../miniml/interp/depend.sh -native + +# Object file prefix +P=stdlib__ + +OBJS=camlinternalFormatBasics.cmx stdlib.cmx $(OTHERS) +OTHERS=$(P)seq.cmx $(P)char.cmx $(P)uchar.cmx $(P)sys.cmx $(P)list.cmx \ + $(P)bytes.cmx $(P)string.cmx \ + $(P)sort.cmx $(P)marshal.cmx $(P)obj.cmx $(P)float.cmx $(P)array.cmx \ + $(P)int32.cmx $(P)int64.cmx $(P)nativeint.cmx \ + $(P)lexing.cmx $(P)parsing.cmx \ + $(P)set.cmx $(P)map.cmx $(P)stack.cmx $(P)queue.cmx \ + camlinternalLazy.cmx $(P)lazy.cmx $(P)stream.cmx \ + $(P)buffer.cmx camlinternalFormat.cmx $(P)printf.cmx \ + $(P)arg.cmx $(P)printexc.cmx $(P)gc.cmx \ + $(P)digest.cmx $(P)random.cmx $(P)hashtbl.cmx $(P)weak.cmx \ + $(P)format.cmx $(P)scanf.cmx $(P)callback.cmx \ + camlinternalOO.cmx $(P)oo.cmx camlinternalMod.cmx \ + $(P)genlex.cmx $(P)ephemeron.cmx \ + $(P)filename.cmx $(P)complex.cmx \ + $(P)arrayLabels.cmx $(P)listLabels.cmx $(P)bytesLabels.cmx \ + $(P)stringLabels.cmx $(P)moreLabels.cmx $(P)stdLabels.cmx \ + $(P)spacetime.cmx $(P)bigarray.cmx + +PREFIXED_OBJS=$(filter stdlib__%.cmx,$(OBJS)) + +all: stdlib.cmxa std_exit.cmx + +stdlib.cmxa: $(OBJS) + $(COMPILER) -a -o $@ $^ + +.SUFFIXES: .mli .ml .cmi .cmx + +stdlib.cmi: stdlib.pp.mli + $(COMPILER) $(COMPFLAGS) $(shell ./Compflags $@) -o $@ -c $< + +stdlib.cmx: stdlib.pp.ml + $(COMPILER) $(COMPFLAGS) $(shell ./Compflags $@) -o $@ -c $< + +%.cmi: %.mli + $(COMPILER) $(COMPFLAGS) $(shell ./Compflags $@) -c $< + +stdlib__%.cmi: %.mli + $(COMPILER) $(COMPFLAGS) $(shell ./Compflags $@) -o $@ -c $< + +%.cmx: %.ml + $(COMPILER) $(COMPFLAGS) $(shell ./Compflags $@) -c $< + +stdlib__%.cmx: %.ml + $(COMPILER) $(COMPFLAGS) $(shell ./Compflags $@) -o $@ -c $< + + +# Dependencies on Stdlib (not tracked by ocamldep) +$(OTHERS:.cmx=.cmi) std_exit.cmi: stdlib.cmi +$(OBJS) std_exit.cmx: stdlib.cmi +$(OTHERS) std_exit.cmx: stdlib.cmx + +clean:: + rm -f *.cm* *.o *.a + rm -f *~ + +include .depend + +EMPTY := +SPACE := $(EMPTY) $(EMPTY) + +.PHONY: depend +depend: + $(DEPEND) $(filter-out stdlib.%,$(wildcard *.mli *.ml)) \ + > .depend.tmp + echo "stdlib.cmi : camlinternalFormatBasics.cmi" >> .depend.tmp + echo "stdlib.cmx : camlinternalFormatBasics.cmx" >> .depend.tmp + sed -Ee \ + 's#(^| )(${subst ${SPACE},|,${PREFIXED_OBJS:stdlib__%.cmx=%}})[.]#\1stdlib__\2.#g' \ + .depend.tmp > .depend + rm -f .depend.tmp diff --git a/miniml/interp/Makefile b/miniml/interp/Makefile index 2bbe7e9..5cd9d1c 100644 --- a/miniml/interp/Makefile +++ b/miniml/interp/Makefile @@ -7,9 +7,11 @@ OCAMLLEX=../../ocaml-src/byterun/ocamlrun ../../ocaml-src/boot/ocamllex OCAMLYACC=../../ocaml-src/yacc/ocamlyacc COMMONOBJS=int32.ml int64.ml nativeint.ml seq.ml char.ml bytes.ml string.ml digest.ml marshal.ml array.ml list.ml stack.ml hashtbl.ml map.ml set.ml buffer.ml format.ml printf.ml arg.ml gc.ml filename.ml lexing.ml parsing.ml -INTERPOBJS=$(COMMONOBJS) misc.ml clflags.ml location.ml asttypes.mli warnings.ml syntaxerr.ml longident.ml parsetree.mli docstrings.ml ast_helper.ml parser.ml lexer.ml parse.ml ../../interpreter/conf.ml ../../interpreter/data.ml ../../interpreter/envir.ml ../../interpreter/runtime_lib.ml ../../interpreter/runtime_base.ml ../../interpreter/eval.ml ../../interpreter/runtime_stdlib.ml ../../interpreter/runtime_compiler.ml ../../interpreter/primitives.ml ../../interpreter/interp.ml +PARSEOBJS=misc.ml clflags.ml location.ml asttypes.mli warnings.ml syntaxerr.ml longident.ml parsetree.mli docstrings.ml ast_helper.ml parser.ml lexer.ml parse.ml +INTERPOBJS=$(COMMONOBJS) $(PARSEOBJS) ../../interpreter/conf.ml ../../interpreter/data.ml ../../interpreter/envir.ml ../../interpreter/runtime_lib.ml ../../interpreter/runtime_base.ml ../../interpreter/eval.ml ../../interpreter/runtime_stdlib.ml ../../interpreter/runtime_compiler.ml ../../interpreter/primitives.ml ../../interpreter/interp.ml LEXOBJS1=../../ocaml-src/lex/cset.ml ../../ocaml-src/lex/syntax.ml ../../ocaml-src/lex/parser.ml LEXOBJS2=../../ocaml-src/lex/table.ml ../../ocaml-src/lex/lexgen.ml ../../ocaml-src/lex/compact.ml ../../ocaml-src/lex/common.ml ../../ocaml-src/lex/output.ml ../../ocaml-src/lex/outputbis.ml ../../ocaml-src/lex/main.ml +DEPENDOBJS=$(COMMONOBJS) $(PARSEOBJS) depend.ml makedepend.ml LEXBOOTOBJS=$(COMMONOBJS) $(LEXOBJS1) ../../lex/lexer.ml $(LEXOBJS2) LEXOBJS=$(COMMONOBJS) $(LEXOBJS1) lex/lexer.ml $(LEXOBJS2) @@ -41,6 +43,9 @@ cvt_emit.byte: $(COMMONOBJS) cvt_emit.ml interp.byte: $(INTERPOBJS) $(MINIML) $(INTERPOBJS) -o $@ +makedepend.byte: $(DEPENDOBJS) + $(MINIML) $(DEPENDOBJS) -o $@ + interpopt.opt: $(INTERPOBJS) interp.byte ./genfileopt.sh @echo "Compiling interpopt.opt, this make take a while..." diff --git a/miniml/interp/clflags.ml b/miniml/interp/clflags.ml index 5507a2b..0d66908 100644 --- a/miniml/interp/clflags.ml +++ b/miniml/interp/clflags.ml @@ -1,2 +1,3 @@ let fast = ref false let applicative_functors = ref true +let transparent_modules = ref false diff --git a/miniml/interp/depend.ml b/miniml/interp/depend.ml new file mode 100644 index 0000000..e82a530 --- /dev/null +++ b/miniml/interp/depend.ml @@ -0,0 +1,514 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Asttypes +open Location +open Longident +open Parsetree + +let pp_deps = ref [] + +module StringSet = Set.Make(struct type t = string let compare = compare end) +module StringMap = Map.Make(String) + +(* Module resolution map *) +(* Node (set of imports for this path, map for submodules) *) +type map_tree = Node of StringSet.t * bound_map +and bound_map = map_tree StringMap.t +let bound = Node (StringSet.empty, StringMap.empty) + +(*let get_free (Node (s, _m)) = s*) +let get_map (Node (_s, m)) = m +let make_leaf s = Node (StringSet.singleton s, StringMap.empty) +let make_node m = Node (StringSet.empty, m) +let rec weaken_map s (Node(s0,m0)) = + Node (StringSet.union s s0, StringMap.map (weaken_map s) m0) +let rec collect_free (Node (s, m)) = + StringMap.fold (fun _ n -> StringSet.union (collect_free n)) m s + +(* Returns the imports required to access the structure at path p *) +(* Only raises Not_found if the head of p is not in the toplevel map *) +let rec lookup_free p m = + match p with + [] -> raise Not_found + | s::p -> + let Node (f, m') = StringMap.find s m in + try lookup_free p m' with Not_found -> f + +(* Returns the node corresponding to the structure at path p *) +let rec lookup_map lid m = + match lid with + Lident s -> StringMap.find s m + | Ldot (l, s) -> StringMap.find s (get_map (lookup_map l m)) + | Lapply _ -> raise Not_found + +(* Collect free module identifiers in the a.s.t. *) + +let free_structure_names = ref StringSet.empty + +let add_names s = + free_structure_names := StringSet.union s !free_structure_names + +let rec add_path bv ?(p=[]) = function + | Lident s -> + let free = + try lookup_free (s::p) bv with Not_found -> StringSet.singleton s + in + (*StringSet.iter (fun s -> Printf.eprintf "%s " s) free; + prerr_endline "";*) + add_names free + | Ldot(l, s) -> add_path bv ~p:(s::p) l + | Lapply(l1, l2) -> add_path bv l1; add_path bv l2 + +let open_module bv lid = + match lookup_map lid bv with + | Node (s, m) -> + add_names s; + StringMap.fold StringMap.add m bv + | exception Not_found -> + add_path bv lid; bv + +let add_parent bv lid = + match lid.txt with + Ldot(l, _s) -> add_path bv l + | _ -> () + +let add = add_parent + +let add_module_path bv lid = add_path bv lid.txt + +let handle_extension ext = () + +let rec add_type bv ty = + match ty.ptyp_desc with + Ptyp_any -> () + | Ptyp_var _ -> () + | Ptyp_arrow(_, t1, t2) -> add_type bv t1; add_type bv t2 + | Ptyp_tuple tl -> List.iter (add_type bv) tl + | Ptyp_constr(c, tl) -> add bv c; List.iter (add_type bv) tl + | Ptyp_object (fl, _) -> + List.iter + (function Otag (_, _, t) -> add_type bv t + | Oinherit t -> add_type bv t) fl + | Ptyp_class(c, tl) -> add bv c; List.iter (add_type bv) tl + | Ptyp_alias(t, _) -> add_type bv t + | Ptyp_variant(fl, _, _) -> + List.iter + (function Rtag(_,_,_,stl) -> List.iter (add_type bv) stl + | Rinherit sty -> add_type bv sty) + fl + | Ptyp_poly(_, t) -> add_type bv t + | Ptyp_package pt -> add_package_type bv pt + | Ptyp_extension e -> handle_extension e + +and add_package_type bv (lid, l) = + add bv lid; + List.iter (add_type bv) (List.map (fun (_, e) -> e) l) + +let add_opt add_fn bv = function + None -> () + | Some x -> add_fn bv x + +let add_constructor_arguments bv = function + | Pcstr_tuple l -> List.iter (add_type bv) l + | Pcstr_record l -> List.iter (fun l -> add_type bv l.pld_type) l + +let add_constructor_decl bv pcd = + add_constructor_arguments bv pcd.pcd_args; + Misc.may (add_type bv) pcd.pcd_res + +let add_type_declaration bv td = + List.iter + (fun (ty1, ty2, _) -> add_type bv ty1; add_type bv ty2) + td.ptype_cstrs; + add_opt add_type bv td.ptype_manifest; + let add_tkind = function + Ptype_abstract -> () + | Ptype_variant cstrs -> + List.iter (add_constructor_decl bv) cstrs + | Ptype_record lbls -> + List.iter (fun pld -> add_type bv pld.pld_type) lbls + | Ptype_open -> () in + add_tkind td.ptype_kind + +let add_extension_constructor bv ext = + match ext.pext_kind with + Pext_decl(args, rty) -> + add_constructor_arguments bv args; + Misc.may (add_type bv) rty + | Pext_rebind lid -> add bv lid + +let add_type_extension bv te = + add bv te.ptyext_path; + List.iter (add_extension_constructor bv) te.ptyext_constructors + +let rec add_class_type bv cty = + match cty.pcty_desc with + Pcty_constr(l, tyl) -> + add bv l; List.iter (add_type bv) tyl + | Pcty_signature { pcsig_self = ty; pcsig_fields = fieldl } -> + add_type bv ty; + List.iter (add_class_type_field bv) fieldl + | Pcty_arrow(_, ty1, cty2) -> + add_type bv ty1; add_class_type bv cty2 + | Pcty_extension e -> handle_extension e + | Pcty_open (_ovf, m, e) -> + let bv = open_module bv m.txt in add_class_type bv e + +and add_class_type_field bv pctf = + match pctf.pctf_desc with + Pctf_inherit cty -> add_class_type bv cty + | Pctf_val(_, _, _, ty) -> add_type bv ty + | Pctf_method(_, _, _, ty) -> add_type bv ty + | Pctf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 + | Pctf_attribute _ -> () + | Pctf_extension e -> handle_extension e + +let add_class_description bv infos = + add_class_type bv infos.pci_expr + +let add_class_type_declaration = add_class_description + +let pattern_bv = ref StringMap.empty + +let rec add_pattern bv pat = + match pat.ppat_desc with + Ppat_any -> () + | Ppat_var _ -> () + | Ppat_alias(p, _) -> add_pattern bv p + | Ppat_interval _ + | Ppat_constant _ -> () + | Ppat_tuple pl -> List.iter (add_pattern bv) pl + | Ppat_construct(c, op) -> add bv c; add_opt add_pattern bv op + | Ppat_record(pl, _) -> + List.iter (fun (lbl, p) -> add bv lbl; add_pattern bv p) pl + | Ppat_array pl -> List.iter (add_pattern bv) pl + | Ppat_or(p1, p2) -> add_pattern bv p1; add_pattern bv p2 + | Ppat_constraint(p, ty) -> add_pattern bv p; add_type bv ty + | Ppat_variant(_, op) -> add_opt add_pattern bv op + | Ppat_type li -> add bv li + | Ppat_lazy p -> add_pattern bv p + | Ppat_unpack id -> pattern_bv := StringMap.add id.txt bound !pattern_bv + | Ppat_open ( m, p) -> let bv = open_module bv m.txt in add_pattern bv p + | Ppat_exception p -> add_pattern bv p + | Ppat_extension e -> handle_extension e + +let add_pattern bv pat = + pattern_bv := bv; + add_pattern bv pat; + !pattern_bv + +let rec add_expr bv exp = + match exp.pexp_desc with + Pexp_ident l -> add bv l + | Pexp_constant _ -> () + | Pexp_let(rf, pel, e) -> + let bv = add_bindings rf bv pel in add_expr bv e + | Pexp_fun (_, opte, p, e) -> + add_opt add_expr bv opte; add_expr (add_pattern bv p) e + | Pexp_function pel -> + add_cases bv pel + | Pexp_apply(e, el) -> + add_expr bv e; List.iter (fun (_,e) -> add_expr bv e) el + | Pexp_match(e, pel) -> add_expr bv e; add_cases bv pel + | Pexp_try(e, pel) -> add_expr bv e; add_cases bv pel + | Pexp_tuple el -> List.iter (add_expr bv) el + | Pexp_construct(c, opte) -> add bv c; add_opt add_expr bv opte + | Pexp_variant(_, opte) -> add_opt add_expr bv opte + | Pexp_record(lblel, opte) -> + List.iter (fun (lbl, e) -> add bv lbl; add_expr bv e) lblel; + add_opt add_expr bv opte + | Pexp_field(e, fld) -> add_expr bv e; add bv fld + | Pexp_setfield(e1, fld, e2) -> add_expr bv e1; add bv fld; add_expr bv e2 + | Pexp_array el -> List.iter (add_expr bv) el + | Pexp_ifthenelse(e1, e2, opte3) -> + add_expr bv e1; add_expr bv e2; add_opt add_expr bv opte3 + | Pexp_sequence(e1, e2) -> add_expr bv e1; add_expr bv e2 + | Pexp_while(e1, e2) -> add_expr bv e1; add_expr bv e2 + | Pexp_for( _, e1, e2, _, e3) -> + add_expr bv e1; add_expr bv e2; add_expr bv e3 + | Pexp_coerce(e1, oty2, ty3) -> + add_expr bv e1; + add_opt add_type bv oty2; + add_type bv ty3 + | Pexp_constraint(e1, ty2) -> + add_expr bv e1; + add_type bv ty2 + | Pexp_send(e, _m) -> add_expr bv e + | Pexp_new li -> add bv li + | Pexp_setinstvar(_v, e) -> add_expr bv e + | Pexp_override sel -> List.iter (fun (_s, e) -> add_expr bv e) sel + | Pexp_letmodule(id, m, e) -> + let b = add_module_binding bv m in + add_expr (StringMap.add id.txt b bv) e + | Pexp_letexception(_, e) -> add_expr bv e + | Pexp_assert (e) -> add_expr bv e + | Pexp_lazy (e) -> add_expr bv e + | Pexp_poly (e, t) -> add_expr bv e; add_opt add_type bv t + | Pexp_object { pcstr_self = pat; pcstr_fields = fieldl } -> + let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl + | Pexp_newtype (_, e) -> add_expr bv e + | Pexp_pack m -> add_module_expr bv m + | Pexp_open (_ovf, m, e) -> + let bv = open_module bv m.txt in add_expr bv e + | Pexp_extension (({ txt = ("ocaml.extension_constructor"| + "extension_constructor"); _ }, + PStr [item]) as e) -> + begin match item.pstr_desc with + | Pstr_eval ({ pexp_desc = Pexp_construct (c, None) }, _) -> add bv c + | _ -> handle_extension e + end + | Pexp_extension e -> handle_extension e + | Pexp_unreachable -> () + +and add_cases bv cases = + List.iter (add_case bv) cases + +and add_case bv {pc_lhs; pc_guard; pc_rhs} = + let bv = add_pattern bv pc_lhs in + add_opt add_expr bv pc_guard; + add_expr bv pc_rhs + +and add_bindings recf bv pel = + let bv' = List.fold_left (fun bv x -> add_pattern bv x.pvb_pat) bv pel in + let bv = if recf = Recursive then bv' else bv in + List.iter (fun x -> add_expr bv x.pvb_expr) pel; + bv' + +and add_modtype bv mty = + match mty.pmty_desc with + Pmty_ident l -> add bv l + | Pmty_alias l -> add_module_path bv l + | Pmty_signature s -> add_signature bv s + | Pmty_functor(id, mty1, mty2) -> + Misc.may (add_modtype bv) mty1; + add_modtype (StringMap.add id.txt bound bv) mty2 + | Pmty_with(mty, cstrl) -> + add_modtype bv mty; + List.iter + (function + | Pwith_type (_, td) -> add_type_declaration bv td + | Pwith_module (_, lid) -> add_module_path bv lid + | Pwith_typesubst (_, td) -> add_type_declaration bv td + | Pwith_modsubst (_, lid) -> add_module_path bv lid + ) + cstrl + | Pmty_typeof m -> add_module_expr bv m + | Pmty_extension e -> handle_extension e + +and add_module_alias bv l = + (* If we are in delayed dependencies mode, we delay the dependencies + induced by "Lident s" *) + (if !Clflags.transparent_modules then add_parent else add_module_path) bv l; + try + lookup_map l.txt bv + with Not_found -> + match l.txt with + Lident s -> make_leaf s + | _ -> add_module_path bv l; bound (* cannot delay *) + +and add_modtype_binding bv mty = + match mty.pmty_desc with + Pmty_alias l -> + add_module_alias bv l + | Pmty_signature s -> + make_node (add_signature_binding bv s) + | Pmty_typeof modl -> + add_module_binding bv modl + | _ -> + add_modtype bv mty; bound + +and add_signature bv sg = + ignore (add_signature_binding bv sg) + +and add_signature_binding bv sg = + snd (List.fold_left add_sig_item (bv, StringMap.empty) sg) + +and add_sig_item (bv, m) item = + match item.psig_desc with + Psig_value vd -> + add_type bv vd.pval_type; (bv, m) + | Psig_type (_, dcls) -> + List.iter (add_type_declaration bv) dcls; (bv, m) + | Psig_typext te -> + add_type_extension bv te; (bv, m) + | Psig_exception pext -> + add_extension_constructor bv pext; (bv, m) + | Psig_module pmd -> + let m' = add_modtype_binding bv pmd.pmd_type in + let add = StringMap.add pmd.pmd_name.txt m' in + (add bv, add m) + | Psig_recmodule decls -> + let add = + List.fold_right (fun pmd -> StringMap.add pmd.pmd_name.txt bound) + decls + in + let bv' = add bv and m' = add m in + List.iter (fun pmd -> add_modtype bv' pmd.pmd_type) decls; + (bv', m') + | Psig_modtype x -> + begin match x.pmtd_type with + None -> () + | Some mty -> add_modtype bv mty + end; + (bv, m) + | Psig_open od -> + (open_module bv od.popen_lid.txt, m) + | Psig_include incl -> + let Node (s, m') = add_modtype_binding bv incl.pincl_mod in + add_names s; + let add = StringMap.fold StringMap.add m' in + (add bv, add m) + | Psig_class cdl -> + List.iter (add_class_description bv) cdl; (bv, m) + | Psig_class_type cdtl -> + List.iter (add_class_type_declaration bv) cdtl; (bv, m) + | Psig_attribute _ -> (bv, m) + | Psig_extension (e, _) -> + handle_extension e; + (bv, m) + +and add_module_binding bv modl = + match modl.pmod_desc with + Pmod_ident l -> add_module_alias bv l + | Pmod_structure s -> + make_node (snd @@ add_structure_binding bv s) + | _ -> add_module_expr bv modl; bound + +and add_module_expr bv modl = + match modl.pmod_desc with + Pmod_ident l -> add_module_path bv l + | Pmod_structure s -> ignore (add_structure bv s) + | Pmod_functor(id, mty, modl) -> + Misc.may (add_modtype bv) mty; + add_module_expr (StringMap.add id.txt bound bv) modl + | Pmod_apply(mod1, mod2) -> + add_module_expr bv mod1; add_module_expr bv mod2 + | Pmod_constraint(modl, mty) -> + add_module_expr bv modl; add_modtype bv mty + | Pmod_unpack(e) -> + add_expr bv e + | Pmod_extension e -> + handle_extension e + +and add_structure bv item_list = + let (bv, m) = add_structure_binding bv item_list in + add_names (collect_free (make_node m)); + bv + +and add_structure_binding bv item_list = + List.fold_left add_struct_item (bv, StringMap.empty) item_list + +and add_struct_item (bv, m) item : _ StringMap.t * _ StringMap.t = + match item.pstr_desc with + Pstr_eval (e, _attrs) -> + add_expr bv e; (bv, m) + | Pstr_value(rf, pel) -> + let bv = add_bindings rf bv pel in (bv, m) + | Pstr_primitive vd -> + add_type bv vd.pval_type; (bv, m) + | Pstr_type (_, dcls) -> + List.iter (add_type_declaration bv) dcls; (bv, m) + | Pstr_typext te -> + add_type_extension bv te; + (bv, m) + | Pstr_exception pext -> + add_extension_constructor bv pext; (bv, m) + | Pstr_module x -> + let b = add_module_binding bv x.pmb_expr in + let add = StringMap.add x.pmb_name.txt b in + (add bv, add m) + | Pstr_recmodule bindings -> + let add = + List.fold_right (fun x -> StringMap.add x.pmb_name.txt bound) bindings + in + let bv' = add bv and m = add m in + List.iter + (fun x -> add_module_expr bv' x.pmb_expr) + bindings; + (bv', m) + | Pstr_modtype x -> + begin match x.pmtd_type with + None -> () + | Some mty -> add_modtype bv mty + end; + (bv, m) + | Pstr_open od -> + (open_module bv od.popen_lid.txt, m) + | Pstr_class cdl -> + List.iter (add_class_declaration bv) cdl; (bv, m) + | Pstr_class_type cdtl -> + List.iter (add_class_type_declaration bv) cdtl; (bv, m) + | Pstr_include incl -> + let Node (s, m') as n = add_module_binding bv incl.pincl_mod in + if !Clflags.transparent_modules then + add_names s + else + (* If we are not in the delayed dependency mode, we need to + collect all delayed dependencies imported by the include statement *) + add_names (collect_free n); + let add = StringMap.fold StringMap.add m' in + (add bv, add m) + | Pstr_attribute _ -> (bv, m) + | Pstr_extension (e, _) -> + handle_extension e; + (bv, m) + +and add_use_file bv top_phrs = + ignore (List.fold_left add_top_phrase bv top_phrs) + +and add_implementation bv l = + ignore (add_structure_binding bv l) + +and add_implementation_binding bv l = + snd (add_structure_binding bv l) + +and add_top_phrase bv = function + | Ptop_def str -> add_structure bv str + | Ptop_dir (_, _) -> bv + +and add_class_expr bv ce = + match ce.pcl_desc with + Pcl_constr(l, tyl) -> + add bv l; List.iter (add_type bv) tyl + | Pcl_structure { pcstr_self = pat; pcstr_fields = fieldl } -> + let bv = add_pattern bv pat in List.iter (add_class_field bv) fieldl + | Pcl_fun(_, opte, pat, ce) -> + add_opt add_expr bv opte; + let bv = add_pattern bv pat in add_class_expr bv ce + | Pcl_apply(ce, exprl) -> + add_class_expr bv ce; List.iter (fun (_,e) -> add_expr bv e) exprl + | Pcl_let(rf, pel, ce) -> + let bv = add_bindings rf bv pel in add_class_expr bv ce + | Pcl_constraint(ce, ct) -> + add_class_expr bv ce; add_class_type bv ct + | Pcl_extension e -> handle_extension e + | Pcl_open (_ovf, m, e) -> + let bv = open_module bv m.txt in add_class_expr bv e + +and add_class_field bv pcf = + match pcf.pcf_desc with + Pcf_inherit(_, ce, _) -> add_class_expr bv ce + | Pcf_val(_, _, Cfk_concrete (_, e)) + | Pcf_method(_, _, Cfk_concrete (_, e)) -> add_expr bv e + | Pcf_val(_, _, Cfk_virtual ty) + | Pcf_method(_, _, Cfk_virtual ty) -> add_type bv ty + | Pcf_constraint(ty1, ty2) -> add_type bv ty1; add_type bv ty2 + | Pcf_initializer e -> add_expr bv e + | Pcf_attribute _ -> () + | Pcf_extension e -> handle_extension e + +and add_class_declaration bv decl = + add_class_expr bv decl.pci_expr diff --git a/miniml/interp/depend.sh b/miniml/interp/depend.sh new file mode 100755 index 0000000..1313869 --- /dev/null +++ b/miniml/interp/depend.sh @@ -0,0 +1,4 @@ +#!/usr/bin/env bash +r=$(dirname $0) +root=$r/../.. +$root/ocaml-src/byterun/ocamlrun $r/makedepend.byte "$@" \ No newline at end of file diff --git a/miniml/interp/format.ml b/miniml/interp/format.ml index fa57f88..b89bbf4 100644 --- a/miniml/interp/format.ml +++ b/miniml/interp/format.ml @@ -48,9 +48,11 @@ let mkprintf is_format print_fun ff fmt cont = Obj.magic (loop 0) let getff ff = ff.out_string -let printf fmt = mkprintf true getff { out_string = print_string } fmt (fun () -> ()) +let std_formatter = { out_string = print_string } +let err_formatter = { out_string = print_err } let fprintf ff fmt = mkprintf true getff ff fmt (fun () -> ()) -let eprintf fmt = mkprintf true getff { out_string = print_err } fmt (fun () -> ()) +let printf fmt = fprintf std_formatter fmt +let eprintf fmt = fprintf err_formatter fmt let kbprintf k b fmt = mkprintf true getff { out_string = Buffer.add_string b } fmt (fun () -> k b) let bprintf b fmt = kbprintf (fun _ -> ()) b fmt let kprintf k fmt = kbprintf (fun b -> k (Buffer.contents b)) (Buffer.create 16) fmt diff --git a/miniml/interp/makedepend.ml b/miniml/interp/makedepend.ml new file mode 100644 index 0000000..17b9492 --- /dev/null +++ b/miniml/interp/makedepend.ml @@ -0,0 +1,415 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1999 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Parsetree + +module StringMap = Depend.StringMap +module StringSet = Depend.StringSet + +let ppf = Format.err_formatter +(* Print the dependencies *) + +type file_kind = ML | MLI;; + +let first_include_dirs = ref ([] : string list) +let include_dirs = ref ([] : string list) +let load_path = ref ([] : (string * string array) list) +let ml_synonyms = ref [".ml"] +let mli_synonyms = ref [".mli"] +let shared = ref false +let native_only = ref false +let bytecode_only = ref false +let error_occurred = ref false +let raw_dependencies = ref false +let all_dependencies = ref false +let one_line = ref false +let files = + ref ([] : (string * file_kind * StringSet.t * string list) list) + +let map_files = ref [] +let module_map = ref StringMap.empty +let debug = ref false + +(* Fix path to use '/' as directory separator instead of '\'. + Only under Windows. *) + +let fix_slash s = + if Sys.os_type = "Unix" then s else begin + String.map (function '\\' -> '/' | c -> c) s + end + +(* Since we reinitialize load_path after reading OCAMLCOMP, + we must use a cache instead of calling Sys.readdir too often. *) +let dirs = ref StringMap.empty +let readdir dir = + try + StringMap.find dir !dirs + with Not_found -> + let contents = + try + Sys.readdir dir + with Sys_error msg -> + Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; + error_occurred := true; + [||] + in + dirs := StringMap.add dir contents !dirs; + contents + +let add_to_list li s = + li := s :: !li + +let add_to_load_path dir = + try + (* let dir = Misc.expand_directory Config.standard_library dir in *) + let contents = readdir dir in + add_to_list load_path (dir, contents) + with Sys_error msg -> + Format.fprintf Format.err_formatter "@[Bad -I option: %s@]@." msg; + error_occurred := true + +let add_to_synonym_list synonyms suffix = + if (String.length suffix) > 1 && suffix.[0] = '.' then + add_to_list synonyms suffix + else begin + Format.fprintf Format.err_formatter "@[Bad suffix: '%s'@]@." suffix; + error_occurred := true + end + +(* Find file 'name' (capitalized) in search path *) +let find_file name = + let uname = String.uncapitalize_ascii name in + let rec find_in_array a pos = + if pos >= Array.length a then None else begin + let s = a.(pos) in + if s = name || s = uname then Some s else find_in_array a (pos + 1) + end in + let rec find_in_path = function + [] -> raise Not_found + | (dir, contents) :: rem -> + match find_in_array contents 0 with + Some truename -> + if dir = "." then truename else Filename.concat dir truename + | None -> find_in_path rem in + find_in_path !load_path + +let rec find_file_in_list = function + [] -> raise Not_found +| x :: rem -> try find_file x with Not_found -> find_file_in_list rem + + +let find_dependency target_kind modname (byt_deps, opt_deps) = + try + let candidates = List.map ((^) modname) !mli_synonyms in + let filename = find_file_in_list candidates in + let basename = Filename.chop_extension filename in + let cmi_file = basename ^ ".cmi" in + let cmx_file = basename ^ ".cmx" in + let ml_exists = + List.exists (fun ext -> Sys.file_exists (basename ^ ext)) !ml_synonyms in + let new_opt_dep = + if !all_dependencies then + match target_kind with + | MLI -> [ cmi_file ] + | ML -> + cmi_file :: (if ml_exists then [ cmx_file ] else []) + else + (* this is a make-specific hack that makes .cmx to be a 'proxy' + target that would force the dependency on .cmi via transitivity *) + if ml_exists + then [ cmx_file ] + else [ cmi_file ] + in + ( cmi_file :: byt_deps, new_opt_dep @ opt_deps) + with Not_found -> + try + (* "just .ml" case *) + let candidates = List.map ((^) modname) !ml_synonyms in + let filename = find_file_in_list candidates in + let basename = Filename.chop_extension filename in + let cmi_file = basename ^ ".cmi" in + let cmx_file = basename ^ ".cmx" in + let bytenames = + if !all_dependencies then + match target_kind with + | MLI -> [ cmi_file ] + | ML -> [ cmi_file ] + else + (* again, make-specific hack *) + [basename ^ (if !native_only then ".cmx" else ".cmo")] in + let optnames = + if !all_dependencies + then match target_kind with + | MLI -> [ cmi_file ] + | ML -> [ cmi_file; cmx_file ] + else [ cmx_file ] + in + (bytenames @ byt_deps, optnames @ opt_deps) + with Not_found -> + (byt_deps, opt_deps) + +let depends_on = ":" +let escaped_eol = " \\\n " + +let print_filename s = + let s = fix_slash s in + if not (String.contains s ' ') then begin + print_string s; + end else begin + let rec count n i = + if i >= String.length s then n + else if s.[i] = ' ' then count (n+1) (i+1) + else count n (i+1) + in + let spaces = count 0 0 in + let result = Bytes.create (String.length s + spaces) in + let rec loop i j = + if i >= String.length s then () + else if s.[i] = ' ' then begin + Bytes.set result j '\\'; + Bytes.set result (j+1) ' '; + loop (i+1) (j+2); + end else begin + Bytes.set result j s.[i]; + loop (i+1) (j+1); + end + in + loop 0 0; + print_bytes result; + end +;; + +let print_dependencies target_files deps = + let rec print_items pos = function + [] -> print_string "\n" + | dep :: rem -> + if !one_line || (pos + 1 + String.length dep <= 77) then begin + if pos <> 0 then print_string " "; print_filename dep; + print_items (pos + String.length dep + 1) rem + end else begin + print_string escaped_eol; print_filename dep; + print_items (String.length dep + 4) rem + end in + print_items 0 (target_files @ [depends_on] @ deps) + +let print_raw_dependencies source_file deps = + print_filename source_file; print_string depends_on; + StringSet.iter + (fun dep -> + (* filter out "*predef*" *) + if (String.length dep > 0) + && (match dep.[0] with + | 'A'..'Z' | '\128'..'\255' -> true + | _ -> false) then + begin + print_char ' '; + print_string dep + end) + deps; + print_char '\n' + + +(* Process one file *) + +let report_err exn = error_occurred := true + +let tool_name = "ocamldep" + +let rec lexical_approximation lexbuf = + (* Approximation when a file can't be parsed. + Heuristic: + - first component of any path starting with an uppercase character is a + dependency. + - always skip the token after a dot, unless dot is preceded by a + lower-case identifier + - always skip the token after a backquote + *) + try + let rec process after_lident lexbuf = + match Lexer.token lexbuf with + | Parser.UIDENT name -> + Depend.free_structure_names := + StringSet.add name !Depend.free_structure_names; + process false lexbuf + | Parser.LIDENT _ -> process true lexbuf + | Parser.DOT when after_lident -> process false lexbuf + | Parser.DOT | Parser.BACKQUOTE -> skip_one lexbuf + | Parser.EOF -> () + | _ -> process false lexbuf + and skip_one lexbuf = + match Lexer.token lexbuf with + | Parser.DOT | Parser.BACKQUOTE -> skip_one lexbuf + | Parser.EOF -> () + | _ -> process false lexbuf + + in + process false lexbuf + with Lexer.Error _ -> lexical_approximation lexbuf + +let read_and_approximate inputfile = + error_occurred := false; + Depend.free_structure_names := StringSet.empty; + let ic = open_in_bin inputfile in + try + seek_in ic 0; + Location.input_name := inputfile; + let lexbuf = Lexing.from_channel ic in + Location.init lexbuf inputfile; + lexical_approximation lexbuf; + close_in ic; + !Depend.free_structure_names + with exn -> + close_in ic; + report_err exn; + !Depend.free_structure_names + +let read_parse_and_extract parse_function extract_function source_file = + Depend.pp_deps := []; + Depend.free_structure_names := Depend.StringSet.empty; + try + let ic = open_in source_file in + let lexbuf = Lexing.from_channel ic in + Location.init lexbuf source_file; + let ast = parse_function lexbuf in + let bound_vars = !module_map in + extract_function bound_vars ast; + !Depend.free_structure_names + with x -> begin + read_and_approximate source_file + end + + +let print_ml_dependencies source_file extracted_deps pp_deps = + let basename = Filename.chop_extension source_file in + let byte_targets = [ basename ^ ".cmo" ] in + let native_targets = + if !all_dependencies + then [ basename ^ ".cmx"; basename ^ ".o" ] + else [ basename ^ ".cmx" ] in + let shared_targets = [ basename ^ ".cmxs" ] in + let init_deps = if !all_dependencies then [source_file] else [] in + let cmi_name = basename ^ ".cmi" in + let init_deps, extra_targets = + if List.exists (fun ext -> Sys.file_exists (basename ^ ext)) + !mli_synonyms + then (cmi_name :: init_deps, cmi_name :: init_deps), [] + else (init_deps, init_deps), + (if !all_dependencies then [cmi_name] else []) + in + let (byt_deps, native_deps) = + StringSet.fold (find_dependency ML) + extracted_deps init_deps in + if not !native_only then + print_dependencies (byte_targets @ extra_targets) (byt_deps @ pp_deps); + if not !bytecode_only then + begin + print_dependencies (native_targets @ extra_targets) + (native_deps @ pp_deps); + if !shared then + print_dependencies (shared_targets @ extra_targets) + (native_deps @ pp_deps) + end + +let print_mli_dependencies source_file extracted_deps pp_deps = + let basename = Filename.chop_extension source_file in + let (byt_deps, _opt_deps) = + StringSet.fold (find_dependency MLI) + extracted_deps ([], []) in + print_dependencies [basename ^ ".cmi"] (byt_deps @ pp_deps) + +let print_file_dependencies (source_file, kind, extracted_deps, pp_deps) = + if !raw_dependencies then begin + print_raw_dependencies source_file extracted_deps + end else + match kind with + | ML -> print_ml_dependencies source_file extracted_deps pp_deps + | MLI -> print_mli_dependencies source_file extracted_deps pp_deps + + +let ml_file_dependencies source_file = + let parse_use_file_as_impl lexbuf = + let f x = + match x with + | Ptop_def s -> s + | Ptop_dir _ -> [] + in + List.flatten (List.map f (Parse.use_file lexbuf)) + in + let extracted_deps = + read_parse_and_extract parse_use_file_as_impl Depend.add_implementation source_file + in + files := (source_file, ML, extracted_deps, []) :: !files + +let mli_file_dependencies source_file = + let extracted_deps = + read_parse_and_extract Parse.interface Depend.add_signature source_file + in + files := (source_file, MLI, extracted_deps, []) :: !files + +let process_file_as process_fun def source_file = + load_path := []; + List.iter add_to_load_path ( + (!include_dirs @ + !first_include_dirs + )); + Location.input_name := source_file; + try + if Sys.file_exists source_file then process_fun source_file else def + with x -> report_err x; def + +let process_file source_file ~ml_file ~mli_file ~def = + if List.exists (Filename.check_suffix source_file) !ml_synonyms then + process_file_as ml_file def source_file + else if List.exists (Filename.check_suffix source_file) !mli_synonyms then + process_file_as mli_file def source_file + else def + +let file_dependencies source_file = + process_file source_file ~def:() + ~ml_file:ml_file_dependencies + ~mli_file:mli_file_dependencies + +let file_dependencies_as kind = + match kind with + | ML -> process_file_as ml_file_dependencies () + | MLI -> process_file_as mli_file_dependencies () + +(* Entry point *) + +let main () = + add_to_list first_include_dirs Filename.current_dir_name; + let specs = [ + "-I", Arg.String (add_to_list include_dirs), + " Add to the list of include directories"; + "-impl", Arg.String (file_dependencies_as ML), + " Process as a .ml file"; + "-intf", Arg.String (file_dependencies_as MLI), + " Process as a .mli file"; + "-native", Arg.Set native_only, + " Generate dependencies for native-code only (no .cmo files)"; + "-bytecode", Arg.Set bytecode_only, + " Generate dependencies for bytecode-code only (no .cmx files)"; + (* "-pp", Arg.String(fun s -> Clflags.preprocessor := Some s), + " Pipe sources through preprocessor "; *) + ] in + let usage = + Printf.sprintf "Usage: %s [options] \nOptions are:" + (Filename.basename Sys.argv.(0)) + in + Arg.parse specs file_dependencies usage; + List.iter print_file_dependencies (List.sort compare !files); + exit (if !error_occurred then 2 else 0) + +let () = main () diff --git a/miniml/interp/misc.ml b/miniml/interp/misc.ml index e8956ac..2000e2b 100644 --- a/miniml/interp/misc.ml +++ b/miniml/interp/misc.ml @@ -23,3 +23,5 @@ let create_hashtable size init = let tbl = Hashtbl.create size in List.iter (fun (key, data) -> Hashtbl.add tbl key data) init; tbl + +let may f = function Some x -> f x | None -> () diff --git a/miniml/interp/std.ml b/miniml/interp/std.ml index 2adfe62..2bdfae3 100644 --- a/miniml/interp/std.ml +++ b/miniml/interp/std.ml @@ -190,9 +190,12 @@ external pos_in : in_channel -> int = "caml_ml_pos_in" let output_string oc s = unsafe_output_string oc s 0 (string_length s) +let output_bytes oc s = + unsafe_output oc s 0 (bytes_length s) let print_char c = output_char stdout c let print_string s = output_string stdout s; flush stdout +let print_bytes s = output_bytes stdout s; flush stdout let print_newline () = print_string "\n" let print_endline s = print_string s; print_newline () let print_err s = output_string stderr s; flush stderr @@ -254,6 +257,7 @@ module Sys = struct external getcwd: unit -> string = "caml_sys_getcwd" external rename : string -> string -> unit = "caml_sys_rename" external remove: string -> unit = "caml_sys_remove" + external readdir : string -> string array = "caml_sys_read_directory" let os_type = "" let ocaml_version = "camlboot"