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

remove experimental/ 

This subdirectory was used to store experimental patches on some older
version-control system where branching (or discussing branches?) was
inconvenient. It doesn't make much sense anymore now, and getting rid
of it simplifies a couple places that had to grow around it.

Suggested-by: Nicolás Ojeda Bär

(no change entry needed)
master
Gabriel Scherer 2018-09-08 16:53:08 +02:00
parent cbae94c0d0
commit ef00dc7317
59 changed files with 1 additions and 15888 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -63,8 +63,6 @@ emacs/caml.el ocaml-typo=long-line,unused-prop,missing-header
emacs/COPYING ocaml-typo=tab,non-printing,missing-header
emacs/ocamltags.in ocaml-typo=non-printing
/experimental ocaml-typo=prune
/manual ocaml-typo=prune
ocamldoc/Changes.txt ocaml-typo=missing-header

3
.gitignore vendored
View File

@ -74,9 +74,6 @@ _ocamltestd
/emacs/ocamltags
/emacs/*.elc
/experimental/garrigue/*.out
/experimental/garrigue/*.out2
/lex/parser.ml
/lex/parser.mli
/lex/lexer.ml

1
HACKING.adoc
View File

@ -178,7 +178,6 @@ has excellent documentation.
debugger/:: source-level replay debugger
driver/:: driver code for the compilers
emacs/:: editing mode and debugger interface for GNU Emacs
experimental/:: experiments not built by default
flexdll/:: git submodule -- see link:README.win32.adoc[]
lex/:: lexer generator
man/:: man pages

4
Makefile
View File

@ -1310,9 +1310,7 @@ beforedepend:: bytecomp/opcodes.ml
# Testing the parser -- see parsing/HACKING.adoc
SOURCE_FILES=$(shell \
git ls-files '*.ml' '*.mli' \
| grep -v '^experimental/')
SOURCE_FILES=$(shell git ls-files '*.ml' '*.mli')
AST_FILES=$(addsuffix .ast,$(SOURCE_FILES))

149
experimental/doligez/check-bounds.diff
View File

@ -1,149 +0,0 @@
Patch taken from:
https://github.com/mshinwell/ocaml/commits/4.02-block-bounds
diff --git a/asmcomp/cmmgen.ml b/asmcomp/cmmgen.ml
index 01eff9c..b498b58 100644
--- a/asmcomp/cmmgen.ml
+++ b/asmcomp/cmmgen.ml
@@ -22,6 +22,13 @@ open Clambda
open Cmm
open Cmx_format
+let do_check_field_access = true
+(*
+ match try Some (Sys.getenv "BOUNDS") with Not_found -> None with
+ | None | Some "" -> false
+ | Some _ -> true
+*)
+
(* Local binding of complex expressions *)
let bind name arg fn =
@@ -494,6 +501,35 @@ let get_tag ptr =
let get_size ptr =
Cop(Clsr, [header ptr; Cconst_int 10])
+(* Bounds checks upon field access, for debugging the compiler *)
+
+let check_field_access ptr field_index if_success =
+ if not do_check_field_access then
+ if_success
+ else
+ let field_index = Cconst_int field_index in
+ (* If [ptr] points at an infix header, we need to move it back to the "main"
+ [Closure_tag] header. *)
+ let ptr =
+ Cifthenelse (Cop (Ccmpi Cne, [get_tag ptr; Cconst_int Obj.infix_tag]),
+ ptr,
+ Cop (Csuba, [ptr;
+ Cop (Cmuli, [get_size ptr (* == Infix_offset_val(ptr) *);
+ Cconst_int size_addr])]))
+ in
+ let not_too_small = Cop (Ccmpi Cge, [field_index; Cconst_int 0]) in
+ let not_too_big = Cop (Ccmpi Clt, [field_index; get_size ptr]) in
+ let failure =
+ Cop (Cextcall ("caml_field_access_out_of_bounds_error", typ_addr, false,
+ Debuginfo.none),
+ [ptr; field_index])
+ in
+ Cifthenelse (not_too_small,
+ Cifthenelse (not_too_big,
+ if_success,
+ failure),
+ failure)
+
(* Array indexing *)
let log2_size_addr = Misc.log2 size_addr
@@ -1550,13 +1586,18 @@ and transl_prim_1 p arg dbg =
return_unit(remove_unit (transl arg))
(* Heap operations *)
| Pfield n ->
- get_field (transl arg) n
+ let ptr = transl arg in
+ let body = get_field ptr n in
+ check_field_access ptr n body
| Pfloatfield n ->
let ptr = transl arg in
- box_float(
- Cop(Cload Double_u,
- [if n = 0 then ptr
- else Cop(Cadda, [ptr; Cconst_int(n * size_float)])]))
+ let body =
+ box_float(
+ Cop(Cload Double_u,
+ [if n = 0 then ptr
+ else Cop(Cadda, [ptr; Cconst_int(n * size_float)])]))
+ in
+ check_field_access ptr n body
| Pint_as_pointer ->
Cop(Cadda, [transl arg; Cconst_int (-1)])
(* Exceptions *)
@@ -1649,20 +1690,25 @@ and transl_prim_1 p arg dbg =
and transl_prim_2 p arg1 arg2 dbg =
match p with
(* Heap operations *)
- Psetfield(n, ptr) ->
- if ptr then
- return_unit(Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none),
- [field_address (transl arg1) n; transl arg2]))
- else
- return_unit(set_field (transl arg1) n (transl arg2))
+ Psetfield(n, is_ptr) ->
+ let ptr = transl arg1 in
+ let body =
+ if is_ptr then
+ Cop(Cextcall("caml_modify", typ_void, false,Debuginfo.none),
+ [field_address ptr n; transl arg2])
+ else
+ set_field ptr n (transl arg2)
+ in
+ check_field_access ptr n (return_unit body)
| Psetfloatfield n ->
let ptr = transl arg1 in
- return_unit(
+ let body =
Cop(Cstore Double_u,
[if n = 0 then ptr
else Cop(Cadda, [ptr; Cconst_int(n * size_float)]);
- transl_unbox_float arg2]))
-
+ transl_unbox_float arg2])
+ in
+ check_field_access ptr n (return_unit body)
(* Boolean operations *)
| Psequand ->
Cifthenelse(test_bool(transl arg1), transl arg2, Cconst_int 1)
diff --git a/asmrun/fail.c b/asmrun/fail.c
index cb2c1cb..4f67c74 100644
--- a/asmrun/fail.c
+++ b/asmrun/fail.c
@@ -15,6 +15,7 @@
#include <stdio.h>
#include <signal.h>
+#include <assert.h>
#include "alloc.h"
#include "fail.h"
#include "io.h"
@@ -180,3 +181,20 @@ int caml_is_special_exception(value exn) {
|| exn == (value) caml_exn_Assert_failure
|| exn == (value) caml_exn_Undefined_recursive_module;
}
+
+void caml_field_access_out_of_bounds_error(value v_block, intnat index)
+{
+ assert(Is_block(v_block));
+ fprintf(stderr, "Fatal error: out-of-bounds access to field %ld ", index);
+ fprintf(stderr, "of block at %p (%s, size %ld, tag %d)\n",
+ (void*) v_block,
+ Is_young(v_block) ? "in minor heap"
+ : Is_in_heap(v_block) ? "in major heap"
+ : Is_in_value_area(v_block) ? "in static data"
+ : "out-of-heap",
+ (long) Wosize_val(v_block), (int) Tag_val(v_block));
+ fflush(stderr);
+ /* This error may have occurred in places where it is not reasonable to
+ attempt to continue. */
+ abort();
+}

155
experimental/doligez/checkheaders
View File

@ -1,155 +0,0 @@
#!/bin/sh
#**************************************************************************
#* *
#* OCaml *
#* *
#* Damien Doligez, projet Gallium, INRIA Rocquencourt *
#* *
#* Copyright 2011 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. *
#* *
#**************************************************************************
(
case $# in
0) find . -type f -print;;
*) echo $1;;
esac
) | \
while read f; do
awk -f - "$f" <<\EOF
function checkline (x) {
return ( $0 ~ ("^.{0,4}" x) );
}
function hrule () {
return (checkline("[*#]{69}"));
}
function blank () {
return (checkline(" {69}"));
}
function ocaml () {
return (checkline(" {32}OCaml {32}") \
|| checkline(" {35}OCaml {32}") \
|| checkline(" ocamlbuild ") \
|| checkline(" OCamldoc ") \
);
}
function any () {
return (checkline(".{69}"));
}
function copy1 () {
return (checkline(" Copyright +[-0-9]+ +Institut +National +de +Recherche +en +Informatique +et "));
}
function copy2 () {
return (checkline(" en Automatique"));
}
function err () {
printf ("File \"%s\", line %d:\n", FILENAME, FNR);
printf (" Error: line %d of header is wrong.\n", FNR + offset);
print $0;
}
function add_ignore_re (x) {
ignore_re[++ignore_re_index] = x;
}
function add_exception (x) {
exception[++exception_index] = x;
}
FNR == 1 {
offset = 0;
add_ignore_re("/\\.svn/");
add_ignore_re("/\\.depend(\\.nt)?$");
add_ignore_re("/\\.ignore$");
add_ignore_re("\\.gif$");
add_ignore_re("/[A-Z]*$");
add_ignore_re("/README\\.[^/]*$");
add_ignore_re("/Changes$");
add_ignore_re("\\.mlpack$");
add_ignore_re("\\.mllib$");
add_ignore_re("\\.mltop$");
add_ignore_re("\\.clib$");
add_ignore_re("\\.odocl$");
add_ignore_re("\\.itarget$");
add_ignore_re("^\\./boot/");
add_ignore_re("^\\./camlp4/test/");
add_ignore_re("^\\./camlp4/unmaintained/");
add_ignore_re("^\\./config/gnu/");
add_ignore_re("^\\./experimental/");
add_ignore_re("^\\./ocamlbuild/examples/");
add_ignore_re("^\\./ocamlbuild/test/");
add_ignore_re("^\\./testsuite/");
for (i in ignore_re){
if (FILENAME ~ ignore_re[i]) { nextfile; }
}
add_exception("./asmrun/m68k.S"); # obsolete
add_exception("./build/camlp4-bootstrap-recipe.txt");
add_exception("./build/new-build-system");
add_exception("./ocamlbuild/ChangeLog");
add_exception("./ocamlbuild/manual/myocamlbuild.ml"); # TeX input file ?
add_exception("./ocamlbuild/manual/trace.out"); # TeX input file
add_exception("./ocamldoc/Changes.txt");
add_exception("./ocamldoc/ocamldoc.sty"); # public domain
add_exception("./tools/objinfo_helper.c"); # non-INRIA
add_exception("./tools/magic"); # public domain ?
add_exception("./Upgrading");
add_exception("./win32caml/inriares.h"); # generated
add_exception("./win32caml/ocaml.rc"); # generated
add_exception("./win32caml/resource.h"); # generated
for (i in exception){
if (FILENAME == exception[i]) { nextfile; }
}
}
# 1 [!hrule] #!
# 2 [!hrule] empty
# 3 hrule
# 4 [blank]
# 5 ocaml title
# 6 blank
# 7 any author
# 8 [!blank] author
# 9 [!blank] author
#10 blank
#11 copy1 copyright
#12 copy2 copyright
#13 any copyright
#14 [!blank] copyright
#15 [!blank] copyright
#16 blank
#17 hrule
FNR + offset == 1 && hrule() { ++offset; }
FNR + offset == 2 && hrule() { ++offset; }
FNR + offset == 3 && ! hrule() { err(); nextfile; }
FNR + offset == 4 && ! blank() { ++offset; }
FNR + offset == 5 && ! ocaml() { err(); nextfile; }
FNR + offset == 6 && ! blank() { err(); nextfile; }
FNR + offset == 7 && ! any() { err(); nextfile; }
FNR + offset == 8 && blank() { ++offset; }
FNR + offset == 9 && blank() { ++offset; }
FNR + offset ==10 && ! blank() { err(); nextfile; }
FNR + offset ==11 && ! copy1() { err(); nextfile; }
FNR + offset ==12 && ! copy2() { err(); nextfile; }
FNR + offset ==13 && ! any() { err(); nextfile; }
FNR + offset ==14 && blank() { ++offset; }
FNR + offset ==15 && blank() { ++offset; }
FNR + offset ==16 && ! blank() { err(); nextfile; }
FNR + offset ==17 && ! hrule() { err(); nextfile; }
EOF
done

113
experimental/frisch/Makefile
View File

@ -1,113 +0,0 @@
include ../../config/Makefile
ROOT=../..
OCAMLC=$(ROOT)/boot/ocamlrun $(ROOT)/ocamlc -I $(ROOT)/stdlib -I $(ROOT)/parsing -I $(ROOT)/utils -I $(ROOT)/tools -I $(ROOT)/typing -I $(ROOT)/driver -I $(ROOT)/toplevel -w A-4-9-42
COMMON=$(ROOT)/compilerlibs/ocamlcommon.cma
BYTECMP=$(ROOT)/compilerlibs/ocamlbytecomp.cma
TOPLVL=$(ROOT)/compilerlibs/ocamltoplevel.cma
clean:
rm -f *.exe *.cm* *~
## Detecting unused exported values
.PHONY: unused_exported_values
unused_exported_values:
$(OCAMLC) -o unused_exported_values.exe $(COMMON) $(ROOT)/tools/tast_iter.cmo unused_exported_values.ml
## Conditional compilation based on environment variables
.PHONY: ifdef
ifdef:
$(OCAMLC) -o ifdef.exe $(COMMON) ifdef.ml
$(OCAMLC) -o test_ifdef.exe -ppx ./ifdef.exe -dsource test_ifdef.ml
./test_ifdef.exe
## A proposal for replacing js_of_ocaml Camlp4 syntax extension with
## a -ppx filter
.PHONY: js_syntax
js_syntax:
$(OCAMLC) -o js_syntax.exe $(COMMON) js_syntax.ml
$(OCAMLC) -o test_ifdef.exe -i -ppx ./js_syntax.exe test_js.ml
## A "toy" ocamldoc clone based on .cmti files
.PHONY: minidoc
minidoc:
$(OCAMLC) -custom -o minidoc.exe $(COMMON) minidoc.ml
$(OCAMLC) -c -bin-annot testdoc.mli
./minidoc.exe testdoc.cmti
## Using the OCaml toplevel to evaluate expression during compilation
.PHONY: eval
eval:
$(OCAMLC) -linkall -o eval.exe $(COMMON) $(BYTECMP) $(TOPLVL) eval.ml
$(OCAMLC) -o test_eval.exe -ppx ./eval.exe test_eval.ml
./test_eval.exe
## Example of code generation based on type declarations
.PHONY: ppx_builder
ppx_builder:
$(OCAMLC) -linkall -o ppx_builder.exe $(COMMON) ppx_builder.ml
$(OCAMLC) -o test_builder.exe -ppx ./ppx_builder.exe -dsource test_builder.ml
## Import type definitions from other source files (e.g. to avoid code
## duplication between the .ml and .mli files)
.PHONY: copy_typedef
copy_typedef:
$(OCAMLC) -linkall -o copy_typedef.exe $(COMMON) copy_typedef.ml
$(OCAMLC) -c -ppx ./copy_typedef.exe test_copy_typedef.mli
$(OCAMLC) -o test_copy_typedef.exe -ppx ./copy_typedef.exe -dsource test_copy_typedef.ml
## Create mli files from ml files
.PHONY: nomli
nomli:
$(OCAMLC) -linkall -o nomli.exe $(COMMON) $(BYTECMP) ../../tools/untypeast.cmo ../../tools/tast_iter.cmo nomli.ml
./nomli.exe test_nomli.ml
## A port of pa_matches
.PHONY: matches
matches:
$(OCAMLC) -linkall -o ppx_matches.exe $(COMMON) ppx_matches.ml
$(OCAMLC) -c -dsource -ppx ./ppx_matches.exe test_matches.ml
## Benchmark ocamllex
.PHONY: bench_ocamllex bench_ocamllex2
ARGS=-o bench.exe -nostdlib \
-I $(ROOT)/otherlibs/$(UNIXLIB) -I $(ROOT)/stdlib -I $(ROOT)/parsing -I $(ROOT)/utils \
$(ROOT)/compilerlibs/ocamlcommon.cma unix.cma \
my_lexer.ml bench.ml
bench_ocamllex:
@cp $(ROOT)/parsing/lexer.mll my_lexer.mll
cp my_lexer2.mll my_lexer.mll
@(cd $(ROOT)/lex && make ocamllex)
@$(ROOT)/boot/ocamlrun $(ROOT)/lex/ocamllex -ml my_lexer.mll
@echo WITH -ml flag:
@make -s bench_ocamllex2
@$(ROOT)/boot/ocamlrun $(ROOT)/lex/ocamllex -q my_lexer.mll
@echo WITHOUT -ml flag:
@make -s bench_ocamllex2
bench_ocamllex2:
@echo -n " NATIVE, -inline 1000: "
@$(ROOT)/boot/ocamlrun $(ROOT)/ocamlopt -inline 1000 $(ARGS:.cma=.cmxa)
@./bench.exe
@echo -n " NATIVE, -inline 10 : "
@$(ROOT)/boot/ocamlrun $(ROOT)/ocamlopt -inline 10 $(ARGS:.cma=.cmxa)
@./bench.exe
@echo -n " BYTECODE : "
@$(ROOT)/boot/ocamlrun $(ROOT)/ocamlc -custom $(ARGS)
@./bench.exe

39
experimental/frisch/bench.ml
View File

@ -1,39 +0,0 @@
let lexing s =
let lexbuf = Lexing.from_string s in
lexbuf.lex_curr_p <- Lexing.dummy_pos;
let rec loop () =
match My_lexer.token lexbuf with
| Parser.EOF -> ()
| token -> loop ()
in
loop ()
let s =
let ic = open_in "../../typing/typecore.ml" in
let b = Buffer.create 16 in
begin
try while true do
Buffer.add_string b (input_line ic);
Buffer.add_char b '\n'
done
with End_of_file -> ()
end;
close_in ic;
Buffer.contents b
let () =
let alloc0 = Gc.allocated_bytes () in
let t0 = Unix.gettimeofday () in
let n = 100 in
for _ = 1 to n do
lexing s
done;
let time = Unix.gettimeofday () -. t0 in
let alloc = Gc.allocated_bytes () -. alloc0 in
let len = float (String.length s) *. float n in
let mb = len /. 1024. /. 1024. in
Printf.printf " % 8.02f Mb/s % 8.02f ms/Mb alloc x % 8.02f \n%!"
(mb /. time)
(time *. 1000. /. mb)
(alloc /. len)

110
experimental/frisch/bench_ocamllex_optims.md
View File

@ -1,110 +0,0 @@
Some benchmark to evaluate the speedup to `ocamllex -ml`.
In all tests, we tokenize the `typecore.ml` file (first loaded in
memory) file using either:
- the OCaml lexer, or
- a simpler lexer with trivial actions (to eliminate the cost of
actions themselves, which is not under the control of ocamllex).
We run the output of:
- `ocamllex` without the -ml flag, i.e. using tables interpreted at
runtime by the C support code
- `ocamllex -ml`, i.e. the automaton is translated to OCaml code;
this is done on before and after the optimizations;
In adition, since it turned out that the automatic update of lex_start_p by
the generated code is quite costly, there is now logic so that
the generated code does not update this field and lex_curr_p when
lex_start_p is initially physically equal to Lexing.dummy_pos. This is also
tested (only for the simpler lexer, since the OCaml one update the field in
its actions).
For each case, we compile the benchmark with:
- `ocamlc`
- `ocamlopt -inline 10`
- `ocamlopt -inline 1000`
(flambda disabled).
The tables below show:
- the throughput (Mb of source code tokenized
by second -- higher is better;
- its inverse (number of milleseconds to parse one Mb) -- lower is better;
- the allocation ratio (number of bytes allocated by the GC for each byte of source code)
Conclusions:
- In native code, the "-ml" mode is slightly slower than the table
mode before the optimizations, but it becomes significantly faster
after the optimizations, obviously even more so when the
lexer actions are trivial (throughput 58.44 -> 98.30).
- In bytecode, the "-ml" mode is always much slower than the table
mode, but the optimization reduce the gap is little bit.
- Not tested here, but it is likely that the optimizations produce
code which would be more friendly to Javascript backends
(js_of_ocaml and Bucklescript), as they reduce quite a bit
the number of function calls and mutations.
Note:
- The "refill handler" mode has been lightly tested only.
OCaml lexer:
````
WITHOUT -ml flag:
NATIVE, -inline 1000: 38.07 Mb/s 26.27 ms/Mb alloc x 36.79
NATIVE, -inline 10 : 35.42 Mb/s 28.23 ms/Mb alloc x 36.79
BYTECODE : 7.84 Mb/s 127.54 ms/Mb alloc x 35.48
WITH -ml flag, TRUNK:
NATIVE, -inline 1000: 34.36 Mb/s 29.11 ms/Mb alloc x 36.79
NATIVE, -inline 10 : 34.12 Mb/s 29.31 ms/Mb alloc x 36.79
BYTECODE : 4.08 Mb/s 244.93 ms/Mb alloc x 35.48
WITH -ml flag, BRANCH:
NATIVE, -inline 1000: 45.56 Mb/s 21.95 ms/Mb alloc x 36.79
NATIVE, -inline 10 : 43.19 Mb/s 23.15 ms/Mb alloc x 36.79
BYTECODE : 4.35 Mb/s 229.91 ms/Mb alloc x 35.48
````
Simpler lexer (trivial actions):
````
WITHOUT -ml flag:
NATIVE, -inline 1000: 58.44 Mb/s 17.11 ms/Mb alloc x 21.94
NATIVE, -inline 10 : 58.24 Mb/s 17.17 ms/Mb alloc x 21.94
BYTECODE : 12.63 Mb/s 79.21 ms/Mb alloc x 21.93
WITH -ml flag, TRUNK:
NATIVE, -inline 1000: 55.14 Mb/s 18.13 ms/Mb alloc x 21.94
NATIVE, -inline 10 : 50.76 Mb/s 19.70 ms/Mb alloc x 21.94
BYTECODE : 5.74 Mb/s 174.22 ms/Mb alloc x 21.93
WITH -ml flag, BRANCH:
NATIVE, -inline 1000: 98.30 Mb/s 10.17 ms/Mb alloc x 21.94
NATIVE, -inline 10 : 87.16 Mb/s 11.47 ms/Mb alloc x 21.94
BYTECODE : 6.48 Mb/s 154.43 ms/Mb alloc x 21.93
WITH -ml flag, BRANCH, dummy_pos:
NATIVE, -inline 1000: 152.68 Mb/s 6.55 ms/Mb alloc x 1.00
NATIVE, -inline 10 : 133.97 Mb/s 7.46 ms/Mb alloc x 1.00
BYTECODE : 7.42 Mb/s 134.81 ms/Mb alloc x 1.00
````

181
experimental/frisch/copy_typedef.ml
View File

@ -1,181 +0,0 @@
(*
A -ppx rewriter to copy type definitions from the interface into
the implementation.
In an .ml file, you can write:
type t = [%copy_typedef]
and the concrete definition will be copied from the corresponding .mli
file (looking for the type name in the same path).
The same is available for module types:
module type S = [%copy_typedef]
You can also import a definition from an arbitrary .ml/.mli file.
Example:
type loc = [%copy_typedef "../../parsing/location.mli" t]
Note: the definitions are imported textually without any substitution.
*)
module Main : sig end = struct
open Asttypes
open! Location
open Parsetree
let fatal loc s =
Location.print_error Format.err_formatter loc;
prerr_endline ("** copy_typedef: " ^ Printexc.to_string s);
exit 2
class maintain_path = object(this)
inherit Ast_mapper.mapper as super
val path = []
method! module_binding m = {< path = m.pmb_name.txt :: path >} # super_module_binding m
method super_module_binding = super # module_binding
method! module_declaration m = {< path = m.pmd_name.txt :: path >} # super_module_declaration m
method super_module_declaration = super # module_declaration
method! module_type_declaration m = {< path = m.pmtd_name.txt :: path >} # super_module_type_declaration m
method super_module_type_declaration = super # module_type_declaration
method! structure_item s =
let s =
match s.pstr_desc with
| Pstr_type tdecls -> {s with pstr_desc=Pstr_type (List.map (this # tydecl) tdecls)}
| Pstr_modtype mtd -> {s with pstr_desc=Pstr_modtype (this # mtydecl mtd)}
| _ -> s
in
super # structure_item s
method! signature_item s =
let s =
match s.psig_desc with
| Psig_type tdecls -> {s with psig_desc=Psig_type (List.map (this # tydecl) tdecls)}
| Psig_modtype mtd -> {s with psig_desc=Psig_modtype (this # mtydecl mtd)}
| _ -> s
in
super # signature_item s
method tydecl x = x
method mtydecl x = x
end
let memoize f =
let h = Hashtbl.create 16 in
fun x ->
try Hashtbl.find h x
with Not_found ->
let r = f x in
Hashtbl.add h x r;
r
let from_file file =
let types = Hashtbl.create 16 in
let mtypes = Hashtbl.create 16 in
let collect = object
inherit maintain_path
method! tydecl x =
Hashtbl.add types (path, x.ptype_name.txt) x;
x
method! mtydecl x =
Hashtbl.add mtypes (path, x.pmtd_name.txt) x;
x
end
in
let ic = open_in file in
let lexbuf = Lexing.from_channel ic in
if Filename.check_suffix file ".ml"
then ignore (collect # structure (Parse.implementation lexbuf))
else if Filename.check_suffix file ".mli"
then ignore (collect # signature (Parse.interface lexbuf))
else failwith (Printf.sprintf "Unknown extension for %s" file);
close_in ic;
object
method tydecl path name =
try Hashtbl.find types (path, name)
with Not_found ->
failwith
(Printf.sprintf "Cannot find type %s in file %s\n%!"
(String.concat "." (List.rev (name :: path))) file)
method mtydecl path name =
try Hashtbl.find mtypes (path, name)
with Not_found ->
failwith
(Printf.sprintf "Cannot find module type %s in file %s\n%!"
(String.concat "." (List.rev (name :: path))) file)
end
let from_file = memoize from_file
let copy = object(this)
inherit maintain_path as super
val mutable file = ""
method source name = function
| PStr [] ->
let file =
if Filename.check_suffix file ".ml"
then (Filename.chop_suffix file ".ml") ^ ".mli"
else if Filename.check_suffix file ".mli"
then (Filename.chop_suffix file ".mli") ^ ".ml"
else failwith "Unknown source extension"
in
file, path, name
| PStr [{pstr_desc=Pstr_eval
({pexp_desc=Pexp_apply
({pexp_desc=Pexp_constant(Const_string (file, _)); _},
["", {pexp_desc=Pexp_ident{txt=lid;_}; _}]); _}, _); _}] ->
begin match List.rev (Longident.flatten lid) with
| [] -> assert false
| name :: path -> file, path, name
end
| _ ->
failwith "Cannot parse argument"
method! tydecl = function
| {ptype_kind = Ptype_abstract;
ptype_manifest =
Some{ptyp_desc=Ptyp_extension({txt="copy_typedef";_}, arg); _};
ptype_name = name; ptype_loc = loc; _
} ->
begin try
let (file, path, x) = this # source name.txt arg in
{((from_file file) # tydecl path x)
with ptype_name = name; ptype_loc = loc}
with exn -> fatal loc exn
end
| td -> td
method! mtydecl = function
| {pmtd_type = Some{pmty_desc=Pmty_extension({txt="copy_typedef";_}, arg);
pmty_loc=loc; _};
pmtd_name = name; _
} ->
begin try
let (file, path, x) = this # source name.txt arg in
{((from_file file) # mtydecl path x)
with pmtd_name = name}
with exn -> fatal loc exn
end
| td -> td
method! implementation f x =
file <- f;
super # implementation f x
method! interface f x =
file <- f;
super # interface f x
end
let () = Ast_mapper.main copy
end

141
experimental/frisch/eval.ml
View File

@ -1,141 +0,0 @@
(* A -ppx rewriter which evaluates expressions at compile-time,
using the OCaml toplevel interpreter.
The following extensions are supported:
[%eval e] in expression context: the expression e will be evaluated
at compile time, and the resulting value will be inserted as a
constant literal.
[%%eval.start] as a structure item: forthcoming structure items
until the next [%%eval.stop] will be evaluated at compile time (the
result is ignored) only.
[%%eval.start both] as a structure item: forthcoming structure
items until the next [%%eval.stop] will be evaluated at compile
time (the result is ignored), but also kept in the compiled unit.
[%%eval.load "..."] as a structure item: load the specified
.cmo unit or .cma library, so that it can be used in the forthcoming
compile-time components.
*)
module Main : sig end = struct
open Location
open Parsetree
open Ast_helper
open Outcometree
open Ast_helper.Convenience
let rec lid_of_out_ident = function
| Oide_apply _ -> assert false
| Oide_dot (x, s) -> lid_of_out_ident x ^ "." ^ s
| Oide_ident s -> s
let rec exp_of_out_value = function
| Oval_string x -> str x
| Oval_int x -> int x
| Oval_char x -> char x
| Oval_float x -> Ast_helper.Convenience.float x
| Oval_list l -> list (List.map exp_of_out_value l)
| Oval_array l -> Exp.array (List.map exp_of_out_value l)
| Oval_constr (c, args) -> constr (lid_of_out_ident c) (List.map exp_of_out_value args)
| Oval_record l ->
record
(List.map
(fun (s, v) -> lid_of_out_ident s, exp_of_out_value v) l)
| v ->
Format.eprintf "[%%eval] cannot map value to expression:@.%a@."
!Toploop.print_out_value
v;
exit 2
let empty_str_item = Str.include_ (Mod.structure [])
let run phr =
try Toploop.execute_phrase true Format.err_formatter phr
with exn ->
Errors.report_error Format.err_formatter exn;
exit 2
let get_exp loc = function
| PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e
| _ ->
Format.eprintf "%aExpression expected@."
Location.print_error loc;
exit 2
let eval _args =
let open Ast_mapper in
let eval_str_items = ref None in
let super = default_mapper in
let my_structure_item this i =
match i.pstr_desc with
| Pstr_extension(({txt="eval.load";loc}, e0), _) ->
let e0 = get_exp loc e0 in
let s =
match get_str e0 with
| Some s -> s
| None ->
Location.print_error Format.err_formatter e0.pexp_loc;
Format.eprintf "string literal expected";
exit 2
in
if not (Topdirs.load_file Format.err_formatter s) then begin
Location.print Format.err_formatter e0.pexp_loc;
exit 2;
end;
empty_str_item
| Pstr_extension(({txt="eval.start";_},
PStr [{pstr_desc=Pstr_eval (e, _);_}]
), _) when get_lid e = Some "both" ->
eval_str_items := Some true;
empty_str_item
| Pstr_extension(({txt="eval.start";_}, PStr []), _) ->
eval_str_items := Some false;
empty_str_item
| Pstr_extension(({txt="eval.stop";_}, PStr []), _) ->
eval_str_items := None;
empty_str_item
| _ ->
let s = super.structure_item this i in
match !eval_str_items with
| None -> s
| Some both ->
if not (run (Ptop_def [s])) then begin
Location.print_error Format.err_formatter s.pstr_loc;
Format.eprintf "this structure item raised an exception@.";
exit 2
end;
if both then s else empty_str_item
in
let my_expr this e =
match e.pexp_desc with
| Pexp_extension({txt="eval";loc}, e0) ->
let e0 = get_exp loc e0 in
let last_result = ref None in
let pop = !Toploop.print_out_phrase in
Toploop.print_out_phrase := begin fun _ppf -> function
| Ophr_eval (v, _) -> last_result := Some v
| r ->
Location.print_error Format.err_formatter e.pexp_loc;
Format.eprintf "error while evaluating expression:@.%a@."
pop
r;
exit 2
end;
assert (run (Ptop_def [Str.eval e0]));
Toploop.print_out_phrase := pop;
let v = match !last_result with None -> assert false | Some v -> v in
with_default_loc e0.pexp_loc (fun () -> exp_of_out_value v)
| _ ->
super.expr this e
in
Toploop.initialize_toplevel_env ();
{super with expr = my_expr; structure_item = my_structure_item}
let () = Ast_mapper.run_main eval
end

740
experimental/frisch/extension_points.txt
View File

@ -1,740 +0,0 @@
This file describes the changes on the extension_points branch.
=== Attributes
Attributes are "decorations" of the syntax tree which are ignored by
the type-checker. An attribute is made of an identifier (written id below)
and a payload (written s below).
* The identifier 'id' can be a lowercase or uppercase identifier
(including OCaml keywords) or a sequence of such atomic identifiers
separated with a dots (whitespaces are allowed around the dots).
In the Parsetree, the identifier is represented as a single string
(without spaces).
* The payload 's' can be one of three things:
- An OCaml structure (i.e. a list of structure items). Note that a
structure can be empty or reduced to a single expression.
[@id]
[@id x + 3]
[@id type t = int]
- A type expression, prefixed with the ":" character.
[@id : TYP]
- A pattern, prefixed with the "?" character, and optionally followed
by a "when" clause:
[@id ? PAT]
[@id ? PAT when EXPR]
Attributes on expressions, type expressions, module expressions, module type expressions,
patterns, class expressions, class type expressions:
... [@id s]
The same syntax [@id s] is also available to add attributes on
constructors and labels in type declarations:
type t =
| A [@id1]
| B [@id2] of int [@id3]
Here, id1 (resp. id2) is attached to the constructor A (resp. B)
and id3 is attached to the int type expression. Example on records:
type t =
{
x [@id1]: int;
mutable y [@id2] [@id3]: string [@id4];
}
Attributes on items:
... [@@id s]
Items designate:
- structure and signature items (for type declarations, recursive modules, class
declarations and class type declarations, each component has its own attributes)
- class fields and class type fields
- each binding in a let declaration (for let structure item, local let-bindings in
expression and class expressions)
For instance, consider:
type t1 = ... [@@id1] [@@id2] and t2 = ... [@@id3] [@@id4]
Here, the attributes on t1 are id1, id23; the attributes on
t2 are id3 and id4.
Similarly for:
let x1 = ... [@@id1] [@@id2] and x2 = ... [@@id3] [@@id4]
Floating attributes:
The [@@@id s] form defines an attribute which stands as a
stand-alone signature or structure item (not attached to another
item).
Example:
module type S = sig
[@@id1]
type t
[@@id2]
[@@@id3] [@@@id4]
[@@@id5]
type s
[@@id6]
end
Here, id1, id3, id4, id5 are floating attributes, while
id2 is attached to the type t and id6 is attached to the type s.
=== Extension nodes
Extension nodes replace valid components in the syntax tree. They are
normally interpreted and expanded by AST mapper. The type-checker
fails when it encounters such an extension node. An extension node is
made of an identifier (an "LIDENT", written id below) and an optional
expression (written expr below).
Two syntaxes exist for extension node:
As expressions, type expressions, module expressions, module type expressions,
patterns, class expressions, class type expressions:
[%id s]
As structure item, signature item, class field, class type field:
[%%id s]
As other structure item, signature item, class field or class type
field, attributes can be attached to a [%%id s] extension node.
=== Alternative syntax for attributes and extensions on specific kinds of nodes
All expression constructions starting with a keyword (EXPR = KW REST) support an
alternative syntax for attributes and/or extensions:
KW[@id s]...[@id s] REST
---->
EXPR[@id s]...[@id s]
KW%id REST
---->
[%id EXPR]
KW%id[@id s]...[@id s] REST
---->
[%id EXPR[@id s]...[@id s]]
where KW can stand for:
assert
begin
for
fun
function
if
lazy
let
let module
let open
match
new
object
try
while
For instance:
let[@foo] x = 2 in x + 1 ==== (let x = 2 in x + 1)[@foo]
begin[@foo] ... end ==== (begin ... end)[@foo]
match%foo e with ... ==== [%foo match e with ...]
The let-binding form of structure items also supports this form:
let%foo x = ... ==== [%%foo let x = ...]
=== Quoted strings
Quoted strings gives a different syntax to write string literals in
OCaml code. This will typically be used to support embedding pieces
of foreign syntax fragments (to be interpret by a -ppx filter or just
a library) in OCaml code.
The opening delimiter has the form {id| where id is a (possibly empty)
sequence of lowercase letters. The corresponding closing delimiter is
|id} (the same identifier). Contrary to regular OCaml string
literals, quoted strings don't interpret any character in a special
way.
Example:
String.length {|\"|} (* returns 2 *)
String.length {foo|\"|foo} (* returns 2 *)
The fact that a string literal comes from a quoted string is kept in
the Parsetree representation. The Astypes.Const_string constructor is
now defined as:
| Const_string of string * string option
where the "string option" represents the delimiter (None for a string
literal with the regular syntax).
=== Representation of attributes in the Parsetree
Attributes as standalone signature/structure items are represented
by a new constructor:
| Psig_attribute of attribute
| Pstr_attribute of attribute
Most other attributes are stored in an extra field in their record:
and expression = {
...
pexp_attributes: attribute list;
...
}
and type_declaration = {
...
ptype_attributes: attribute list;
...
}
In a previous version, attributes on expressions (and types, patterns,
etc) used to be stored as a new constructor. The current choice makes
it easier to pattern match on structured AST fragments while ignoring
attributes.
For open/include signature/structure items and exception rebind
structure item, the attributes are stored directly in the constructor
of the item:
| Pstr_open of Longident.t loc * attribute list
=== Attributes in the Typedtree
The Typedtree representation has been updated to follow closely the
Parsetree, and attributes are kept exactly as in the Parsetree. This
can allow external tools to process .cmt/.cmti files and process
attributes in them. An example of a mini-ocamldoc based on this
technique is in experimental/frisch/minidoc.ml.
=== Other changes to the parser and Parsetree
--- Introducing Ast_helper module
This module simplifies the creation of AST fragments, without having to
touch the concrete type definitions of Parsetree. Record and sum types
are encapsulated in builder functions, with some optional arguments, e.g.
to represent attributes.
--- Relaxing the syntax for signatures and structures
It is now possible to start a signature or a structure with a ";;" token and to have two successive ";;" tokens.
Rationale:
In an intermediate version of this branch, floating attributes shared
the same syntax as item attributes, with the constraints that they
had to appear either at the beginning of their structure or signature,
or after ";;". The relaxation above made is possible to always prefix
a floating attributes by ";;" independently of its context.
Floating attributes now have a custom syntax [@@@id], but this changes
is harmless, and the same argument holds for toplevel expressions:
it is always possile to write:
;; print_endline "bla";;
without having to care about whether the previous structure item
ends with ";;" or not.
-- Relaxing the syntax for exception declarations
The parser now accepts the same syntax for exceptioon declarations as for constructor declarations,
which permits the GADT syntax:
exception A : int -> foo
The type-checker rejects this form. Note that it is also possible to
define exception whose name is () or ::.
Attributes can be put on the constructor or on the whole declaration:
exception A[@foo] of int [@@bar]
Rationale:
One less notion in the Parsetree, more uniform parsing. Also
open the door to existentials in exception constructors.
--- Relaxing the syntax for recursive modules
Before:
module X1 : MT1 = M1 and ... and Xn : MTn = Mn
Now:
module X1 = M1 and ... and Xn = Mn
(with the usual sugar that Xi = (Mi : MTi) can be written as Xi : MTi = Mi
which gives the old syntax)
The type-checker fails when a module expression is not of
the form (M : MT)
Rationale:
1. More uniform representation in the Parsetree.
2. The type-checker can be made more clever in the future to support
other forms of module expressions (e.g. functions with an explicit
constraint on its result; or a structure with only type-level
components).
--- Turning some tuple or n-ary constructors into records
Before:
| Pstr_module of string loc * module_expr
After:
| Pstr_module of module_binding
...
and module_binding =
{
pmb_name: string loc;
pmb_expr: module_expr;
pmb_attributes: attribute list;
}
Rationale:
More self-documented, more robust to future additions (such as
attributes), simplifies some code.
--- Keeping names inside value_description and type_declaration
Before:
| Psig_type of (string loc * type_declaration) list
After:
| Psig_type of type_declaration list
....
and type_declaration =
{ ptype_name: string loc;
...
}
Rationale:
More self-documented, simplifies some code.
--- Better representation of variance information on type parameters
Introduced a new type Asttypes.variance to represent variance
(Covariant/Contravariant/Invariant) and use it instead of bool * bool
in Parsetree. Moreover, variance information is now attached
directly to the parameters fields:
and type_declaration =
{ ptype_name: string loc;
- ptype_params: string loc option list;
+ ptype_params: (string loc option * variance) list;
ptype_cstrs: (core_type * core_type * Location.t) list;
ptype_kind: type_kind;
ptype_private: private_flag;
ptype_manifest: core_type option;
- ptype_variance: (bool * bool) list;
ptype_attributes: attribute list;
ptype_loc: Location.t }
--- Getting rid of 'Default' case in Astypes.rec_flag
This constructor was used internally only during the compilation of
default expression for optional arguments, in order to trigger a
subsequent optimization (see PR#5975). This behavior is now
implemented by creating an attribute internally (whose name "#default"
cannot be used in real programs).
Rationale:
- Attributes give a way to encode information local to the
type-checker without polluting the definition of the Parsetree.
--- Simpler and more faithful representation of object types
- | Ptyp_object of core_field_type list
+ | Ptyp_object of (string * core_type) list * closed_flag
(and get rid of Parsetree.core_field_type)
And same in the Typedtree.
Rationale:
- More faithful representation of the syntax really supported
(i.e. the ".." can only be the last field).
- One less "concept" in the Parsetree.
--- Do not require empty Ptyp_poly nodes in the Parsetree
The type-checker automatically inserts Ptyp_poly node (with no
variable) where needed. It is still allowed to put empty
Ptyp_poly nodes in the Parsetree.
Rationale:
- Less chance that Ast-related code forget to insert those nodes.
To be discussed: should we segrate simple_poly_type from core_type in the
Parsetree to prevent Ptyp_poly nodes to be inserted in the wrong place?
--- Use constructor names closer to concrete syntax
E.g. Pcf_cstr -> Pcf_constraint.
Rationale:
- Make the Parsetree more self-documented.
--- Merge concrete/virtual val and method constructors
As in the Typedtree.
- | Pcf_valvirt of (string loc * mutable_flag * core_type)
- | Pcf_val of (string loc * mutable_flag * override_flag * expression)
- | Pcf_virt of (string loc * private_flag * core_type)
- | Pcf_meth of (string loc * private_flag * override_flag * expression)
+ | Pcf_val of (string loc * mutable_flag * class_field_kind)
+ | Pcf_method of (string loc * private_flag * class_field_kind
...
+and class_field_kind =
+ | Cfk_virtual of core_type
+ | Cfk_concrete of override_flag * expression
+
--- Explicit representation of "when" guards
Replaced the "(pattern * expression) list" argument of Pexp_function, Pexp_match, Pexp_try
with "case list", with case defined as:
{
pc_lhs: pattern;
pc_guard: expression option;
pc_rhs: expression;
}
and get rid of Pexp_when. Idem in the Typedtree.
Rationale:
- Make it explicit when the guard can appear.
--- Get rid of "fun p when guard -> e"
See #5939, #5936.
--- Get rid of the location argument on pci_params
It was only used for error messages, and we get better location using
the location of each parameter variable.
--- More faithful representation of "with constraint"
All kinds of "with constraints" used to be represented together with a
Longident.t denoting the constrained identifier. Now, each constraint
keeps its own constrainted identifier, which allows us to express more
invariants in the Parsetree (such as: := constraints cannot be on qualified
identifiers). Also, we avoid mixing in a single Longident.t identifier
which can be LIDENT or UIDENT.
--- Get rid of the "#c [> `A]" syntax
See #5936, #5983.
--- Keep interval patterns in the Parsetree
They used to be expanded into or-patterns by the parser. It is better to do
the expansion in the type-checker to allow -ppx rewriters to see the interval
patterns.
Note: Camlp4 parsers still expand interval patterns themselves (TODO?).
--- Get rid of Pexp_assertfalse
Do not treat specially "assert false" in the parser any more, but
instead in the type-checker. This simplifies the Parsetree and avoids
a potential source of confusion. Moreove, this ensures that
attributes can be put (and used by ppx rewriters) on the "false"
expressions. This is also more robust, since it checks that the
condition is the constructor "false" after type-checking the condition:
- if "false" is redefined (as a constructor of a different sum type),
an error will be reported;
- "extra" layers which are represented as exp_extra in the typedtree
won't break the detection of the "false", e.g. the following will
be recognized as "assert false":
assert(false : bool)
assert(let open X in false)
Note: Camlp4's AST still has a special representation for "assert false".
--- Get rid of the "explicit arity" flag on Pexp_construct/Ppat_construct
This Boolean was used (only by camlp5?) to indicate that the tuple
(expression/pattern) used as the argument was intended to correspond
to the arity of an n-ary constructor. In particular, this allowed
the revised syntax to distinguish "A x y" from "A (x, y)" (the second one
being wrapped in an extra fake tuple) and get a proper error message
if "A (x, y)" was used with a constructor expecting two arguments.
The feature has been preserved, but the information that a
Pexp_construct/Ppat_constructo node has an "exact arity" is now
propagated used as am attribute "ocaml.explicit_arity" on that node.
--- Split Pexp_function into Pexp_function/Pexp_fun
This reflects more closely the concrete syntax and removes cases of
Parsetree fragments which don't correspond to concrete syntax.
Typedtree has not been changed.
Note: Camlp4's AST has not been adapted.
--- Split Pexp_constraint into Pexp_constraint/Pexp_coerce
Idem in the Typedtree.
This reflects more closely the concrete syntax.
Note: Camlp4's AST has not been adapted.
--- Accept abstract module type declaration in structures
Previously, we could declare:
module type S
in signatures, but not implementations. To make the syntax, the Parsetree
and the type-checker more uniform, this is now also allowed in structures
(altough this is probably useless in practice).
=== More TODOs
- Adapt pprintast to print attributes and extension nodes.
- Adapt Camlp4 (both its parser(s) and its internal representation of OCaml ASTs).
- Consider adding hooks to the type-checker so that custom extension expanders can be registered (a la OCaml Templates).
- Make the Ast_helper module more user-friendly (e.g. with optional arguments and good default values) and/or
expose higher-level convenience functions.
- Document Ast_helper modules.
=== Use cases
From https://github.com/gasche/ocaml-syntax-extension-discussion/wiki/Use-Cases
-- Bisect
let f x =
match List.map foo [x; a x; b x] with
| [y1; y2; y3] -> tata
| _ -> assert false [@bisect VISIT]
;;[@@bisect IGNORE-BEGIN]
let unused = ()
;;[@@bisect IGNORE-END]
-- OCamldoc
val stats : ('a, 'b) t -> statistics
[@@doc
"[Hashtbl.stats tbl] returns statistics about the table [tbl]:
number of buckets, size of the biggest bucket, distribution of
buckets by size."
]
[@@since "4.00.0"]
;;[@@doc section 6 "Functorial interface"]
module type HashedType =
sig
type t
[@@doc "The type of the hashtable keys."]
val equal : t -> t -> bool
[@@doc "The equality predicate used to compare keys."]
end
-- type-conv, deriving
type t = {
x : int [@default 42];
y : int [@default 3] [@sexp_drop_default];
z : int [@default 3] [@sexp_drop_if z_test];
} [@@sexp]
type r1 = {
r1_l1 : int;
r1_l2 : int;
} [@@deriving (Dump, Eq, Show, Typeable, Pickle, Functor)]
-- camlp4 map/fold generators
type variable = string
and term =
| Var of variable
| Lam of variable * term
| App of term * term
class map = [%generate_map term]
or:
[%%generate_map map term]
-- ocaml-rpc
type t = { foo [@rpc "type"]: int; bar [@rpc "let"]: int }
[@@ rpc]
or:
type t = { foo: int; bar: int }
[@@ rpc ("foo" > "type"), ("bar" > "let")]
-- pa_monad
begin%monad
a <-- [1; 2; 3];
b <-- [3; 4; 5];
return (a + b)
end
-- pa_lwt
let%lwt x = start_thread foo
and y = start_other_thread foo in
try%lwt
let%for_lwt (x, y) = waiting_threads in
compute blah
with Killed -> bar
-- Bolt
let funct n =
[%log "funct(%d)" n LEVEL DEBUG];
for i = 1 to n do
print_endline "..."
done
-- pre-polyrecord
let r = [%polyrec x = 1; y = ref None]
let () = [%polyrec r.y <- Some 2]
-- orakuda
function%regexp
| "$/^[0-9]+$/" as v -> `Int (int_of_string v#_0)
| "$/^[a-z][A-Za-z0-9_]*$" as v -> `Variable v#_0
| _ -> failwith "parse error"
-- bitstring
let bits = Bitstring.bitstring_of_file "/bin/ls" in
match%bitstring bits with
| [ 0x7f, 8; "ELF", 24, string; (* ELF magic number *)
e_ident, Mul(12,8), bitstring; (* ELF identifier *)
e_type, 16, littleendian; (* object file type *)
e_machine, 16, littleendian (* architecture *)
] ->
printf "This is an ELF binary, type %d, arch %d\n"
e_type e_machine
-- sedlex
let rec token buf =
let%regexp ('a'..'z'|'A'..'Z') = letter in
match%sedlex buf with
| number -> Printf.printf "Number %s\n" (Sedlexing.Latin1.lexeme buf); token buf
| letter, Star ('A'..'Z' | 'a'..'z' | digit) -> Printf.printf "Ident %s\n" (Sedlexing.Latin1.lexeme buf); token buf
| Plus xml_blank -> token buf
| Plus (Chars "+*-/") -> Printf.printf "Op %s\n" (Sedlexing.Latin1.lexeme buf); token buf
| Range(128,255) -> print_endline "Non ASCII"
| eof -> print_endline "EOF"
| _ -> failwith "Unexpected character"
-- cppo
[%%ifdef DEBUG]
[%%define debug(s) = Printf.eprintf "[%S %i] %s\n%!" __FILE__ __LINE__ s]
[%%else]
[%%define debug(s) = ()]
[%%endif]
debug("test")
-- PG'OCaml
let fetch_users dbh =
[%pgsql dbh "select id, name from users"]
-- Macaque
let names view = [%view {name = t.name}, t <- !view]"
-- Cass
let color1 = [%css{| black |}]
let color2 = [%css{| gray |}]
let button = [%css{|
.button {
$Css.gradient ~low:color2 ~high:color1$;
color: white;
$Css.top_rounded$;
|}]

118
experimental/frisch/ifdef.ml
View File

@ -1,118 +0,0 @@
(* This filter implements the following extensions:
In structures:
[%%IFDEF X]
... --> included if the environment variable X is defined
[%%ELSE]
... --> included if the environment variable X is undefined
[%%END]
In expressions:
[%GETENV X] ---> the string literal representing the compile-time value
of environment variable X
In variant type declarations:
type t =
..
| C [@IFDEF X] of ... --> the constructor is kept only if X is defined
In match clauses (function/match...with/try...with):
P when [%IFDEF X] -> E --> the case is kept only if X is defined
*)
open Ast_helper
open! Asttypes
open Parsetree
open Longident
let getenv loc arg =
match arg with
| PStr [{pstr_desc=Pstr_eval({pexp_desc = Pexp_construct ({txt = Lident sym; _}, None); _}, _); _}] ->
(try Sys.getenv sym with Not_found -> "")
| _ ->
Format.eprintf "%a** IFDEF: bad syntax."
Location.print_error loc;
exit 2
let empty_str_item = Str.include_ (Mod.structure [])
let ifdef _args =
let stack = ref [] in
let eval_attributes =
List.for_all
(function
| {txt="IFDEF"; loc}, arg -> getenv loc arg <> ""
| {txt="IFNDEF"; loc}, arg -> getenv loc arg = ""
| _ -> true)
in
let filter_constr cd = eval_attributes cd.pcd_attributes in
let open Ast_mapper in
let super = default_mapper in
{
super with
type_declaration =
(fun this td ->
let td =
match td with
| {ptype_kind = Ptype_variant cstrs; _} as td ->
{td
with ptype_kind = Ptype_variant(List.filter filter_constr cstrs)}
| td -> td
in
super.type_declaration this td
);
cases =
(fun this l ->
let l =
List.fold_right
(fun c rest ->
match c with
| {pc_guard=Some {pexp_desc=Pexp_extension({txt="IFDEF";loc}, arg); _}; _} ->
if getenv loc arg = "" then rest else {c with pc_guard=None} :: rest
| c -> c :: rest
) l []
in
super.cases this l
);
structure_item =
(fun this i ->
match i.pstr_desc, !stack with
| Pstr_extension(({txt="IFDEF";loc}, arg), _), _ ->
stack := (getenv loc arg <> "") :: !stack;
empty_str_item
| Pstr_extension(({txt="ELSE";loc=_}, _), _), (hd :: tl) ->
stack := not hd :: tl;
empty_str_item
| Pstr_extension(({txt="END";loc=_}, _), _), _ :: tl ->
stack := tl;
empty_str_item
| Pstr_extension(({txt="ELSE"|"END";loc}, _), _), [] ->
Format.printf "%a** IFDEF: mo matching [%%%%IFDEF]"
Location.print_error loc;
exit 2
| _, (true :: _ | []) -> super.structure_item this i
| _, false :: _ -> empty_str_item
);
expr =
(fun this -> function
| {pexp_desc = Pexp_extension({txt="GETENV";loc=l}, arg);
pexp_loc = loc; _} ->
Exp.constant ~loc (Const_string (getenv l arg, None))
| x -> super.expr this x
);
}
let () = Ast_mapper.run_main ifdef

112
experimental/frisch/js_syntax.ml
View File

@ -1,112 +0,0 @@
(* This example shows how the AST mapping approach could be used
instead of Camlp4 in order to give a nice syntax for js_of_ocaml
(properties and method calls). The code below overloads regular
syntax for field projection and assignment for Javascript
properties, and (currified) method call for Javascript method
calls. This is enabled under the scope of the [%js ...] extension:
Get property: [%js o.x]
Set property: [%js o.x <- e]
Method call: [%js o#x e1 e2]
*)
open Asttypes
open! Location
open Parsetree
open Longident
open Ast_helper
open Ast_helper.Convenience
(* A few local helper functions to simplify the creation of AST nodes. *)
let apply_ f l = app (evar f) l
let oobject l = Typ.object_ l Open
let annot e t = Exp.constraint_ e t
let rnd = Random.State.make [|0x513511d4|]
let random_var () = Format.sprintf "a%08Lx" (Random.State.int64 rnd 0x100000000L : Int64.t)
let fresh_type () = Typ.var (random_var ())
let unescape lab =
assert (lab <> "");
let lab =
if lab.[0] = '_' then String.sub lab 1 (String.length lab - 1) else lab
in
try
let i = String.rindex lab '_' in
if i = 0 then raise Not_found;
String.sub lab 0 i
with Not_found ->
lab
let method_literal meth = str (unescape meth)
let access_object loc e m m_typ f =
let open Exp in
with_default_loc loc
(fun () ->
let x = random_var () in
let obj_type = random_var () in
let obj = annot e Typ.(tconstr "Js.t" [alias (oobject []) obj_type]) in
let y = random_var () in
let o = annot (evar y) (Typ.var obj_type) in
let constr = lam (pvar y) (annot (send o m) m_typ) in
let_in [Vb.mk (pvar x) obj; Vb.mk (Pat.any ()) constr] (f (evar x))
)
let method_call loc obj meth args =
let args = List.map (fun e -> (e, fresh_type ())) args in
let ret_type = fresh_type () in
let method_type =
List.fold_right
(fun (_, arg_ty) rem_ty -> Typ.arrow "" arg_ty rem_ty)
args
(tconstr "Js.meth" [ret_type])
in
access_object loc obj meth method_type
(fun x ->
let args =
List.map (fun (e, t) -> apply_ "Js.Unsafe.inject" [annot e t]) args
in
annot (apply_ "Js.Unsafe.meth_call" [x; method_literal meth; Exp.array args]) ret_type
)
let mapper _args =
let open Ast_mapper in
let rec mk ~js =
let super = default_mapper in
let expr this e =
let loc = e.pexp_loc in
match e.pexp_desc with
| Pexp_extension({txt="js";_}, PStr [{pstr_desc=Pstr_eval (e, _);_}]) ->
let this = mk ~js:true in this.expr this e
| Pexp_field (o, {txt = Lident meth; loc = _}) when js ->
let o = this.expr this o in
let prop_type = fresh_type () in
let meth_type = tconstr "Js.gen_prop" [oobject ["get", prop_type]] in
access_object loc o meth meth_type
(fun x -> annot (apply_ "Js.Unsafe.get" [x; method_literal meth]) prop_type)
| Pexp_setfield (o, {txt = Lident meth; loc = _}, e) when js ->
let o = this.expr this o and e = this.expr this e in
let prop_type = fresh_type () in
let meth_type = tconstr "Js.gen_prop" [oobject ["set", Typ.arrow "" prop_type (tconstr "unit" [])]] in
access_object loc o meth meth_type
(fun x -> apply_ "Js.Unsafe.set" [x; method_literal meth; annot e prop_type])
| Pexp_apply ({pexp_desc = Pexp_send (o, meth); pexp_loc = loc; _}, args) when js ->
method_call loc o meth (List.map (this.expr this) (List.map snd args))
| Pexp_send (o, meth) when js ->
method_call loc o meth []
| _ ->
super.expr this e
in
{super with expr}
in
mk ~js:false
let () = Ast_mapper.run_main mapper

27
experimental/frisch/metaquot_test.ml
View File

@ -1,27 +0,0 @@
let loc1 = Location.in_file "111"
let loc2 = Location.in_file "222"
let x = [%expr foobar]
let pat = [%pat? _ as x]
let e = [%expr fun (x, [%p pat]) -> x + [%e x] + 1]
let () = Format.printf "%a@." (Printast.expression 0) e
;;[@@metaloc loc2]
let e = [%expr fun (x, [%p pat]) -> x + [%e x] + 1] [@metaloc loc1]
let () = Format.printf "%a@." (Printast.expression 0) e
let e = [%expr fun (x, [%p pat]) -> x + [%e x] + 1]
let () = Format.printf "%a@." (Printast.expression 0) e
let mytype = [%type: int list]
let s = [%str type t = A of [%t mytype] | B of string]
let () = Format.printf "%a@." Printast.implementation s
let f = function
| ([%expr [%e? x] + 1]
| [%expr 1 + [%e? x]]) as e0 -> [%expr succ [%e x]] [@metaloc e0.pexp_loc]
| e -> e

72
experimental/frisch/minidoc.ml
View File

@ -1,72 +0,0 @@
open Asttypes
open Parsetree
open Typedtree
open Longident
let pendings = ref []
let doc ppf = function
| ({txt="doc";_}, PStr [{pstr_desc=Pstr_eval(e, _); _}]) ->
begin match e.pexp_desc with
| Pexp_constant(Const_string (s, _)) ->
Format.fprintf ppf " --> %s@." s
| Pexp_apply({pexp_desc=Pexp_ident{txt=Lident "section"}},
["", {pexp_desc=Pexp_constant(Const_string (s, _))}]) ->
Format.fprintf ppf " ==== %s ====@." s
| _ -> ()
end
| _ -> ()
let rec signature path ppf sg =
List.iter (signature_item path ppf) sg.sig_items
and signature_item path ppf si =
match si.sig_desc with
| Tsig_value x ->
Format.fprintf ppf " val %s: %a@." x.val_name.txt Printtyp.type_expr x.val_desc.ctyp_type;
List.iter (doc ppf) x.val_attributes
| Tsig_module x ->
begin match x.md_type.mty_desc with
| Tmty_ident (_, {txt=lid}) ->
Format.fprintf ppf " module %s: %a@." x.md_name.txt Printtyp.longident lid
| Tmty_signature sg ->
pendings := `Module (path ^ "." ^ x.md_name.txt, sg) :: !pendings;
Format.fprintf ppf " module %s: ... (see below)@." x.md_name.txt;
| _ ->
Format.fprintf ppf " module %s: ...@." x.md_name.txt;
end;
List.iter (doc ppf) x.md_attributes
| Tsig_type l ->
List.iter (type_declaration ppf) l
| Tsig_attribute x ->
doc ppf x
| _ ->
()
and type_declaration ppf x =
Format.fprintf ppf " type %s@." x.typ_name.txt;
List.iter (doc ppf) x.typ_attributes
let component = function
| `Module (path, sg) ->
Format.printf "[[[ Interface for %s ]]]@.%a@."
path (signature path) sg
let () =
let open Cmt_format in
for i = 1 to Array.length Sys.argv - 1 do
let fn = Sys.argv.(i) in
try
let {cmt_annots; cmt_modname; _} = read_cmt fn in
begin match cmt_annots with
| Interface sg -> component (`Module (cmt_modname, sg))
| _ -> ()
end;
while !pendings <> [] do
let l = List.rev !pendings in
pendings := [];
List.iter component l
done
with exn ->
Format.printf "Cannot read '%s': %s@." fn (Printexc.to_string exn)
done

89
experimental/frisch/my_lexer2.mll
View File

@ -1,89 +0,0 @@
{
open Parser
}
let newline = ('\013'* '\010')
let blank = [' ' '\009' '\012']
let lowercase = ['a'-'z' '_']
let uppercase = ['A'-'Z']
let identchar = ['A'-'Z' 'a'-'z' '_' '\'' '0'-'9']
let lowercase_latin1 = ['a'-'z' '\223'-'\246' '\248'-'\255' '_']
let uppercase_latin1 = ['A'-'Z' '\192'-'\214' '\216'-'\222']
let identchar_latin1 =
['A'-'Z' 'a'-'z' '_' '\192'-'\214' '\216'-'\246' '\248'-'\255' '\'' '0'-'9']
let symbolchar =
['!' '$' '%' '&' '*' '+' '-' '.' '/' ':' '<' '=' '>' '?' '@' '^' '|' '~']
let dotsymbolchar =
['!' '$' '%' '&' '*' '+' '-' '/' ':' '=' '>' '?' '@' '^' '|' '~']
let decimal_literal =
['0'-'9'] ['0'-'9' '_']*
let hex_digit =
['0'-'9' 'A'-'F' 'a'-'f']
let hex_literal =
'0' ['x' 'X'] ['0'-'9' 'A'-'F' 'a'-'f']['0'-'9' 'A'-'F' 'a'-'f' '_']*
let oct_literal =
'0' ['o' 'O'] ['0'-'7'] ['0'-'7' '_']*
let bin_literal =
'0' ['b' 'B'] ['0'-'1'] ['0'-'1' '_']*
let int_literal =
decimal_literal | hex_literal | oct_literal | bin_literal
let float_literal =
['0'-'9'] ['0'-'9' '_']*
('.' ['0'-'9' '_']* )?
(['e' 'E'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
let hex_float_literal =
'0' ['x' 'X']
['0'-'9' 'A'-'F' 'a'-'f'] ['0'-'9' 'A'-'F' 'a'-'f' '_']*
('.' ['0'-'9' 'A'-'F' 'a'-'f' '_']* )?
(['p' 'P'] ['+' '-']? ['0'-'9'] ['0'-'9' '_']* )?
let literal_modifier = ['G'-'Z' 'g'-'z']
rule token = parse
| eof { EOF }
| lowercase identchar * { TILDE }
| "&" { AMPERSAND }
| "&&" { AMPERAMPER }
| "`" { BACKQUOTE }
| "\'" { QUOTE }
| "(" { LPAREN }
| ")" { RPAREN }
| "*" { STAR }
| "," { COMMA }
| "->" { MINUSGREATER }
| "." { DOT }
| ".." { DOTDOT }
| ":" { COLON }
| "::" { COLONCOLON }
| ":=" { COLONEQUAL }
| ":>" { COLONGREATER }
| ";" { SEMI }
| ";;" { SEMISEMI }
| "<" { LESS }
| "<-" { LESSMINUS }
| "=" { EQUAL }
| "[" { LBRACKET }
| "[|" { LBRACKETBAR }
| "[<" { LBRACKETLESS }
| "[>" { LBRACKETGREATER }
| "]" { RBRACKET }
| "{" { LBRACE }
| "{<" { LBRACELESS }
| "|" { BAR }
| "||" { BARBAR }
| "|]" { BARRBRACKET }
| ">" { GREATER }
| ">]" { GREATERRBRACKET }
| "}" { RBRACE }
| ">}" { GREATERRBRACE }
| "[@" { LBRACKETAT }
| "[@@" { LBRACKETATAT }
| "[@@@" { LBRACKETATATAT }
| "[%" { LBRACKETPERCENT }
| "[%%" { LBRACKETPERCENTPERCENT }
| "!" { BANG }
| "!=" { INFIXOP0 "!=" }
| "+" { PLUS }
| "+." { PLUSDOT }
| "+=" { PLUSEQ }
| "-" { MINUS }
| "-." { MINUSDOT }
| _ { EOL }

113
experimental/frisch/nomli.ml
View File

@ -1,113 +0,0 @@
(** Creates an mli from an annotated ml file. *)
open Path
open Location
open Longident
open Misc
open Parsetree
open Types
open! Typedtree
open Ast_helper
let mli_attr l = Convenience.find_attr "mli" l
let map_flatten f l =
List.flatten (List.map f l)
let is_abstract = function
| PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_ident{txt=Lident "abstract"}},_)}] -> true
| _ -> false
let explicit_type_of_expr = function
| {pexp_desc=Pexp_constraint({pexp_desc=Pexp_ident{txt=Lident id}}, t)} -> [id, t]
| _ -> []
let explicit_type = function
| PStr [{pstr_desc=Pstr_eval({pexp_desc=Pexp_tuple el},_)}] -> map_flatten explicit_type_of_expr el
| PStr [{pstr_desc=Pstr_eval(e,_)}] -> explicit_type_of_expr e
| _ -> []
let rec structure l : Parsetree.signature =
map_flatten (structure_item l.str_final_env) l.str_items
and structure_item final_env x : Parsetree.signature =
match x.str_desc with
| Tstr_module {mb_name; mb_expr} ->
begin match module_expr mb_expr with
| Some mty -> [Sig.module_ (Md.mk mb_name mty)]
| None -> []
end
| Tstr_type l ->
begin match map_flatten type_declaration l with
| [] -> []
| l -> [Sig.type_ l]
end
| Tstr_value (_, l) ->
map_flatten (value_binding final_env) l
| _ ->
[]
and module_expr x : Parsetree.module_type option =
match x.mod_desc with
| Tmod_structure l ->
(* No explicit signature: use [@@mli] attributes in the sub-structure to define exported components. *)
begin match structure l with
| [] -> None
| l -> Some (Mty.signature l)
end
| Tmod_constraint (_, _, Tmodtype_explicit mty, _) ->
(* Explicit signature: if non-empty, use it for the mli; if empty, drop the sub-module *)
begin match Untypeast.untype_module_type mty with
| {pmty_desc=Pmty_signature []} -> None
| pmty -> Some pmty
end
| _ ->
None
and type_declaration x : Parsetree.type_declaration list =
match mli_attr x.typ_attributes with
| None -> []
| Some attrs ->
let pdecl = Untypeast.untype_type_declaration x in
(* If the declaration is marked with [@@mli abstract], make it abstract *)
let pdecl = if is_abstract attrs then {pdecl with ptype_kind=Ptype_abstract} else pdecl in
[pdecl]
and value_binding final_env x : Parsetree.signature =
match mli_attr x.vb_attributes with
| None -> []
| Some attrs ->
match explicit_type attrs with
| [] ->
(* No explicit type, use the inferred type for bound identifiers *)
let ids = let_bound_idents [x] in
List.map
(fun id ->
let ty = typ (Env.find_value (Pident id) final_env).val_type in
Sig.value (Val.mk (mknoloc (Ident.name id)) ty)
) ids
| l ->
(* Explicit type given with the syntax [@@mli (x1 : ty1), ..., (xn : tyn)] *)
List.map (fun (id, ty) -> Sig.value (Val.mk (mknoloc id) ty)) l
and typ x : Parsetree.core_type =
(* print the inferred type and parse the result again *)
let t = Printtyp.type_scheme Format.str_formatter x in
let s = Format.flush_str_formatter t in
Parse.core_type (Lexing.from_string s)
let mli_of_ml ppf sourcefile =
Location.input_name := sourcefile;
Compmisc.init_path false;
let file = Filename.remove_extension sourcefile in
let modulename = String.capitalize(Filename.basename file) in
Env.set_unit_name modulename;
let inputfile = Pparse.preprocess sourcefile in
let env = Compmisc.initial_env() in
let ast = Pparse.file ppf inputfile Parse.implementation Config.ast_impl_magic_number in
let (str, _coerc) = Typemod.type_implementation sourcefile file modulename env ast in
let sg = structure str in
Format.printf "%a@." Pprintast.signature sg
let () =
mli_of_ml Format.err_formatter Sys.argv.(1)

100
experimental/frisch/ppx_builder.ml
View File

@ -1,100 +0,0 @@
(*
A toy -ppx rewriter which illustrates code generation based on type
declarations. Here, we create builder function from record and sum
type declarations annotated with attribute [@@builder]: one function
per record type, one function per constructor of a sum type.
We recognize some special attributes on record fields (or their associated
type) and on constructor argument types:
- [@label id]: specify a label for the parameter of the builder function
(for records, it is set automatically from the label name
but it can be overridden).
- [@opt]: the parameter is optional (this assume that the field/argument
has an option type).
- [@default expr]: the parameter is optional, with a default value
(cannot be used with [@opt]).
*)
module Main : sig end = struct
open Asttypes
open! Location
open Parsetree
open Ast_helper
open Ast_helper.Convenience
let fatal loc s =
Location.print_error Format.err_formatter loc;
prerr_endline s;
exit 2
let param named name loc attrs =
let default = find_attr_expr "default" attrs in
let opt = has_attr "opt" attrs in
let label =
match find_attr_expr "label" attrs with
| None -> if named then name else ""
| Some e ->
match get_lid e with
| Some s -> s
| None -> fatal e.pexp_loc "'label' attribute must be a string literal"
in
let label =
if default <> None || opt then
if label = "" then fatal loc "Optional arguments must be named" else "?" ^ label
else label
in
if default <> None && opt then fatal loc "Cannot have both 'opt' and 'default' attributes";
lam ~label ?default (pvar name), (name, evar name)
let gen_builder tdecl =
if has_attr "builder" tdecl.ptype_attributes then
match tdecl.ptype_kind with
| Ptype_record fields ->
let field pld =
param true pld.pld_name.txt pld.pld_loc (pld.pld_attributes @ pld.pld_type.ptyp_attributes)
in
let fields = List.map field fields in
let body = lam (punit()) (record (List.map snd fields)) in
let f = List.fold_right (fun (f, _) k -> f k) fields body in
let s = Str.value Nonrecursive [Vb.mk (pvar tdecl.ptype_name.txt) f] in
[s]
| Ptype_variant constrs ->
let constr {pcd_name={txt=name;_}; pcd_args=args; _} =
let arg i ty = param false (Printf.sprintf "x%i" i) ty.ptyp_loc ty.ptyp_attributes in
let args = List.mapi arg args in
let body = lam (punit()) (constr name (List.map (fun (_, (_, e)) -> e) args)) in
let f = List.fold_right (fun (f, _) k -> f k) args body in
let s = Str.value Nonrecursive [Vb.mk (pvar (tdecl.ptype_name.txt ^ "_" ^ name)) f] in
s
in
List.map constr constrs
| _ -> []
else
[]
let gen_builder tdecl =
with_default_loc tdecl.ptype_loc (fun () -> gen_builder tdecl)
let builder _args =
let open Ast_mapper in
let super = default_mapper in
{super
with
structure =
(fun this l ->
List.flatten
(List.map
(function
| {pstr_desc = Pstr_type tdecls; _} as i ->
i :: (List.flatten (List.map gen_builder tdecls))
| i -> [this.structure_item this i]
) l
)
)
}
let () = Ast_mapper.run_main builder
end

29
experimental/frisch/ppx_matches.ml
View File

@ -1,29 +0,0 @@
(*
Example : List.filter [%matches ? 'a' .. 'z' ] text
Output : List.filter (function 'a' .. 'z' -> true | _ -> false) text
*)
open Asttypes
open Parsetree
open Ast_helper
let mapper _args =
let open Ast_mapper in
let super = default_mapper in
{super with
expr =
(fun this e ->
match e.pexp_desc with
| Pexp_extension({txt="matches";_}, PPat (p, guard)) ->
let p = this.pat this p in
let guard = Ast_mapper.map_opt (this.expr this) guard in
Exp.function_ ~loc:e.pexp_loc
[
Exp.case p ?guard (Convenience.constr "true" []);
Exp.case (Pat.any ()) (Convenience.constr "false" []);
]
| _ -> super.expr this e
)
}
let () = Ast_mapper.run_main mapper

19
experimental/frisch/test_builder.ml
View File

@ -1,19 +0,0 @@
type t =
{
x: int;
y [@label foo]: int;
z [@default 3]: int;
} [@@builder]
and s =
{
a: string;
b [@opt]: int option;
c: int [@default 2];
} [@@builder]
and sum =
| A of int
| B of string * (string [@label str])
| C of (int [@label i] [@default 0]) * (string [@label s] [@default ""])
[@@builder]

19
experimental/frisch/test_copy_typedef.ml
View File

@ -1,19 +0,0 @@
module type S = [%copy_typedef]
module type T = sig
type t
module type M = [%copy_typedef]
end
module M = struct
type t = [%copy_typedef]
end
type t = [%copy_typedef]
let _x = M.A
let _y : t = [1; 2]
type _loc = [%copy_typedef "../../parsing/location.mli" t]

20
experimental/frisch/test_copy_typedef.mli
View File

@ -1,20 +0,0 @@
module type S = sig
type t
val x: int
end
module type T = sig
type t
module type M = sig
type t = A | B of t
end
end
module M : sig
type t =
| A
| B of string
end
type t = int list

37
experimental/frisch/test_eval.ml
View File

@ -1,37 +0,0 @@
[%%eval.load "unix.cma"]
[%%eval.start both]
(* This type definition will be evaluated at compile time,
but it will be kept in the compiled unit as well. *)
type t = A | B of string
[%%eval.stop]
[%%eval.start]
(* This is going to be executed at compile time only. *)
let () = print_endline "Now compiling..."
[%%eval.stop]
let () =
begin match [%eval B "x"] with
| A -> print_endline "A"
| B s -> Printf.printf "B %S\n%!" s
end;
Printf.printf "Home dir at compile time = %s\n" [%eval Sys.getenv "HOME"];
Printf.printf "Word-size = %i\n" [%eval Sys.word_size];
Array.iter (Printf.printf "%s;") [%eval Sys.readdir "."];
print_endline "";
[%eval print_endline "COUCOU"]
let () =
let tm = [%eval Unix.(localtime (gettimeofday ()))] in
Printf.printf "This program was compiled in %i\n%!" (1900 + tm.Unix.tm_year)
let () =
let debug =
[%eval try Some (Sys.getenv "DEBUG") with Not_found -> None]
in
match debug with
| Some x -> Printf.printf "DEBUG %s\n%!" x
| None -> Printf.printf "NODEBUG\n%!"

25
experimental/frisch/test_ifdef.ml
View File

@ -1,25 +0,0 @@
type t =
| A
| DBG [@IFDEF DEBUG] of string
| B
[%%IFDEF DEBUG]
let debug s = prerr_endline ([%GETENV DEBUG] ^ ":" ^ s)
let x = DBG "xxx"
[%%ELSE]
let debug _ = ()
let x = A
[%%END]
let f = function
| A -> "A"
| DBG s when [%IFDEF DEBUG] -> "DEBUG:" ^ s
| B -> "B"
let () = debug "ABC"
let () =
Printf.printf "compiled by user %s in directory %s\n%!"
[%GETENV USER]
[%GETENV PWD]

22
experimental/frisch/test_js.ml
View File

@ -1,22 +0,0 @@
module Js = struct
type +'a t
type +'a gen_prop
type +'a meth
module Unsafe = struct
type any
let get (_o : 'a t) (_meth : string) = assert false
let set (_o : 'a t) (_meth : string) (_v : 'b) = ()
let meth_call (_ : 'a) (_ : string) (_ : any array) : 'b = assert false
let inject _ : any = assert false
end
end
let foo1 o =
if [%js o.bar] then [%js o.foo1.foo2] else [%js o.foo2]
let foo2 o =
[%js o.x <- o.x + 1]
let foo3 o a =
[%js o#x] + [%js o#y 1 a]

3
experimental/frisch/test_matches.ml
View File

@ -1,3 +0,0 @@
let l = List.filter [%matches ? 'a'..'z'] ['a';'A';'X';'x']
let f = [%matches ? Some i when i >= 0]

30
experimental/frisch/test_nomli.ml
View File

@ -1,30 +0,0 @@
type t = A | B
[@@mli]
and s = C | D
[@@mli abstract]
module X = struct
type t = X | Y
[@@mli]
and s
let id x = x
[@@mli]
end
module Y : sig type t type s end = struct
type t = X | Y
type s = A | B
end
let f x y = x + y
[@@mli]
and g a b = (a, b)
[@@mli]
and h a b = (a, b)
[@@mli (h : int -> int -> int * int)]
let (x, y, z) = (1, 2, 3)
[@@mli (x : int), (y : int)]

29
experimental/frisch/testdoc.mli
View File

@ -1,29 +0,0 @@
[@@doc section "First section"]
module M : sig
[@@doc section "Public definitions"]
type t =
| A
| B
[@@doc section "Internal definitions"]
val zero: int
[@@doc "A very important integer."]
end
[@@doc "This is an internal module."]
val incr: int -> int
[@@doc "This function returns the next integer."]
[@@doc section "Second section"]
val decr: int -> int
[@@doc "This function returns the previous integer."]
val is_a: M.t -> bool
[@@doc "This function checks whether its argument is the A constructor."]
module X: Hashtbl.HashedType
[@@doc "An internal module"]

63
experimental/frisch/unused_exported_values.ml
View File

@ -1,63 +0,0 @@
(* This tool reports values exported by .mli files but never used in any other module.
It assumes that .mli files are compiled with -keep-locs and .ml files with -bin-annot.
This can be enforced by setting:
OCAMLPARAM=bin-annot=1,keep-locs=1,_
*)
open Types
open Typedtree
let vds = ref [] (* all exported value declarations *)
let references = Hashtbl.create 256 (* all value references *)
let unit fn =
Filename.chop_extension (Filename.basename fn)
let rec collect_export fn = function
| Sig_value (_, {Types.val_loc; _}) when not val_loc.Location.loc_ghost ->
(* a .cmi file can contain locations from other files.
For instance:
module M : Set.S with type elt = int
will create value definitions whole locations is in set.mli
*)
if unit fn = unit val_loc.Location.loc_start.Lexing.pos_fname then
vds := val_loc :: !vds
| Sig_module (_, {Types.md_type=Mty_signature sg; _}, _) -> List.iter (collect_export fn) sg
| _ -> ()
let collect_references = object
inherit Tast_iter.iter as super
method! expression = function
| {exp_desc = Texp_ident (_, _, {Types.val_loc; _}); exp_loc} -> Hashtbl.add references val_loc exp_loc
| e -> super # expression e
end
let rec load_file fn =
if Filename.check_suffix fn ".cmi"
&& Sys.file_exists (Filename.chop_suffix fn ".cmi" ^ ".mli") then
(* only consider module with an explicit interface *)
let open Cmi_format in
(* Printf.eprintf "Scanning %s\n%!" fn; *)
List.iter (collect_export fn) (read_cmi fn).cmi_sign
else if Filename.check_suffix fn ".cmt" then
let open Cmt_format in
(* Printf.eprintf "Scanning %s\n%!" fn; *)
match read fn with
| (_, Some {cmt_annots = Implementation x; _}) -> collect_references # structure x
| _ -> () (* todo: support partial_implementation? *)
else if (try Sys.is_directory fn with _ -> false) then
Array.iter (fun s -> load_file (Filename.concat fn s)) (Sys.readdir fn)
let report loc =
if not (Hashtbl.mem references loc) then
Format.printf "%a: unused exported value@." Location.print_loc loc
let () =
try
for i = 1 to Array.length Sys.argv - 1 do load_file Sys.argv.(i) done;
List.iter report !vds
with exn ->
Location.report_exception Format.err_formatter exn;
exit 2

2
experimental/garrigue/.cvsignore
View File

@ -1,2 +0,0 @@
*.out
*.out2

141
experimental/garrigue/caml_set_oid.diff
View File

@ -1,141 +0,0 @@
Index: byterun/intern.c
===================================================================
--- byterun/intern.c (revision 11929)
+++ byterun/intern.c (working copy)
@@ -27,6 +27,7 @@
#include "memory.h"
#include "mlvalues.h"
#include "misc.h"
+#include "obj.h"
#include "reverse.h"
static unsigned char * intern_src;
@@ -139,6 +140,14 @@
dest = (value *) (intern_dest + 1);
*intern_dest = Make_header(size, tag, intern_color);
intern_dest += 1 + size;
+ /* For objects, we need to freshen the oid */
+ if (tag == Object_tag) {
+ intern_rec(dest++);
+ intern_rec(dest++);
+ caml_set_oid((value)(dest-2));
+ size -= 2;
+ if (size == 0) return;
+ }
for(/*nothing*/; size > 1; size--, dest++)
intern_rec(dest);
goto tailcall;
Index: byterun/obj.c
===================================================================
--- byterun/obj.c (revision 11929)
+++ byterun/obj.c (working copy)
@@ -25,6 +25,7 @@
#include "minor_gc.h"
#include "misc.h"
#include "mlvalues.h"
+#include "obj.h"
#include "prims.h"
CAMLprim value caml_static_alloc(value size)
@@ -212,6 +213,16 @@
return (tag == Field(meths,li) ? Field (meths, li-1) : 0);
}
+/* Generate ids on the C side, to avoid races */
+
+CAMLprim value caml_set_oid (value obj)
+{
+ static value last_oid = 1;
+ Field(obj,1) = last_oid;
+ last_oid += 2;
+ return obj;
+}
+
/* these two functions might be useful to an hypothetical JIT */
#ifdef CAML_JIT
Index: byterun/obj.h
===================================================================
--- byterun/obj.h (revision 0)
+++ byterun/obj.h (revision 0)
@@ -0,0 +1,28 @@
+/***********************************************************************/
+/* */
+/* OCaml */
+/* */
+/* Jacques Garrigue, projet Cristal, INRIA Rocquencourt */
+/* */
+/* Copyright 1996 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$ */
+
+/* Primitives for the Obj and CamlinternalOO modules */
+
+#ifndef CAML_OBJ_H
+#define CAML_OBJ_H
+
+#include "misc.h"
+#include "mlvalues.h"
+
+/* Set the OID of an object to a fresh value */
+/* returns the same object as result */
+value caml_set_oid (value obj);
+
+#endif /* CAML_OBJ_H */
Index: stdlib/camlinternalOO.ml
===================================================================
--- stdlib/camlinternalOO.ml (revision 11929)
+++ stdlib/camlinternalOO.ml (working copy)
@@ -15,23 +15,15 @@
open Obj
-(**** Object representation ****)
+(**** OID handling ****)
-let last_id = ref 0
-let new_id () =
- let id = !last_id in incr last_id; id
+external set_oid : t -> t = "caml_set_oid" "noalloc"
-let set_id o id =
- let id0 = !id in
- Array.unsafe_set (Obj.magic o : int array) 1 id0;
- id := id0 + 1
-
(**** Object copy ****)
let copy o =
- let o = (Obj.obj (Obj.dup (Obj.repr o))) in
- set_id o last_id;
- o
+ let o = Obj.dup (Obj.repr o) in
+ Obj.obj (set_oid o)
(**** Compression options ****)
(* Parameters *)
@@ -355,8 +347,7 @@
let obj = Obj.new_block Obj.object_tag table.size in
(* XXX Appel de [caml_modify] *)
Obj.set_field obj 0 (Obj.repr table.methods);
- set_id obj last_id;
- (Obj.obj obj)
+ Obj.obj (set_oid obj)
let create_object_opt obj_0 table =
if (Obj.magic obj_0 : bool) then obj_0 else begin
@@ -364,8 +355,7 @@
let obj = Obj.new_block Obj.object_tag table.size in
(* XXX Appel de [caml_modify] *)
Obj.set_field obj 0 (Obj.repr table.methods);
- set_id obj last_id;
- (Obj.obj obj)
+ Obj.obj (set_oid obj)
end
let rec iter_f obj =

93
experimental/garrigue/coerce.diff
View File

@ -1,93 +0,0 @@
Index: typing/ctype.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
retrieving revision 1.201
diff -u -r1.201 ctype.ml
--- typing/ctype.ml 5 Apr 2006 02:28:13 -0000 1.201
+++ typing/ctype.ml 17 May 2006 23:48:22 -0000
@@ -490,6 +490,31 @@
unmark_class_signature sign;
Some reason
+(* Variant for checking principality *)
+
+let rec free_nodes_rec ty =
+ let ty = repr ty in
+ if ty.level >= lowest_level then begin
+ if ty.level <= !current_level then raise Exit;
+ ty.level <- pivot_level - ty.level;
+ begin match ty.desc with
+ Tvar ->
+ raise Exit
+ | Tobject (ty, _) ->
+ free_nodes_rec ty
+ | Tfield (_, _, ty1, ty2) ->
+ free_nodes_rec ty1; free_nodes_rec ty2
+ | Tvariant row ->
+ let row = row_repr row in
+ iter_row free_nodes_rec {row with row_bound = []};
+ if not (static_row row) then free_nodes_rec row.row_more
+ | _ ->
+ iter_type_expr free_nodes_rec ty
+ end;
+ end
+
+let has_free_nodes ty =
+ try free_nodes_rec ty; false with Exit -> true
(**********************)
(* Type duplication *)
Index: typing/ctype.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.mli,v
retrieving revision 1.54
diff -u -r1.54 ctype.mli
--- typing/ctype.mli 5 Apr 2006 02:28:13 -0000 1.54
+++ typing/ctype.mli 17 May 2006 23:48:22 -0000
@@ -228,6 +228,9 @@
val closed_class:
type_expr list -> class_signature -> closed_class_failure option
(* Check whether all type variables are bound *)
+val has_free_nodes: type_expr -> bool
+ (* Check whether there are free type variables, or nodes with
+ level lower or equal to !current_level *)
val unalias: type_expr -> type_expr
val signature_of_class_type: class_type -> class_signature
Index: typing/typecore.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
retrieving revision 1.181
diff -u -r1.181 typecore.ml
--- typing/typecore.ml 16 Apr 2006 23:28:22 -0000 1.181
+++ typing/typecore.ml 17 May 2006 23:48:22 -0000
@@ -1183,12 +1183,29 @@
let (ty', force) =
Typetexp.transl_simple_type_delayed env sty'
in
+ if !Clflags.principal then begin_def ();
let arg = type_exp env sarg in
+ let has_fv =
+ if !Clflags.principal then begin
+ end_def ();
+ let b = has_free_nodes arg.exp_type in
+ Ctype.unify env arg.exp_type (newvar ());
+ b
+ end else
+ free_variables arg.exp_type <> []
+ in
begin match arg.exp_desc, !self_coercion, (repr ty').desc with
Texp_ident(_, {val_kind=Val_self _}), (path,r) :: _,
Tconstr(path',_,_) when Path.same path path' ->
r := sexp.pexp_loc :: !r;
force ()
+ | _ when not has_fv ->
+ begin try
+ let force' = subtype env arg.exp_type ty' in
+ force (); force' ()
+ with Subtype (tr1, tr2) ->
+ raise(Error(sexp.pexp_loc, Not_subtype(tr1, tr2)))
+ end
| _ ->
let ty, b = enlarge_type env ty' in
force ();

16
experimental/garrigue/countchars.ml
View File

@ -1,16 +0,0 @@
let rec long_lines name n ic =
let l = input_line ic in
if String.length l > 80 then Printf.printf "%s: %d\n%!" name n;
long_lines name (n+1) ic
let process_file name =
try
let ic = open_in name in
try long_lines name 1 ic
with End_of_file -> close_in ic
with _ ->()
let () =
for i = 1 to Array.length Sys.argv - 1 do
process_file Sys.argv.(i)
done

1
experimental/garrigue/dirs_multimatch
View File

@ -1 +0,0 @@
parsing typing bytecomp driver toplevel

1
experimental/garrigue/dirs_poly
View File

@ -1 +0,0 @@
bytecomp byterun driver parsing stdlib tools toplevel typing utils

77
experimental/garrigue/fixedtypes.ml
View File

@ -1,77 +0,0 @@
(* cvs update -r fixedtypes parsing typing *)
(* recursive types *)
class c = object (self) method m = 1 method s = self end
module type S = sig type t = private #c end;;
module M : S = struct type t = c end
module type S' = S with type t = c;;
class d = object inherit c method n = 2 end
module type S2 = S with type t = private #d;;
module M2 : S = struct type t = d end;;
module M3 : S = struct type t = private #d end;;
module T1 = struct
type ('a,'b) a = [`A of 'a | `B of 'b]
type ('a,'b) b = [`Z | ('a,'b) a]
end
module type T2 = sig
type a and b
val evala : a -> int
val evalb : b -> int
end
module type T3 = sig
type a0 = private [> (a0,b0) T1.a]
and b0 = private [> (a0,b0) T1.b]
end
module type T4 = sig
include T3
include T2 with type a = a0 and type b = b0
end
module F(X:T4) = struct
type a = X.a and b = X.b
let a = X.evala (`B `Z)
let b = X.evalb (`A(`B `Z))
let a2b (x : a) : b = `A x
let b2a (x : b) : a = `B x
end
module M4 = struct
type a = [`A of a | `B of b | `ZA]
and b = [`A of a | `B of b | `Z]
type a0 = a
type b0 = b
let rec eval0 = function
`A a -> evala a
| `B b -> evalb b
and evala : a -> int = function
#T1.a as x -> 1 + eval0 x
| `ZA -> 3
and evalb : b -> int = function
#T1.a as x -> 1 + eval0 x
| `Z -> 7
end
module M5 = F(M4)
module M6 : sig
class ci : int ->
object
val x : int
method x : int
method move : int -> unit
end
type c = private #ci
val create : int -> c
end = struct
class ci x = object
val mutable x : int = x
method x = x
method move d = x <- x+d
end
type c = ci
let create = new ci
end
let f (x : M6.c) = x#move 3; x#x;;
module M : sig type t = private [> `A of bool] end =
struct type t = [`A of int] end

519
experimental/garrigue/gadt-escape-check.diff
View File

@ -1,519 +0,0 @@
Index: typing/env.ml
===================================================================
--- typing/env.ml (revision 11214)
+++ typing/env.ml (working copy)
@@ -20,6 +20,7 @@
open Longident
open Path
open Types
+open Btype
type error =
@@ -56,7 +57,7 @@
cltypes: (Path.t * cltype_declaration) Ident.tbl;
summary: summary;
local_constraints: bool;
- level_map: (int * int) list;
+ gadt_instances: (int * TypeSet.t ref) list;
}
and module_components = module_components_repr Lazy.t
@@ -96,7 +97,7 @@
modules = Ident.empty; modtypes = Ident.empty;
components = Ident.empty; classes = Ident.empty;
cltypes = Ident.empty;
- summary = Env_empty; local_constraints = false; level_map = [] }
+ summary = Env_empty; local_constraints = false; gadt_instances = [] }
let diff_keys is_local tbl1 tbl2 =
let keys2 = Ident.keys tbl2 in
@@ -286,13 +287,14 @@
(* the level is changed when updating newtype definitions *)
if !Clflags.principal then begin
match level, decl.type_newtype_level with
- Some level, Some def_level when level < def_level -> raise Not_found
+ Some level, Some (_, exp_level) when level < exp_level -> raise Not_found
| _ -> ()
end;
match decl.type_manifest with
| Some body when decl.type_private = Public
|| decl.type_kind <> Type_abstract
- || Btype.has_constr_row body -> (decl.type_params, body)
+ || Btype.has_constr_row body ->
+ (decl.type_params, body, may_map snd decl.type_newtype_level)
(* The manifest type of Private abstract data types without
private row are still considered unknown to the type system.
Hence, this case is caught by the following clause that also handles
@@ -308,7 +310,7 @@
match decl.type_manifest with
(* The manifest type of Private abstract data types can still get
an approximation using their manifest type. *)
- | Some body -> (decl.type_params, body)
+ | Some body -> (decl.type_params, body, may_map snd decl.type_newtype_level)
| _ -> raise Not_found
let find_modtype_expansion path env =
@@ -453,32 +455,42 @@
and lookup_cltype =
lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
-(* Level handling *)
+(* GADT instance tracking *)
-(* The level map is a list of pairs describing separate segments (lv,lv'),
- lv < lv', organized in decreasing order.
- The definition level is obtained by mapping a level in a segment to the
- high limit of this segment.
- The definition level of a newtype should be greater or equal to
- the highest level of the newtypes in its manifest type.
- *)
+let add_gadt_instance_level lv env =
+ {env with
+ gadt_instances = (lv, ref TypeSet.empty) :: env.gadt_instances}
-let rec map_level lv = function
- | [] -> lv
- | (lv1, lv2) :: rem ->
- if lv > lv2 then lv else
- if lv >= lv1 then lv2 else map_level lv rem
+let is_Tlink = function {desc = Tlink _} -> true | _ -> false
-let map_newtype_level env lv = map_level lv env.level_map
+let gadt_instance_level env t =
+ let rec find_instance = function
+ [] -> None
+ | (lv, r) :: rem ->
+ if TypeSet.exists is_Tlink !r then
+ r := TypeSet.fold (fun ty -> TypeSet.add (repr ty)) !r TypeSet.empty;
+ if TypeSet.mem t !r then Some lv else find_instance rem
+ in find_instance env.gadt_instances
-(* precondition: lv < lv' *)
-let rec add_level lv lv' = function
- | [] -> [lv, lv']
- | (lv1, lv2) :: rem as l ->
- if lv2 < lv then (lv, lv') :: l else
- if lv' < lv1 then (lv1, lv2) :: add_level lv lv' rem
- else add_level (max lv lv1) (min lv' lv2) rem
+let add_gadt_instances env lv tl =
+ let r =
+ try List.assoc lv env.gadt_instances with Not_found -> assert false in
+ r := List.fold_right TypeSet.add tl !r
+(* Only use this after expand_head! *)
+let add_gadt_instance_chain env lv t =
+ let r =
+ try List.assoc lv env.gadt_instances with Not_found -> assert false in
+ let rec add_instance t =
+ let t = repr t in
+ if not (TypeSet.mem t !r) then begin
+ r := TypeSet.add t !r;
+ match t.desc with
+ Tconstr (p, _, memo) ->
+ may add_instance (find_expans Private p !memo)
+ | _ -> ()
+ end
+ in add_instance t
(* Expand manifest module type names at the top of the given module type *)
@@ -497,7 +509,7 @@
let constructors_of_type ty_path decl =
let handle_variants cstrs =
Datarepr.constructor_descrs
- (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
+ (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
cstrs decl.type_private
in
match decl.type_kind with
@@ -510,7 +522,7 @@
match decl.type_kind with
Type_record(labels, rep) ->
Datarepr.label_descrs
- (Btype.newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
+ (newgenty (Tconstr(ty_path, decl.type_params, ref Mnil)))
labels rep decl.type_private
| Type_variant _ | Type_abstract -> []
@@ -773,14 +785,13 @@
and add_cltype id ty env =
store_cltype id (Pident id) ty env
-let add_local_constraint id info mlv env =
+let add_local_constraint id info elv env =
match info with
- {type_manifest = Some ty; type_newtype_level = Some lv} ->
- (* use the newtype level for this definition, lv is the old one *)
- let env = add_type id {info with type_newtype_level = Some mlv} env in
- let level_map =
- if lv < mlv then add_level lv mlv env.level_map else env.level_map in
- { env with local_constraints = true; level_map = level_map }
+ {type_manifest = Some ty; type_newtype_level = Some (lv, _)} ->
+ (* elv is the expansion level, lv is the definition level *)
+ let env =
+ add_type id {info with type_newtype_level = Some (lv, elv)} env in
+ { env with local_constraints = true }
| _ -> assert false
(* Insertion of bindings by name *)
Index: typing/typecore.ml
===================================================================
--- typing/typecore.ml (revision 11214)
+++ typing/typecore.ml (working copy)
@@ -1989,6 +1989,7 @@
end
| Pexp_newtype(name, sbody) ->
(* Create a fake abstract type declaration for name. *)
+ let level = get_current_level () in
let decl = {
type_params = [];
type_arity = 0;
@@ -1996,7 +1997,7 @@
type_private = Public;
type_manifest = None;
type_variance = [];
- type_newtype_level = Some (get_current_level ());
+ type_newtype_level = Some (level, level);
}
in
let ty = newvar () in
@@ -2421,6 +2422,7 @@
begin_def ();
Ident.set_current_time (get_current_level ());
let lev = Ident.current_time () in
+ let env = Env.add_gadt_instance_level lev env in
Ctype.init_def (lev+1000);
if !Clflags.principal then begin_def (); (* propagation of the argument *)
let ty_arg' = newvar () in
Index: typing/typedecl.ml
===================================================================
--- typing/typedecl.ml (revision 11214)
+++ typing/typedecl.ml (working copy)
@@ -404,7 +404,7 @@
else if to_check path' && not (List.mem path' prev_exp) then begin
try
(* Attempt expansion *)
- let (params0, body0) = Env.find_type_expansion path' env in
+ let (params0, body0, _) = Env.find_type_expansion path' env in
let (params, body) =
Ctype.instance_parameterized_type params0 body0 in
begin
Index: typing/types.mli
===================================================================
--- typing/types.mli (revision 11214)
+++ typing/types.mli (working copy)
@@ -144,9 +144,9 @@
type_manifest: type_expr option;
type_variance: (bool * bool * bool) list;
(* covariant, contravariant, weakly contravariant *)
- type_newtype_level: int option }
+ type_newtype_level: (int * int) option }
+ (* definition level * expansion level *)
-
and type_kind =
Type_abstract
| Type_record of
Index: typing/ctype.ml
===================================================================
--- typing/ctype.ml (revision 11214)
+++ typing/ctype.ml (working copy)
@@ -470,7 +470,7 @@
free_variables := (ty, real) :: !free_variables
| Tconstr (path, tl, _), Some env ->
begin try
- let (_, body) = Env.find_type_expansion path env in
+ let (_, body, _) = Env.find_type_expansion path env in
if (repr body).level <> generic_level then
free_variables := (ty, real) :: !free_variables
with Not_found -> ()
@@ -687,7 +687,7 @@
try
match (Env.find_type p env).type_newtype_level with
| None -> Path.binding_time p
- | Some x -> x
+ | Some (x, _) -> x
with
| _ ->
(* no newtypes in predef *)
@@ -696,9 +696,13 @@
let rec update_level env level ty =
let ty = repr ty in
if ty.level > level then begin
+ if !Clflags.principal && Env.has_local_constraints env then begin
+ match Env.gadt_instance_level env ty with
+ Some lv -> if level < lv then raise (Unify [(ty, newvar2 level)])
+ | None -> ()
+ end;
match ty.desc with
- Tconstr(p, tl, abbrev)
- when level < Env.map_newtype_level env (get_level env p) ->
+ Tconstr(p, tl, abbrev) when level < get_level env p ->
(* Try first to replace an abbreviation by its expansion. *)
begin try
(* if is_newtype env p then raise Cannot_expand; *)
@@ -1025,7 +1029,7 @@
| Some (env, newtype_lev) ->
let existentials = List.map copy cstr.cstr_existentials in
let process existential =
- let decl = new_declaration (Some newtype_lev) None in
+ let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in
let (id, new_env) =
Env.enter_type (get_new_abstract_name ()) decl !env in
env := new_env;
@@ -1271,7 +1275,7 @@
end;
ty
| None ->
- let (params, body) =
+ let (params, body, lv) =
try find_type_expansion level path env with Not_found ->
raise Cannot_expand
in
@@ -1284,6 +1288,15 @@
ty.desc <- Tvariant { row with row_name = Some (path, args) }
| _ -> ()
end;
+ (* For gadts, remember type as non exportable *)
+ if !Clflags.principal then begin
+ match lv with
+ Some lv -> Env.add_gadt_instances env lv [ty; ty']
+ | None ->
+ match Env.gadt_instance_level env ty with
+ Some lv -> Env.add_gadt_instances env lv [ty']
+ | None -> ()
+ end;
ty'
end
| _ ->
@@ -1306,15 +1319,7 @@
let try_expand_once env ty =
let ty = repr ty in
match ty.desc with
- Tconstr (p, _, _) ->
- let ty' = repr (expand_abbrev env ty) in
- if !Clflags.principal then begin
- match (Env.find_type p env).type_newtype_level with
- Some lv when ty.level < Env.map_newtype_level env lv ->
- link_type ty ty'
- | _ -> ()
- end;
- ty'
+ Tconstr (p, _, _) -> repr (expand_abbrev env ty)
| _ -> raise Cannot_expand
let _ = forward_try_expand_once := try_expand_once
@@ -1324,11 +1329,16 @@
May raise Unify, if a recursion was hidden in the type. *)
let rec try_expand_head env ty =
let ty' = try_expand_once env ty in
- begin try
- try_expand_head env ty'
- with Cannot_expand ->
- ty'
- end
+ let ty'' =
+ try try_expand_head env ty'
+ with Cannot_expand -> ty'
+ in
+ if !Clflags.principal then begin
+ match Env.gadt_instance_level env ty'' with
+ None -> ()
+ | Some lv -> Env.add_gadt_instance_chain env lv ty
+ end;
+ ty''
(* Expand once the head of a type *)
let expand_head_once env ty =
@@ -1405,7 +1415,7 @@
*)
let generic_abbrev env path =
try
- let (_, body) = Env.find_type_expansion path env in
+ let (_, body, _) = Env.find_type_expansion path env in
(repr body).level = generic_level
with
Not_found ->
@@ -1742,7 +1752,7 @@
let reify env t =
let newtype_level = get_newtype_level () in
let create_fresh_constr lev row =
- let decl = new_declaration (Some (newtype_level)) None in
+ let decl = new_declaration (Some (newtype_level, newtype_level)) None in
let name =
let name = get_new_abstract_name () in
if row then name ^ "#row" else name
@@ -2065,7 +2075,7 @@
update_level !env t1.level t2;
link_type t1 t2
| (Tconstr (p1, [], a1), Tconstr (p2, [], a2))
- when Path.same p1 p2 && actual_mode !env = Old
+ when Path.same p1 p2 (* && actual_mode !env = Old *)
(* This optimization assumes that t1 does not expand to t2
(and conversely), so we fall back to the general case
when any of the types has a cached expansion. *)
@@ -2091,6 +2101,15 @@
if unify_eq !env t1' t2' then () else
let t1 = repr t1 and t2 = repr t2 in
+ if !Clflags.principal then begin
+ match Env.gadt_instance_level !env t1',Env.gadt_instance_level !env t2' with
+ Some lv1, Some lv2 ->
+ if lv1 > lv2 then Env.add_gadt_instance_chain !env lv1 t2 else
+ if lv2 > lv2 then Env.add_gadt_instance_chain !env lv2 t1
+ | Some lv1, None -> Env.add_gadt_instance_chain !env lv1 t2
+ | None, Some lv2 -> Env.add_gadt_instance_chain !env lv2 t1
+ | None, None -> ()
+ end;
if unify_eq !env t1 t1' || not (unify_eq !env t2 t2') then
unify3 env t1 t1' t2 t2'
else
Index: typing/env.mli
===================================================================
--- typing/env.mli (revision 11214)
+++ typing/env.mli (working copy)
@@ -33,14 +33,19 @@
val find_cltype: Path.t -> t -> cltype_declaration
val find_type_expansion:
- ?use_local:bool -> ?level:int -> Path.t -> t -> type_expr list * type_expr
-val find_type_expansion_opt: Path.t -> t -> type_expr list * type_expr
+ ?use_local:bool -> ?level:int -> Path.t -> t ->
+ type_expr list * type_expr * int option
+val find_type_expansion_opt:
+ Path.t -> t -> type_expr list * type_expr * int option
(* Find the manifest type information associated to a type for the sake
of the compiler's type-based optimisations. *)
val find_modtype_expansion: Path.t -> t -> Types.module_type
val has_local_constraints: t -> bool
-val map_newtype_level: t -> int -> int
+val add_gadt_instance_level: int -> t -> t
+val gadt_instance_level: t -> type_expr -> int option
+val add_gadt_instances: t -> int -> type_expr list -> unit
+val add_gadt_instance_chain: t -> int -> type_expr -> unit
(* Lookup by long identifiers *)
Index: typing/types.ml
===================================================================
--- typing/types.ml (revision 11214)
+++ typing/types.ml (working copy)
@@ -146,8 +146,8 @@
type_private: private_flag;
type_manifest: type_expr option;
type_variance: (bool * bool * bool) list;
- type_newtype_level: int option }
(* covariant, contravariant, weakly contravariant *)
+ type_newtype_level: (int * int) option }
and type_kind =
Type_abstract
Index: testsuite/tests/typing-gadts/test.ml
===================================================================
--- testsuite/tests/typing-gadts/test.ml (revision 11214)
+++ testsuite/tests/typing-gadts/test.ml (working copy)
@@ -159,17 +159,21 @@
let ky x y = ignore (x = y); x ;;
+let test : type a. a t -> a =
+ function Int -> ky (1 : a) 1
+;;
+
let test : type a. a t -> a = fun x ->
- let r = match x with Int -> ky (1 : a) 1
+ let r = match x with Int -> ky (1 : a) 1 (* fails *)
in r
;;
let test : type a. a t -> a = fun x ->
- let r = match x with Int -> ky 1 (1 : a)
+ let r = match x with Int -> ky 1 (1 : a) (* fails *)
in r
;;
let test : type a. a t -> a = fun x ->
- let r = match x with Int -> (1 : a)
- in r (* fails too *)
+ let r = match x with Int -> (1 : a) (* ok! *)
+ in r
;;
let test : type a. a t -> a = fun x ->
let r : a = match x with Int -> 1
@@ -178,7 +182,7 @@
let test2 : type a. a t -> a option = fun x ->
let r = ref None in
begin match x with Int -> r := Some (1 : a) end;
- !r (* normalized to int option *)
+ !r (* ok *)
;;
let test2 : type a. a t -> a option = fun x ->
let r : a option ref = ref None in
@@ -190,19 +194,19 @@
let u = ref None in
begin match x with Int -> r := Some 1; u := !r end;
!u
-;; (* fail *)
+;; (* ok (u non-ambiguous) *)
let test2 : type a. a t -> a option = fun x ->
let r : a option ref = ref None in
let u = ref None in
begin match x with Int -> u := Some 1; r := !u end;
!u
-;; (* fail *)
+;; (* fails because u : (int | a) option ref *)
let test2 : type a. a t -> a option = fun x ->
let u = ref None in
let r : a option ref = ref None in
begin match x with Int -> r := Some 1; u := !r end;
!u
-;; (* fail *)
+;; (* ok *)
let test2 : type a. a t -> a option = fun x ->
let u = ref None in
let a =
@@ -210,32 +214,32 @@
begin match x with Int -> r := Some 1; u := !r end;
!u
in a
-;; (* fail *)
+;; (* ok *)
(* Effect of external consraints *)
let f (type a) (x : a t) y =
ignore (y : a);
- let r = match x with Int -> (y : a) in (* fails *)
+ let r = match x with Int -> (y : a) in (* ok *)
r
;;
let f (type a) (x : a t) y =
let r = match x with Int -> (y : a) in
- ignore (y : a); (* fails *)
+ ignore (y : a); (* ok *)
r
;;
let f (type a) (x : a t) y =
ignore (y : a);
- let r = match x with Int -> y in
+ let r = match x with Int -> y in (* ok *)
r
;;
let f (type a) (x : a t) y =
let r = match x with Int -> y in
- ignore (y : a);
+ ignore (y : a); (* ok *)
r
;;
let f (type a) (x : a t) (y : a) =
- match x with Int -> y (* should return an int! *)
+ match x with Int -> y (* returns 'a *)
;;
(* Pattern matching *)
@@ -307,4 +311,4 @@
| {left=TE TC; right=D [|1.0|]} -> 14
| {left=TA; right=D 0} -> -1
| {left=TA; right=D z} -> z
-;; (* warn *)
+;; (* ok *)

1008
experimental/garrigue/generative-functors.diff
View File

File diff suppressed because it is too large Load Diff

223
experimental/garrigue/impure-functors.diff
View File

@ -1,223 +0,0 @@
Index: parsing/parser.mly
===================================================================
--- parsing/parser.mly (revision 14285)
+++ parsing/parser.mly (working copy)
@@ -542,8 +542,12 @@
{ unclosed "struct" 1 "end" 3 }
| FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_expr
{ mkmod(Pmod_functor(mkrhs $3 3, $5, $8)) }
+ | FUNCTOR LPAREN RPAREN MINUSGREATER module_expr
+ { mkmod(Pmod_functor(mkrhs "*" 3, mkmty (Pmty_signature []), $5)) }
| module_expr LPAREN module_expr RPAREN
{ mkmod(Pmod_apply($1, $3)) }
+ | module_expr LPAREN RPAREN
+ { mkmod(Pmod_apply($1, mkmod (Pmod_structure []))) }
| module_expr LPAREN module_expr error
{ unclosed "(" 2 ")" 4 }
| LPAREN module_expr COLON module_type RPAREN
@@ -641,6 +645,8 @@
{ mkmod(Pmod_constraint($4, $2)) }
| LPAREN UIDENT COLON module_type RPAREN module_binding_body
{ mkmod(Pmod_functor(mkrhs $2 2, $4, $6)) }
+ | LPAREN RPAREN module_binding_body
+ { mkmod(Pmod_functor(mkrhs "*" 1, mkmty(Pmty_signature []), $3)) }
;
module_bindings:
module_binding { [$1] }
@@ -663,6 +669,9 @@
| FUNCTOR LPAREN UIDENT COLON module_type RPAREN MINUSGREATER module_type
%prec below_WITH
{ mkmty(Pmty_functor(mkrhs $3 3, $5, $8)) }
+ | FUNCTOR LPAREN RPAREN MINUSGREATER module_type
+ %prec below_WITH
+ { mkmty(Pmty_functor(mkrhs "*" 2, mkmty(Pmty_signature []), $5)) }
| module_type WITH with_constraints
{ mkmty(Pmty_with($1, List.rev $3)) }
| MODULE TYPE OF module_expr %prec below_LBRACKETAT
@@ -725,6 +734,8 @@
{ $2 }
| LPAREN UIDENT COLON module_type RPAREN module_declaration
{ mkmty(Pmty_functor(mkrhs $2 2, $4, $6)) }
+ | LPAREN RPAREN module_declaration
+ { mkmty(Pmty_functor(mkrhs "*" 1, mkmty (Pmty_signature []), $3)) }
;
module_rec_declarations:
module_rec_declaration { [$1] }
Index: parsing/pprintast.ml
===================================================================
--- parsing/pprintast.ml (revision 14285)
+++ parsing/pprintast.ml (working copy)
@@ -834,6 +834,8 @@
| Pmty_signature (s) ->
pp f "@[<hv0>@[<hv2>sig@ %a@]@ end@]" (* "@[<hov>sig@ %a@ end@]" *)
(self#list self#signature_item ) s (* FIXME wrong indentation*)
+ | Pmty_functor ({txt="*"}, mt1, mt2) ->
+ pp f "@[<hov2>functor () ->@ %a@]" self#module_type mt2
| Pmty_functor (s, mt1, mt2) ->
pp f "@[<hov2>functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt
self#module_type mt1 self#module_type mt2
@@ -940,6 +942,8 @@
self#module_type mt
| Pmod_ident (li) ->
pp f "%a" self#longident_loc li;
+ | Pmod_functor ({txt="*"}, mt, me) ->
+ pp f "functor ()@;->@;%a" self#module_expr me
| Pmod_functor (s, mt, me) ->
pp f "functor@ (%s@ :@ %a)@;->@;%a"
s.txt self#module_type mt self#module_expr me
@@ -1025,7 +1029,8 @@
| Pstr_module x ->
let rec module_helper me = match me.pmod_desc with
| Pmod_functor(s,mt,me) ->
- pp f "(%s:%a)" s.txt self#module_type mt ;
+ if s.txt = "*" then pp f "()"
+ else pp f "(%s:%a)" s.txt self#module_type mt ;
module_helper me
| _ -> me in
pp f "@[<hov2>module %s%a@]"
Index: typing/includemod.ml
===================================================================
--- typing/includemod.ml (revision 14285)
+++ typing/includemod.ml (working copy)
@@ -35,6 +35,7 @@
Ident.t * class_declaration * class_declaration *
Ctype.class_match_failure list
| Unbound_modtype_path of Path.t
+ | Impure_functor
type pos =
Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
@@ -165,6 +166,8 @@
| (Mty_signature sig1, Mty_signature sig2) ->
signatures env cxt subst sig1 sig2
| (Mty_functor(param1, arg1, res1), Mty_functor(param2, arg2, res2)) ->
+ if Ident.name param1 = "*" && Ident.name param2 <> "*" then
+ raise (Error [cxt, env, Impure_functor]);
let arg2' = Subst.modtype subst arg2 in
let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
let cc_res =
@@ -422,6 +425,8 @@
Includeclass.report_error reason
| Unbound_modtype_path path ->
fprintf ppf "Unbound module type %a" Printtyp.path path
+ | Impure_functor ->
+ fprintf ppf "An impure functor cannot be made applicative"
let rec context ppf = function
Module id :: rem ->
Index: typing/includemod.mli
===================================================================
--- typing/includemod.mli (revision 14285)
+++ typing/includemod.mli (working copy)
@@ -40,6 +40,7 @@
Ident.t * class_declaration * class_declaration *
Ctype.class_match_failure list
| Unbound_modtype_path of Path.t
+ | Impure_functor
type pos =
Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
Index: typing/mtype.ml
===================================================================
--- typing/mtype.ml (revision 14285)
+++ typing/mtype.ml (working copy)
@@ -34,7 +34,8 @@
match scrape env mty with
Mty_signature sg ->
Mty_signature(strengthen_sig env sg p)
- | Mty_functor(param, arg, res) when !Clflags.applicative_functors ->
+ | Mty_functor(param, arg, res)
+ when !Clflags.applicative_functors && Ident.name param <> "*" ->
Mty_functor(param, arg, strengthen env res (Papply(p, Pident param)))
| mty ->
mty
Index: typing/oprint.ml
===================================================================
--- typing/oprint.ml (revision 14285)
+++ typing/oprint.ml (working copy)
@@ -344,6 +344,8 @@
let rec print_out_module_type ppf =
function
Omty_abstract -> ()
+ | Omty_functor ("*", _, mty_res) ->
+ fprintf ppf "@[<2>functor@ () ->@ %a@]" print_out_module_type mty_res
| Omty_functor (name, mty_arg, mty_res) ->
fprintf ppf "@[<2>functor@ (%s : %a) ->@ %a@]" name
print_out_module_type mty_arg print_out_module_type mty_res
Index: typing/typemod.ml
===================================================================
--- typing/typemod.ml (revision 14285)
+++ typing/typemod.ml (working copy)
@@ -39,6 +39,7 @@
| Scoping_pack of Longident.t * type_expr
| Extension of string
| Recursive_module_require_explicit_type
+ | Apply_impure
exception Error of Location.t * Env.t * error
@@ -950,8 +951,10 @@
mod_loc = smod.pmod_loc }
| Pmod_functor(name, smty, sbody) ->
let mty = transl_modtype env smty in
- let (id, newenv) = Env.enter_module name.txt mty.mty_type env in
- let body = type_module sttn true None newenv sbody in
+ let (id, newenv), funct_body =
+ if name.txt = "*" then (Ident.create "*", env), false else
+ Env.enter_module name.txt mty.mty_type env, true in
+ let body = type_module sttn funct_body None newenv sbody in
rm { mod_desc = Tmod_functor(id, name, mty, body);
mod_type = Mty_functor(id, mty.mty_type, body.mod_type);
mod_env = env;
@@ -964,6 +967,13 @@
type_module (sttn && path <> None) funct_body None env sfunct in
begin match Mtype.scrape env funct.mod_type with
Mty_functor(param, mty_param, mty_res) as mty_functor ->
+ let impure = Ident.name param = "*" in
+ if impure then begin
+ if sarg.pmod_desc <> Pmod_structure [] then
+ raise (Error (sfunct.pmod_loc, env, Apply_impure));
+ if funct_body then
+ raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body));
+ end;
let coercion =
try
Includemod.modtypes env arg.mod_type mty_param
@@ -975,6 +985,7 @@
Subst.modtype (Subst.add_module param path Subst.identity)
mty_res
| None ->
+ if impure then mty_res else
try
Mtype.nondep_supertype
(Env.add_module param arg.mod_type env) param mty_res
@@ -1549,7 +1560,7 @@
Location.print_filename intf_name
| Not_allowed_in_functor_body ->
fprintf ppf
- "This kind of expression is not allowed within the body of a functor."
+ "This kind of expression is only allowed inside impure functors."
| With_need_typeconstr ->
fprintf ppf
"Only type constructors with identical parameters can be substituted."
@@ -1570,6 +1581,8 @@
fprintf ppf "Uninterpreted extension '%s'." s
| Recursive_module_require_explicit_type ->
fprintf ppf "Recursive modules require an explicit module type."
+ | Apply_impure ->
+ fprintf ppf "This functor is impure. It can only be applied to ()"
let report_error env ppf err =
Printtyp.wrap_printing_env env (fun () -> report_error ppf err)
Index: typing/typemod.mli
===================================================================
--- typing/typemod.mli (revision 14285)
+++ typing/typemod.mli (working copy)
@@ -60,6 +60,7 @@
| Scoping_pack of Longident.t * type_expr
| Extension of string
| Recursive_module_require_explicit_type
+ | Apply_impure
exception Error of Location.t * Env.t * error

800
experimental/garrigue/marshal_objects.diff
View File

@ -1,800 +0,0 @@
? bytecomp/alpha_eq.ml
Index: bytecomp/lambda.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.ml,v
retrieving revision 1.44
diff -u -r1.44 lambda.ml
--- bytecomp/lambda.ml 25 Aug 2005 15:35:16 -0000 1.44
+++ bytecomp/lambda.ml 2 Feb 2006 05:08:56 -0000
@@ -287,9 +287,10 @@
let compare = compare
end)
-let free_ids get l =
+let free_ids get used l =
let fv = ref IdentSet.empty in
let rec free l =
+ let old = !fv in
iter free l;
fv := List.fold_right IdentSet.add (get l) !fv;
match l with
@@ -307,17 +308,20 @@
fv := IdentSet.remove v !fv
| Lassign(id, e) ->
fv := IdentSet.add id !fv
+ | Lifused(id, e) ->
+ if used && not (IdentSet.mem id old) then fv := IdentSet.remove id !fv
| Lvar _ | Lconst _ | Lapply _
| Lprim _ | Lswitch _ | Lstaticraise _
| Lifthenelse _ | Lsequence _ | Lwhile _
- | Lsend _ | Levent _ | Lifused _ -> ()
+ | Lsend _ | Levent _ -> ()
in free l; !fv
-let free_variables l =
- free_ids (function Lvar id -> [id] | _ -> []) l
+let free_variables ?(ifused=false) l =
+ free_ids (function Lvar id -> [id] | _ -> []) ifused l
let free_methods l =
- free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> []) l
+ free_ids (function Lsend(Self, Lvar meth, obj, _) -> [meth] | _ -> [])
+ false l
(* Check if an action has a "when" guard *)
let raise_count = ref 0
Index: bytecomp/lambda.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/lambda.mli,v
retrieving revision 1.42
diff -u -r1.42 lambda.mli
--- bytecomp/lambda.mli 25 Aug 2005 15:35:16 -0000 1.42
+++ bytecomp/lambda.mli 2 Feb 2006 05:08:56 -0000
@@ -177,7 +177,7 @@
val iter: (lambda -> unit) -> lambda -> unit
module IdentSet: Set.S with type elt = Ident.t
-val free_variables: lambda -> IdentSet.t
+val free_variables: ?ifused:bool -> lambda -> IdentSet.t
val free_methods: lambda -> IdentSet.t
val transl_path: Path.t -> lambda
Index: bytecomp/translclass.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translclass.ml,v
retrieving revision 1.38
diff -u -r1.38 translclass.ml
--- bytecomp/translclass.ml 13 Aug 2005 20:59:37 -0000 1.38
+++ bytecomp/translclass.ml 2 Feb 2006 05:08:56 -0000
@@ -46,6 +46,10 @@
let lfield v i = Lprim(Pfield i, [Lvar v])
+let ltuple l = Lprim(Pmakeblock(0,Immutable), l)
+
+let lprim name args = Lapply(oo_prim name, args)
+
let transl_label l = share (Const_immstring l)
let rec transl_meth_list lst =
@@ -68,8 +72,8 @@
Lvar offset])])]))
let transl_val tbl create name =
- Lapply (oo_prim (if create then "new_variable" else "get_variable"),
- [Lvar tbl; transl_label name])
+ lprim (if create then "new_variable" else "get_variable")
+ [Lvar tbl; transl_label name]
let transl_vals tbl create vals rem =
List.fold_right
@@ -82,7 +86,7 @@
(fun (nm, id) rem ->
try
(nm, id,
- Lapply(oo_prim "get_method", [Lvar tbl; Lvar (Meths.find nm meths)]))
+ lprim "get_method" [Lvar tbl; Lvar (Meths.find nm meths)])
:: rem
with Not_found -> rem)
inh_meths []
@@ -97,17 +101,15 @@
let (inh_init, obj_init, has_init) = init obj' in
if obj_init = lambda_unit then
(inh_init,
- Lapply (oo_prim (if has_init then "create_object_and_run_initializers"
- else"create_object_opt"),
- [obj; Lvar cl]))
+ lprim (if has_init then "create_object_and_run_initializers"
+ else"create_object_opt")
+ [obj; Lvar cl])
else begin
(inh_init,
- Llet(Strict, obj',
- Lapply (oo_prim "create_object_opt", [obj; Lvar cl]),
+ Llet(Strict, obj', lprim "create_object_opt" [obj; Lvar cl],
Lsequence(obj_init,
if not has_init then Lvar obj' else
- Lapply (oo_prim "run_initializers_opt",
- [obj; Lvar obj'; Lvar cl]))))
+ lprim "run_initializers_opt" [obj; Lvar obj'; Lvar cl])))
end
let rec build_object_init cl_table obj params inh_init obj_init cl =
@@ -203,14 +205,13 @@
let bind_method tbl lab id cl_init =
- Llet(StrictOpt, id, Lapply (oo_prim "get_method_label",
- [Lvar tbl; transl_label lab]),
+ Llet(StrictOpt, id, lprim "get_method_label" [Lvar tbl; transl_label lab],
cl_init)
-let bind_methods tbl meths vals cl_init =
- let methl = Meths.fold (fun lab id tl -> (lab,id) :: tl) meths [] in
+let bind_methods tbl methl vals cl_init =
let len = List.length methl and nvals = List.length vals in
- if len < 2 && nvals = 0 then Meths.fold (bind_method tbl) meths cl_init else
+ if len < 2 && nvals = 0 then
+ List.fold_right (fun (n,i) -> bind_method tbl n i) methl cl_init else
if len = 0 && nvals < 2 then transl_vals tbl true vals cl_init else
let ids = Ident.create "ids" in
let i = ref len in
@@ -229,21 +230,19 @@
vals' cl_init)
in
Llet(StrictOpt, ids,
- Lapply (oo_prim getter,
- [Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
+ lprim getter
+ ([Lvar tbl; transl_meth_list (List.map fst methl)] @ names),
List.fold_right
- (fun (lab,id) lam -> decr i; Llet(StrictOpt, id, lfield ids !i, lam))
+ (fun (lab,id) lam -> decr i; Llet(Alias, id, lfield ids !i, lam))
methl cl_init)
let output_methods tbl methods lam =
match methods with
[] -> lam
| [lab; code] ->
- lsequence (Lapply(oo_prim "set_method", [Lvar tbl; lab; code])) lam
+ lsequence (lprim "set_method" [Lvar tbl; lab; code]) lam
| _ ->
- lsequence (Lapply(oo_prim "set_methods",
- [Lvar tbl; Lprim(Pmakeblock(0,Immutable), methods)]))
- lam
+ lsequence (lprim "set_methods" [Lvar tbl; ltuple methods]) lam
let rec ignore_cstrs cl =
match cl.cl_desc with
@@ -266,7 +265,8 @@
Llet (Strict, obj_init,
Lapply(Lprim(Pfield 1, [lpath]), Lvar cla ::
if top then [Lprim(Pfield 3, [lpath])] else []),
- bind_super cla super cl_init))
+ bind_super cla super cl_init),
+ [], [])
| _ ->
assert false
end
@@ -278,10 +278,11 @@
match field with
Cf_inher (cl, vals, meths) ->
let cl_init = output_methods cla methods cl_init in
- let inh_init, cl_init =
+ let (inh_init, cl_init, meths', vals') =
build_class_init cla false
(vals, meths_super cla str.cl_meths meths)
inh_init cl_init msubst top cl in
+ let cl_init = bind_methods cla meths' vals' cl_init in
(inh_init, cl_init, [], values)
| Cf_val (name, id, exp) ->
(inh_init, cl_init, methods, (name, id)::values)
@@ -304,29 +305,37 @@
(inh_init, cl_init, methods, vals @ values)
| Cf_init exp ->
(inh_init,
- Lsequence(Lapply (oo_prim "add_initializer",
- Lvar cla :: msubst false (transl_exp exp)),
+ Lsequence(lprim "add_initializer"
+ (Lvar cla :: msubst false (transl_exp exp)),
cl_init),
methods, values))
str.cl_field
(inh_init, cl_init, [], [])
in
let cl_init = output_methods cla methods cl_init in
- (inh_init, bind_methods cla str.cl_meths values cl_init)
+ (* inh_init, bind_methods cla str.cl_meths values cl_init *)
+ let methods = Meths.fold (fun n i l -> (n,i)::l) str.cl_meths [] in
+ (inh_init, cl_init, methods, values)
| Tclass_fun (pat, vals, cl, _) ->
- let (inh_init, cl_init) =
+ let (inh_init, cl_init, methods, values) =
build_class_init cla cstr super inh_init cl_init msubst top cl
in
+ let fv = free_variables ~ifused:true cl_init in
+ let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
- (inh_init, transl_vals cla true vals cl_init)
+ (* inh_init, transl_vals cla true vals cl_init *)
+ (inh_init, cl_init, methods, vals @ values)
| Tclass_apply (cl, exprs) ->
build_class_init cla cstr super inh_init cl_init msubst top cl
| Tclass_let (rec_flag, defs, vals, cl) ->
- let (inh_init, cl_init) =
+ let (inh_init, cl_init, methods, values) =
build_class_init cla cstr super inh_init cl_init msubst top cl
in
+ let fv = free_variables ~ifused:true cl_init in
+ let vals = List.filter (fun (id,_) -> IdentSet.mem id fv) vals in
let vals = List.map (function (id, _) -> (Ident.name id, id)) vals in
- (inh_init, transl_vals cla true vals cl_init)
+ (* inh_init, transl_vals cla true vals cl_init *)
+ (inh_init, cl_init, methods, vals @ values)
| Tclass_constraint (cl, vals, meths, concr_meths) ->
let virt_meths =
List.filter (fun lab -> not (Concr.mem lab concr_meths)) meths in
@@ -358,23 +367,34 @@
cl_init valids in
(inh_init,
Llet (Strict, inh,
- Lapply(oo_prim "inherits", narrow_args @
- [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
+ lprim "inherits"
+ (narrow_args @
+ [lpath; Lconst(Const_pointer(if top then 1 else 0))]),
Llet(StrictOpt, obj_init, lfield inh 0,
Llet(Alias, inh_vals, lfield inh 1,
- Llet(Alias, inh_meths, lfield inh 2, cl_init)))))
+ Llet(Alias, inh_meths, lfield inh 2, cl_init)))),
+ [], [])
| _ ->
let core cl_init =
build_class_init cla true super inh_init cl_init msubst top cl
in
if cstr then core cl_init else
- let (inh_init, cl_init) =
- core (Lsequence (Lapply (oo_prim "widen", [Lvar cla]), cl_init))
+ let (inh_init, cl_init, methods, values) =
+ core (Lsequence (lprim "widen" [Lvar cla], cl_init))
in
- (inh_init,
- Lsequence(Lapply (oo_prim "narrow", narrow_args), cl_init))
+ let cl_init = bind_methods cla methods values cl_init in
+ (inh_init, Lsequence(lprim "narrow" narrow_args, cl_init), [], [])
end
+let build_class_init cla env inh_init obj_init msubst top cl =
+ let inh_init = List.rev inh_init in
+ let (inh_init, cl_init, methods, values) =
+ build_class_init cla true ([],[]) inh_init obj_init msubst top cl in
+ assert (inh_init = []);
+ if IdentSet.mem env (free_variables ~ifused:true cl_init)
+ then bind_methods cla methods (("", env) :: values) cl_init
+ else Llet(Alias, env, lambda_unit, bind_methods cla methods values cl_init)
+
let rec build_class_lets cl =
match cl.cl_desc with
Tclass_let (rec_flag, defs, vals, cl) ->
@@ -459,16 +479,16 @@
Strict, new_init, lfunction [obj_init] obj_init',
Llet(
Alias, cla, transl_path path,
- Lprim(Pmakeblock(0, Immutable),
- [Lapply(Lvar new_init, [lfield cla 0]);
- lfunction [table]
- (Llet(Strict, env_init,
- Lapply(lfield cla 1, [Lvar table]),
- lfunction [envs]
- (Lapply(Lvar new_init,
- [Lapply(Lvar env_init, [Lvar envs])]))));
- lfield cla 2;
- lfield cla 3])))
+ ltuple
+ [Lapply(Lvar new_init, [lfield cla 0]);
+ lfunction [table]
+ (Llet(Strict, env_init,
+ Lapply(lfield cla 1, [Lvar table]),
+ lfunction [envs]
+ (Lapply(Lvar new_init,
+ [Lapply(Lvar env_init, [Lvar envs])]))));
+ lfield cla 2;
+ lfield cla 3]))
with Exit ->
lambda_unit
@@ -541,7 +561,7 @@
open CamlinternalOO
let builtin_meths arr self env env2 body =
let builtin, args = builtin_meths self env env2 body in
- if not arr then [Lapply(oo_prim builtin, args)] else
+ if not arr then [lprim builtin args] else
let tag = match builtin with
"get_const" -> GetConst
| "get_var" -> GetVar
@@ -599,7 +619,8 @@
(* Prepare for heavy environment handling *)
let tables = Ident.create (Ident.name cl_id ^ "_tables") in
- let (top_env, req) = oo_add_class tables in
+ let table_init = ref None in
+ let (top_env, req) = oo_add_class tables table_init in
let top = not req in
let cl_env, llets = build_class_lets cl in
let new_ids = if top then [] else Env.diff top_env cl_env in
@@ -633,6 +654,7 @@
begin try
(* Doesn't seem to improve size for bytecode *)
(* if not !Clflags.native_code then raise Not_found; *)
+ if !Clflags.debug then raise Not_found;
builtin_meths arr [self] env env2 (lfunction args body')
with Not_found ->
[lfunction (self :: args)
@@ -665,15 +687,8 @@
build_object_init_0 cla [] cl copy_env subst_env top ids in
if not (Translcore.check_recursive_lambda ids obj_init) then
raise(Error(cl.cl_loc, Illegal_class_expr));
- let inh_init' = List.rev inh_init in
- let (inh_init', cl_init) =
- build_class_init cla true ([],[]) inh_init' obj_init msubst top cl
- in
- assert (inh_init' = []);
- let table = Ident.create "table"
- and class_init = Ident.create (Ident.name cl_id ^ "_init")
- and env_init = Ident.create "env_init"
- and obj_init = Ident.create "obj_init" in
+ let cl_init = build_class_init cla env2 inh_init obj_init msubst top cl in
+ let obj_init = Ident.create "obj_init" in
let pub_meths =
List.sort
(fun s s' -> compare (Btype.hash_variant s) (Btype.hash_variant s'))
@@ -685,42 +700,44 @@
let name' = List.assoc tag rev_map in
if name' <> name then raise(Error(cl.cl_loc, Tags(name, name'))))
tags pub_meths;
+ let pos = cl.cl_loc.Location.loc_end in
+ let filepos = [transl_label pos.Lexing.pos_fname;
+ Lconst(Const_base(Const_int pos.Lexing.pos_cnum))] in
let ltable table lam =
- Llet(Strict, table,
- Lapply (oo_prim "create_table", [transl_meth_list pub_meths]), lam)
+ Llet(Strict, table, lprim "create_table" [transl_meth_list pub_meths], lam)
and ldirect obj_init =
Llet(Strict, obj_init, cl_init,
- Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
+ Lsequence(lprim "init_class_shared" (Lvar cla :: filepos),
Lapply(Lvar obj_init, [lambda_unit])))
in
(* Simplest case: an object defined at toplevel (ids=[]) *)
if top && ids = [] then llets (ltable cla (ldirect obj_init)) else
+ let table = Ident.create "table"
+ and class_init = Ident.create (Ident.name cl_id ^ "_init")
+ and env_init = Ident.create (Ident.name cl_id ^ "_env_init") in
+ let cl_init_fun = Lfunction(Curried, [cla], cl_init) in
let concrete =
ids = [] ||
Typeclass.virtual_methods (Ctype.signature_of_class_type cl.cl_type) = []
- and lclass lam =
- let cl_init = llets (Lfunction(Curried, [cla], cl_init)) in
+ and lclass cl_init lam =
Llet(Strict, class_init, cl_init, lam (free_variables cl_init))
and lbody fv =
if List.for_all (fun id -> not (IdentSet.mem id fv)) ids then
- Lapply (oo_prim "make_class",[transl_meth_list pub_meths;
- Lvar class_init])
+ lprim "make_class"
+ (transl_meth_list pub_meths :: Lvar class_init :: filepos)
else
ltable table (
Llet(
Strict, env_init, Lapply(Lvar class_init, [Lvar table]),
- Lsequence(
- Lapply (oo_prim "init_class", [Lvar table]),
- Lprim(Pmakeblock(0, Immutable),
- [Lapply(Lvar env_init, [lambda_unit]);
- Lvar class_init; Lvar env_init; lambda_unit]))))
+ Lsequence(lprim "init_class_shared" (Lvar table :: filepos),
+ ltuple [Lapply(Lvar env_init, [lambda_unit]);
+ Lvar class_init; Lvar env_init; lambda_unit])))
and lbody_virt lenvs =
- Lprim(Pmakeblock(0, Immutable),
- [lambda_unit; Lfunction(Curried,[cla], cl_init); lambda_unit; lenvs])
+ ltuple [lambda_unit; cl_init_fun; lambda_unit; lenvs]
in
(* Still easy: a class defined at toplevel *)
- if top && concrete then lclass lbody else
+ if top && concrete then lclass (llets cl_init_fun) lbody else
if top then llets (lbody_virt lambda_unit) else
(* Now for the hard stuff: prepare for table cacheing *)
@@ -733,23 +750,16 @@
let lenv =
let menv =
if !new_ids_meths = [] then lambda_unit else
- Lprim(Pmakeblock(0, Immutable),
- List.map (fun id -> Lvar id) !new_ids_meths) in
+ ltuple (List.map (fun id -> Lvar id) !new_ids_meths) in
if !new_ids_init = [] then menv else
- Lprim(Pmakeblock(0, Immutable),
- menv :: List.map (fun id -> Lvar id) !new_ids_init)
+ ltuple (menv :: List.map (fun id -> Lvar id) !new_ids_init)
and linh_envs =
List.map (fun (_, p) -> Lprim(Pfield 3, [transl_path p]))
(List.rev inh_init)
in
let make_envs lam =
Llet(StrictOpt, envs,
- (if linh_envs = [] then lenv else
- Lprim(Pmakeblock(0, Immutable), lenv :: linh_envs)),
- lam)
- and def_ids cla lam =
- Llet(StrictOpt, env2,
- Lapply (oo_prim "new_variable", [Lvar cla; transl_label ""]),
+ (if linh_envs = [] then lenv else ltuple (lenv :: linh_envs)),
lam)
in
let inh_paths =
@@ -757,46 +767,53 @@
(fun (_,path) -> List.mem (Path.head path) new_ids) inh_init in
let inh_keys =
List.map (fun (_,p) -> Lprim(Pfield 1, [transl_path p])) inh_paths in
- let lclass lam =
- Llet(Strict, class_init,
- Lfunction(Curried, [cla], def_ids cla cl_init), lam)
+ let lclass_init lam =
+ Llet(Strict, class_init, cl_init_fun, lam)
and lcache lam =
if inh_keys = [] then Llet(Alias, cached, Lvar tables, lam) else
- Llet(Strict, cached,
- Lapply(oo_prim "lookup_tables",
- [Lvar tables; Lprim(Pmakeblock(0, Immutable), inh_keys)]),
+ Llet(Strict, cached, lprim "lookup_tables" [Lvar tables; ltuple inh_keys],
lam)
and lset cached i lam =
Lprim(Psetfield(i, true), [Lvar cached; lam])
in
- let ldirect () =
- ltable cla
- (Llet(Strict, env_init, def_ids cla cl_init,
- Lsequence(Lapply (oo_prim "init_class", [Lvar cla]),
- lset cached 0 (Lvar env_init))))
- and lclass_virt () =
- lset cached 0 (Lfunction(Curried, [cla], def_ids cla cl_init))
+ let ldirect prim pos =
+ ltable cla (
+ Llet(Strict, env_init, cl_init,
+ Lsequence(lprim prim (Lvar cla :: pos), Lvar env_init)))
+ and lclass_concrete cached =
+ ltuple [Lapply (lfield cached 0, [lenvs]);
+ lfield cached 1; lfield cached 0; lenvs]
in
+
llets (
- lcache (
- Lsequence(
- Lifthenelse(lfield cached 0, lambda_unit,
- if ids = [] then ldirect () else
- if not concrete then lclass_virt () else
- lclass (
- Lapply (oo_prim "make_class_store",
- [transl_meth_list pub_meths;
- Lvar class_init; Lvar cached]))),
make_envs (
- if ids = [] then Lapply(lfield cached 0, [lenvs]) else
- Lprim(Pmakeblock(0, Immutable),
- if concrete then
- [Lapply(lfield cached 0, [lenvs]);
- lfield cached 1;
- lfield cached 0;
- lenvs]
- else [lambda_unit; lfield cached 0; lambda_unit; lenvs]
- )))))
+ if inh_paths = [] && concrete then
+ if ids = [] then begin
+ table_init := Some (ldirect "init_class_shared" filepos);
+ Lapply (Lvar tables, [lenvs])
+ end else begin
+ let init =
+ lclass cl_init_fun (fun _ ->
+ lprim "make_class_env"
+ (transl_meth_list pub_meths :: Lvar class_init :: filepos))
+ in table_init := Some init;
+ lclass_concrete tables
+ end
+ else begin
+ lcache (
+ Lsequence(
+ Lifthenelse(lfield cached 0, lambda_unit,
+ if ids = [] then lset cached 0 (ldirect "init_class" []) else
+ if not concrete then lset cached 0 cl_init_fun else
+ lclass_init (
+ lprim "make_class_store"
+ [transl_meth_list pub_meths; Lvar class_init; Lvar cached])),
+ llets (
+ make_envs (
+ if ids = [] then Lapply(lfield cached 0, [lenvs]) else
+ if concrete then lclass_concrete cached else
+ ltuple [lambda_unit; lfield cached 0; lambda_unit; lenvs]))))
+ end))
(* Wrapper for class compilation *)
Index: bytecomp/translobj.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.ml,v
retrieving revision 1.9
diff -u -r1.9 translobj.ml
--- bytecomp/translobj.ml 26 May 2004 11:10:51 -0000 1.9
+++ bytecomp/translobj.ml 2 Feb 2006 05:08:56 -0000
@@ -88,7 +88,6 @@
(* Insert labels *)
-let string s = Lconst (Const_base (Const_string s))
let int n = Lconst (Const_base (Const_int n))
let prim_makearray =
@@ -124,8 +123,8 @@
let top_env = ref Env.empty
let classes = ref []
-let oo_add_class id =
- classes := id :: !classes;
+let oo_add_class id init =
+ classes := (id, init) :: !classes;
(!top_env, !cache_required)
let oo_wrap env req f x =
@@ -141,10 +140,12 @@
let lambda = f x in
let lambda =
List.fold_left
- (fun lambda id ->
+ (fun lambda (id, init) ->
Llet(StrictOpt, id,
- Lprim(Pmakeblock(0, Mutable),
- [lambda_unit; lambda_unit; lambda_unit]),
+ (match !init with
+ Some lam -> lam
+ | None -> Lprim(Pmakeblock(0, Mutable),
+ [lambda_unit; lambda_unit; lambda_unit])),
lambda))
lambda !classes
in
Index: bytecomp/translobj.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/bytecomp/translobj.mli,v
retrieving revision 1.6
diff -u -r1.6 translobj.mli
--- bytecomp/translobj.mli 26 May 2004 11:10:51 -0000 1.6
+++ bytecomp/translobj.mli 2 Feb 2006 05:08:56 -0000
@@ -25,4 +25,4 @@
Ident.t -> int -> ('a -> lambda) -> 'a -> int * lambda
val oo_wrap: Env.t -> bool -> ('a -> lambda) -> 'a -> lambda
-val oo_add_class: Ident.t -> Env.t * bool
+val oo_add_class: Ident.t -> Lambda.lambda option ref -> Env.t * bool
Index: byterun/compare.h
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/byterun/compare.h,v
retrieving revision 1.2
diff -u -r1.2 compare.h
--- byterun/compare.h 31 Dec 2003 14:20:35 -0000 1.2
+++ byterun/compare.h 2 Feb 2006 05:08:56 -0000
@@ -17,5 +17,6 @@
#define CAML_COMPARE_H
CAMLextern int caml_compare_unordered;
+CAMLextern value caml_compare(value, value);
#endif /* CAML_COMPARE_H */
Index: byterun/extern.c
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/byterun/extern.c,v
retrieving revision 1.59
diff -u -r1.59 extern.c
--- byterun/extern.c 4 Jan 2006 16:55:49 -0000 1.59
+++ byterun/extern.c 2 Feb 2006 05:08:56 -0000
@@ -411,6 +411,22 @@
extern_record_location(v);
break;
}
+ case Object_tag: {
+ value field0;
+ mlsize_t i;
+ i = Wosize_val(Field(v, 0)) - 1;
+ field0 = Field(Field(v, 0),i);
+ if (Wosize_val(field0) > 0) {
+ writecode32(CODE_OBJECT, Wosize_hd (hd));
+ extern_record_location(v);
+ extern_rec(field0);
+ for (i = 1; i < sz - 1; i++) extern_rec(Field(v, i));
+ v = Field(v, i);
+ goto tailcall;
+ }
+ if (!extern_closures)
+ extern_invalid_argument("output_value: dynamic class");
+ } /* may fall through */
default: {
value field0;
mlsize_t i;
Index: byterun/intern.c
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/byterun/intern.c,v
retrieving revision 1.60
diff -u -r1.60 intern.c
--- byterun/intern.c 22 Sep 2005 14:21:50 -0000 1.60
+++ byterun/intern.c 2 Feb 2006 05:08:56 -0000
@@ -28,6 +28,8 @@
#include "mlvalues.h"
#include "misc.h"
#include "reverse.h"
+#include "callback.h"
+#include "compare.h"
static unsigned char * intern_src;
/* Reading pointer in block holding input data. */
@@ -98,6 +100,25 @@
#define readblock(dest,len) \
(memmove((dest), intern_src, (len)), intern_src += (len))
+static value get_method_table (value key)
+{
+ static value *classes = NULL;
+ value current;
+ if (classes == NULL) {
+ classes = caml_named_value("caml_oo_classes");
+ if (classes == NULL) return 0;
+ caml_register_global_root(classes);
+ }
+ for (current = Field(*classes, 0); Is_block(current);
+ current = Field(current, 1))
+ {
+ value head = Field(current, 0);
+ if (caml_compare(key, Field(head, 0)) == Val_int(0))
+ return Field(head, 1);
+ }
+ return 0;
+}
+
static void intern_cleanup(void)
{
if (intern_input_malloced) caml_stat_free(intern_input);
@@ -315,6 +336,24 @@
Custom_ops_val(v) = ops;
intern_dest += 1 + size;
break;
+ case CODE_OBJECT:
+ size = read32u();
+ v = Val_hp(intern_dest);
+ *dest = v;
+ if (intern_obj_table != NULL) intern_obj_table[obj_counter++] = v;
+ dest = (value *) (intern_dest + 1);
+ *intern_dest = Make_header(size, Object_tag, intern_color);
+ intern_dest += 1 + size;
+ intern_rec(dest);
+ *dest = get_method_table(*dest);
+ if (*dest == 0) {
+ intern_cleanup();
+ caml_failwith("input_value: unknown class");
+ }
+ for(size--, dest++; size > 1; size--, dest++)
+ intern_rec(dest);
+ goto tailcall;
+
default:
intern_cleanup();
caml_failwith("input_value: ill-formed message");
Index: byterun/intext.h
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/byterun/intext.h,v
retrieving revision 1.32
diff -u -r1.32 intext.h
--- byterun/intext.h 22 Sep 2005 14:21:50 -0000 1.32
+++ byterun/intext.h 2 Feb 2006 05:08:56 -0000
@@ -56,6 +56,7 @@
#define CODE_CODEPOINTER 0x10
#define CODE_INFIXPOINTER 0x11
#define CODE_CUSTOM 0x12
+#define CODE_OBJECT 0x14
#if ARCH_FLOAT_ENDIANNESS == 0x76543210
#define CODE_DOUBLE_NATIVE CODE_DOUBLE_BIG
Index: stdlib/camlinternalOO.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.ml,v
retrieving revision 1.14
diff -u -r1.14 camlinternalOO.ml
--- stdlib/camlinternalOO.ml 25 Oct 2005 18:34:07 -0000 1.14
+++ stdlib/camlinternalOO.ml 2 Feb 2006 05:08:56 -0000
@@ -305,10 +305,38 @@
public_methods;
table
+(*
+let create_table_variables pub_meths priv_meths vars =
+ let tbl = create_table pub_meths in
+ let pub_meths = to_array pub_meths
+ and priv_meths = to_array priv_meths
+ and vars = to_array vars in
+ let len = 2 + Array.length pub_meths + Array.length priv_meths in
+ let res = Array.create len tbl in
+ let mv = new_methods_variables tbl pub_meths vars in
+ Array.blit mv 0 res 1;
+ res
+*)
+
let init_class table =
inst_var_count := !inst_var_count + table.size - 1;
table.initializers <- List.rev table.initializers;
- resize table (3 + magic table.methods.(1) * 16 / Sys.word_size)
+ let len = 3 + magic table.methods.(1) * 16 / Sys.word_size in
+ (* keep 1 more for extra info *)
+ let len = if len > Array.length table.methods then len else len+1 in
+ resize table len
+
+let classes = ref []
+let () = Callback.register "caml_oo_classes" classes
+
+let init_class_shared table (file : string) (pos : int) =
+ init_class table;
+ let rec unique_pos pos =
+ if List.mem_assoc (file, pos) !classes then unique_pos (pos + 0x100000)
+ else pos in
+ let pos = unique_pos pos in
+ table.methods.(Array.length table.methods - 1) <- Obj.magic (file, pos);
+ classes := ((file, pos), table.methods) :: !classes
let inherits cla vals virt_meths concr_meths (_, super, _, env) top =
narrow cla vals virt_meths concr_meths;
@@ -319,12 +347,18 @@
Array.map (fun nm -> get_method cla (get_method_label cla nm))
(to_array concr_meths))
-let make_class pub_meths class_init =
+let make_class pub_meths class_init file pos =
let table = create_table pub_meths in
let env_init = class_init table in
- init_class table;
+ init_class_shared table file pos;
(env_init (Obj.repr 0), class_init, env_init, Obj.repr 0)
+let make_class_env pub_meths class_init file pos =
+ let table = create_table pub_meths in
+ let env_init = class_init table in
+ init_class_shared table file pos;
+ (env_init, class_init)
+
type init_table = { mutable env_init: t; mutable class_init: table -> t }
let make_class_store pub_meths class_init init_table =
Index: stdlib/camlinternalOO.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/stdlib/camlinternalOO.mli,v
retrieving revision 1.9
diff -u -r1.9 camlinternalOO.mli
--- stdlib/camlinternalOO.mli 25 Oct 2005 18:34:07 -0000 1.9
+++ stdlib/camlinternalOO.mli 2 Feb 2006 05:08:56 -0000
@@ -43,14 +43,20 @@
val add_initializer : table -> (obj -> unit) -> unit
val dummy_table : table
val create_table : string array -> table
+(* val create_table_variables :
+ string array -> string array -> string array -> table *)
val init_class : table -> unit
+val init_class_shared : table -> string -> int -> unit
val inherits :
table -> string array -> string array -> string array ->
(t * (table -> obj -> Obj.t) * t * obj) -> bool ->
(Obj.t * int array * closure array)
val make_class :
- string array -> (table -> Obj.t -> t) ->
+ string array -> (table -> Obj.t -> t) -> string -> int ->
(t * (table -> Obj.t -> t) * (Obj.t -> t) * Obj.t)
+val make_class_env :
+ string array -> (table -> Obj.t -> t) -> string -> int ->
+ (Obj.t -> t) * (table -> Obj.t -> t)
type init_table
val make_class_store :
string array -> (table -> t) -> init_table -> unit

403
experimental/garrigue/module-errors.diff
View File

@ -1,403 +0,0 @@
Index: typing/includemod.ml
===================================================================
--- typing/includemod.ml (revision 11161)
+++ typing/includemod.ml (working copy)
@@ -19,7 +19,7 @@
open Types
open Typedtree
-type error =
+type symptom =
Missing_field of Ident.t
| Value_descriptions of Ident.t * value_description * value_description
| Type_declarations of Ident.t * type_declaration
@@ -38,6 +38,10 @@
Ctype.class_match_failure list
| Unbound_modtype_path of Path.t
+type pos =
+ Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
+type error = pos list * symptom
+
exception Error of error list
(* All functions "blah env x1 x2" check that x1 is included in x2,
@@ -46,51 +50,52 @@
(* Inclusion between value descriptions *)
-let value_descriptions env subst id vd1 vd2 =
+let value_descriptions env cxt subst id vd1 vd2 =
let vd2 = Subst.value_description subst vd2 in
try
Includecore.value_descriptions env vd1 vd2
with Includecore.Dont_match ->
- raise(Error[Value_descriptions(id, vd1, vd2)])
+ raise(Error[cxt, Value_descriptions(id, vd1, vd2)])
(* Inclusion between type declarations *)
-let type_declarations env subst id decl1 decl2 =
+let type_declarations env cxt subst id decl1 decl2 =
let decl2 = Subst.type_declaration subst decl2 in
let err = Includecore.type_declarations env id decl1 decl2 in
- if err <> [] then raise(Error[Type_declarations(id, decl1, decl2, err)])
+ if err <> [] then raise(Error[cxt, Type_declarations(id, decl1, decl2, err)])
(* Inclusion between exception declarations *)
-let exception_declarations env subst id decl1 decl2 =
+let exception_declarations env cxt subst id decl1 decl2 =
let decl2 = Subst.exception_declaration subst decl2 in
if Includecore.exception_declarations env decl1 decl2
then ()
- else raise(Error[Exception_declarations(id, decl1, decl2)])
+ else raise(Error[cxt, Exception_declarations(id, decl1, decl2)])
(* Inclusion between class declarations *)
-let class_type_declarations env subst id decl1 decl2 =
+let class_type_declarations env cxt subst id decl1 decl2 =
let decl2 = Subst.cltype_declaration subst decl2 in
match Includeclass.class_type_declarations env decl1 decl2 with
[] -> ()
- | reason -> raise(Error[Class_type_declarations(id, decl1, decl2, reason)])
+ | reason ->
+ raise(Error[cxt, Class_type_declarations(id, decl1, decl2, reason)])
-let class_declarations env subst id decl1 decl2 =
+let class_declarations env cxt subst id decl1 decl2 =
let decl2 = Subst.class_declaration subst decl2 in
match Includeclass.class_declarations env decl1 decl2 with
[] -> ()
- | reason -> raise(Error[Class_declarations(id, decl1, decl2, reason)])
+ | reason -> raise(Error[cxt, Class_declarations(id, decl1, decl2, reason)])
(* Expand a module type identifier when possible *)
exception Dont_match
-let expand_module_path env path =
+let expand_module_path env cxt path =
try
Env.find_modtype_expansion path env
with Not_found ->
- raise(Error[Unbound_modtype_path path])
+ raise(Error[cxt, Unbound_modtype_path path])
(* Extract name, kind and ident from a signature item *)
@@ -128,28 +133,29 @@
Return the restriction that transforms a value of the smaller type
into a value of the bigger type. *)
-let rec modtypes env subst mty1 mty2 =
+let rec modtypes env cxt subst mty1 mty2 =
try
- try_modtypes env subst mty1 mty2
+ try_modtypes env cxt subst mty1 mty2
with
Dont_match ->
- raise(Error[Module_types(mty1, Subst.modtype subst mty2)])
+ raise(Error[cxt, Module_types(mty1, Subst.modtype subst mty2)])
| Error reasons ->
- raise(Error(Module_types(mty1, Subst.modtype subst mty2) :: reasons))
+ raise(Error((cxt, Module_types(mty1, Subst.modtype subst mty2))
+ :: reasons))
-and try_modtypes env subst mty1 mty2 =
+and try_modtypes env cxt subst mty1 mty2 =
match (mty1, mty2) with
(_, Tmty_ident p2) ->
- try_modtypes2 env mty1 (Subst.modtype subst mty2)
+ try_modtypes2 env cxt mty1 (Subst.modtype subst mty2)
| (Tmty_ident p1, _) ->
- try_modtypes env subst (expand_module_path env p1) mty2
+ try_modtypes env cxt subst (expand_module_path env cxt p1) mty2
| (Tmty_signature sig1, Tmty_signature sig2) ->
- signatures env subst sig1 sig2
+ signatures env cxt subst sig1 sig2
| (Tmty_functor(param1, arg1, res1), Tmty_functor(param2, arg2, res2)) ->
let arg2' = Subst.modtype subst arg2 in
- let cc_arg = modtypes env Subst.identity arg2' arg1 in
+ let cc_arg = modtypes env (Arg param1::cxt) Subst.identity arg2' arg1 in
let cc_res =
- modtypes (Env.add_module param1 arg2' env)
+ modtypes (Env.add_module param1 arg2' env) (Body param1::cxt)
(Subst.add_module param2 (Pident param1) subst) res1 res2 in
begin match (cc_arg, cc_res) with
(Tcoerce_none, Tcoerce_none) -> Tcoerce_none
@@ -158,19 +164,19 @@
| (_, _) ->
raise Dont_match
-and try_modtypes2 env mty1 mty2 =
+and try_modtypes2 env cxt mty1 mty2 =
(* mty2 is an identifier *)
match (mty1, mty2) with
(Tmty_ident p1, Tmty_ident p2) when Path.same p1 p2 ->
Tcoerce_none
| (_, Tmty_ident p2) ->
- try_modtypes env Subst.identity mty1 (expand_module_path env p2)
+ try_modtypes env cxt Subst.identity mty1 (expand_module_path env cxt p2)
| (_, _) ->
assert false
(* Inclusion between signatures *)
-and signatures env subst sig1 sig2 =
+and signatures env cxt subst sig1 sig2 =
(* Environment used to check inclusion of components *)
let new_env =
Env.add_signature sig1 env in
@@ -202,7 +208,7 @@
let rec pair_components subst paired unpaired = function
[] ->
begin match unpaired with
- [] -> signature_components new_env subst (List.rev paired)
+ [] -> signature_components new_env cxt subst (List.rev paired)
| _ -> raise(Error unpaired)
end
| item2 :: rem ->
@@ -234,7 +240,7 @@
((item1, item2, pos1) :: paired) unpaired rem
with Not_found ->
let unpaired =
- if report then Missing_field id2 :: unpaired else unpaired in
+ if report then (cxt, Missing_field id2) :: unpaired else unpaired in
pair_components subst paired unpaired rem
end in
(* Do the pairing and checking, and return the final coercion *)
@@ -242,65 +248,67 @@
(* Inclusion between signature components *)
-and signature_components env subst = function
+and signature_components env cxt subst = function
[] -> []
| (Tsig_value(id1, valdecl1), Tsig_value(id2, valdecl2), pos) :: rem ->
- let cc = value_descriptions env subst id1 valdecl1 valdecl2 in
+ let cc = value_descriptions env cxt subst id1 valdecl1 valdecl2 in
begin match valdecl2.val_kind with
- Val_prim p -> signature_components env subst rem
- | _ -> (pos, cc) :: signature_components env subst rem
+ Val_prim p -> signature_components env cxt subst rem
+ | _ -> (pos, cc) :: signature_components env cxt subst rem
end
| (Tsig_type(id1, tydecl1, _), Tsig_type(id2, tydecl2, _), pos) :: rem ->
- type_declarations env subst id1 tydecl1 tydecl2;
- signature_components env subst rem
+ type_declarations env cxt subst id1 tydecl1 tydecl2;
+ signature_components env cxt subst rem
| (Tsig_exception(id1, excdecl1), Tsig_exception(id2, excdecl2), pos)
:: rem ->
- exception_declarations env subst id1 excdecl1 excdecl2;
- (pos, Tcoerce_none) :: signature_components env subst rem
+ exception_declarations env cxt subst id1 excdecl1 excdecl2;
+ (pos, Tcoerce_none) :: signature_components env cxt subst rem
| (Tsig_module(id1, mty1, _), Tsig_module(id2, mty2, _), pos) :: rem ->
let cc =
- modtypes env subst (Mtype.strengthen env mty1 (Pident id1)) mty2 in
- (pos, cc) :: signature_components env subst rem
+ modtypes env (Module id1::cxt) subst
+ (Mtype.strengthen env mty1 (Pident id1)) mty2 in
+ (pos, cc) :: signature_components env cxt subst rem
| (Tsig_modtype(id1, info1), Tsig_modtype(id2, info2), pos) :: rem ->
- modtype_infos env subst id1 info1 info2;
- signature_components env subst rem
+ modtype_infos env cxt subst id1 info1 info2;
+ signature_components env cxt subst rem
| (Tsig_class(id1, decl1, _), Tsig_class(id2, decl2, _), pos) :: rem ->
- class_declarations env subst id1 decl1 decl2;
- (pos, Tcoerce_none) :: signature_components env subst rem
+ class_declarations env cxt subst id1 decl1 decl2;
+ (pos, Tcoerce_none) :: signature_components env cxt subst rem
| (Tsig_cltype(id1, info1, _), Tsig_cltype(id2, info2, _), pos) :: rem ->
- class_type_declarations env subst id1 info1 info2;
- signature_components env subst rem
+ class_type_declarations env cxt subst id1 info1 info2;
+ signature_components env cxt subst rem
| _ ->
assert false
(* Inclusion between module type specifications *)
-and modtype_infos env subst id info1 info2 =
+and modtype_infos env cxt subst id info1 info2 =
let info2 = Subst.modtype_declaration subst info2 in
+ let cxt' = Modtype id :: cxt in
try
match (info1, info2) with
(Tmodtype_abstract, Tmodtype_abstract) -> ()
| (Tmodtype_manifest mty1, Tmodtype_abstract) -> ()
| (Tmodtype_manifest mty1, Tmodtype_manifest mty2) ->
- check_modtype_equiv env mty1 mty2
+ check_modtype_equiv env cxt' mty1 mty2
| (Tmodtype_abstract, Tmodtype_manifest mty2) ->
- check_modtype_equiv env (Tmty_ident(Pident id)) mty2
+ check_modtype_equiv env cxt' (Tmty_ident(Pident id)) mty2
with Error reasons ->
- raise(Error(Modtype_infos(id, info1, info2) :: reasons))
+ raise(Error((cxt, Modtype_infos(id, info1, info2)) :: reasons))
-and check_modtype_equiv env mty1 mty2 =
+and check_modtype_equiv env cxt mty1 mty2 =
match
- (modtypes env Subst.identity mty1 mty2,
- modtypes env Subst.identity mty2 mty1)
+ (modtypes env cxt Subst.identity mty1 mty2,
+ modtypes env cxt Subst.identity mty2 mty1)
with
(Tcoerce_none, Tcoerce_none) -> ()
- | (_, _) -> raise(Error [Modtype_permutation])
+ | (_, _) -> raise(Error [cxt, Modtype_permutation])
(* Simplified inclusion check between module types (for Env) *)
let check_modtype_inclusion env mty1 path1 mty2 =
try
- ignore(modtypes env Subst.identity
+ ignore(modtypes env [] Subst.identity
(Mtype.strengthen env mty1 path1) mty2)
with Error reasons ->
raise Not_found
@@ -312,16 +320,16 @@
let compunit impl_name impl_sig intf_name intf_sig =
try
- signatures Env.initial Subst.identity impl_sig intf_sig
+ signatures Env.initial [] Subst.identity impl_sig intf_sig
with Error reasons ->
- raise(Error(Interface_mismatch(impl_name, intf_name) :: reasons))
+ raise(Error(([], Interface_mismatch(impl_name, intf_name)) :: reasons))
-(* Hide the substitution parameter to the outside world *)
+(* Hide the context and substitution parameters to the outside world *)
-let modtypes env mty1 mty2 = modtypes env Subst.identity mty1 mty2
-let signatures env sig1 sig2 = signatures env Subst.identity sig1 sig2
+let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
+let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
let type_declarations env id decl1 decl2 =
- type_declarations env Subst.identity id decl1 decl2
+ type_declarations env [] Subst.identity id decl1 decl2
(* Error report *)
@@ -384,9 +392,62 @@
| Unbound_modtype_path path ->
fprintf ppf "Unbound module type %a" Printtyp.path path
-let report_error ppf = function
- | [] -> ()
- | err :: errs ->
- let print_errs ppf errs =
- List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in
- fprintf ppf "@[<v>%a%a@]" include_err err print_errs errs
+let rec context ppf = function
+ Module id :: rem ->
+ fprintf ppf "@[<2>module %a%a@]" ident id args rem
+ | Modtype id :: rem ->
+ fprintf ppf "@[<2>module type %a =@ %a@]" ident id context_mty rem
+ | Body x :: rem ->
+ fprintf ppf "functor (%a) ->@ %a" ident x context_mty rem
+ | Arg x :: rem ->
+ fprintf ppf "functor (%a : %a) -> ..." ident x context_mty rem
+ | [] ->
+ fprintf ppf "<here>"
+and context_mty ppf = function
+ (Module _ | Modtype _) :: _ as rem ->
+ fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem
+ | cxt -> context ppf cxt
+and args ppf = function
+ Body x :: rem ->
+ fprintf ppf "(%a)%a" ident x args rem
+ | Arg x :: rem ->
+ fprintf ppf "(%a :@ %a) : ..." ident x context_mty rem
+ | cxt ->
+ fprintf ppf " :@ %a" context_mty cxt
+
+let path_of_context = function
+ Module id :: rem ->
+ let rec subm path = function
+ [] -> path
+ | Module id :: rem -> subm (Pdot (path, Ident.name id, -1)) rem
+ | _ -> assert false
+ in subm (Pident id) rem
+ | _ -> assert false
+
+let context ppf cxt =
+ if cxt = [] then () else
+ if List.for_all (function Module _ -> true | _ -> false) cxt then
+ fprintf ppf "In module %a:@ " path (path_of_context cxt)
+ else
+ fprintf ppf "@[<hv 2>At position@ %a@]@ " context cxt
+
+let include_err ppf (cxt, err) =
+ fprintf ppf "@[<v>%a%a@]" context (List.rev cxt) include_err err
+
+let max_size = 500
+let buffer = String.create max_size
+let is_big obj =
+ try ignore (Marshal.to_buffer buffer 0 max_size obj []); false
+ with _ -> true
+
+let report_error ppf errs =
+ if errs = [] then () else
+ let (errs , err) = split_last errs in
+ let pe = ref true in
+ let include_err' ppf err =
+ if !Clflags.show_trace || not (is_big err) then
+ fprintf ppf "%a@ " include_err err
+ else if !pe then (fprintf ppf "...@ "; pe := false)
+ in
+ let print_errs ppf = List.iter (include_err' ppf) in
+ fprintf ppf "@[<v>%a%a@]" print_errs errs include_err err
Index: typing/includemod.mli
===================================================================
--- typing/includemod.mli (revision 11161)
+++ typing/includemod.mli (working copy)
@@ -24,7 +24,7 @@
val type_declarations:
Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
-type error =
+type symptom =
Missing_field of Ident.t
| Value_descriptions of Ident.t * value_description * value_description
| Type_declarations of Ident.t * type_declaration
@@ -43,6 +43,10 @@
Ctype.class_match_failure list
| Unbound_modtype_path of Path.t
+type pos =
+ Module of Ident.t | Modtype of Ident.t | Arg of Ident.t | Body of Ident.t
+type error = pos list * symptom
+
exception Error of error list
val report_error: formatter -> error list -> unit
Index: utils/clflags.ml
===================================================================
--- utils/clflags.ml (revision 11161)
+++ utils/clflags.ml (working copy)
@@ -53,6 +53,7 @@
and dllpaths = ref ([] : string list) (* -dllpath *)
and make_package = ref false (* -pack *)
and for_package = ref (None: string option) (* -for-pack *)
+and show_trace = ref false (* -show-trace *)
let dump_parsetree = ref false (* -dparsetree *)
and dump_rawlambda = ref false (* -drawlambda *)
and dump_lambda = ref false (* -dlambda *)
Index: utils/clflags.mli
===================================================================
--- utils/clflags.mli (revision 11161)
+++ utils/clflags.mli (working copy)
@@ -50,6 +50,7 @@
val dllpaths : string list ref
val make_package : bool ref
val for_package : string option ref
+val show_trace : bool ref
val dump_parsetree : bool ref
val dump_rawlambda : bool ref
val dump_lambda : bool ref

1418
experimental/garrigue/multimatch.diff
View File

File diff suppressed because it is too large Load Diff

158
experimental/garrigue/multimatch.ml
View File

@ -1,158 +0,0 @@
(* Simple example *)
let f x =
(multimatch x with `A -> 1 | `B -> true),
(multimatch x with `A -> 1. | `B -> "1");;
(* OK *)
module M : sig
val f :
[< `A & 'a = int & 'b = float | `B & 'b =string & 'a = bool] -> 'a * 'b
end = struct let f = f end;;
(* Bad *)
module M : sig
val f :
[< `A & 'a = int & 'b = float | `B & 'b =string & 'a = int] -> 'a * 'b
end = struct let f = f end;;
(* Should be good! *)
module M : sig
val f :
[< `A & 'a = int * float | `B & 'a = bool * string] -> 'a
end = struct let f = f end;;
let f = multifun `A|`B as x -> f x;;
(* Two-level example *)
let f = multifun
`A -> (multifun `C -> 1 | `D -> 1.)
| `B -> (multifun `C -> true | `D -> "1");;
(* OK *)
module M : sig
val f :
[< `A & 'b = [< `C & 'a = int | `D & 'a = float & 'c = bool] -> 'a
| `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
end = struct let f = f end;;
(* Bad *)
module M : sig
val f :
[< `A & 'b = [< `C & 'a = int | `D & 'a = bool] -> 'a
| `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
end = struct let f = f end;;
module M : sig
val f :
[< `A & 'b = [< `C & 'a = int | `D] -> 'a
| `B & 'b = [< `C & 'c = bool | `D & 'c = string] -> 'c] -> 'b
end = struct let f = f end;;
(* Examples with hidden sharing *)
let r = ref []
let f = multifun `A -> 1 | `B -> true
let g x = r := [f x];;
(* Bad! *)
module M : sig
val g : [< `A & 'a = int | `B & 'a = bool] -> unit
end = struct let g = g end;;
let r = ref []
let f = multifun `A -> r | `B -> ref [];;
(* Now OK *)
module M : sig
val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
end = struct let f = f end;;
(* Still OK *)
let l : int list ref = r;;
module M : sig
val f : [< `A & 'b = int list ref | `B & 'b = 'c list ref] -> 'b
end = struct let f = f end;;
(* Examples that would need unification *)
let f = multifun `A -> (1, []) | `B -> (true, [])
let g x = fst (f x);;
(* Didn't work, now Ok *)
module M : sig
val g : [< `A & 'a * 'b = int * bool | `B & 'a * 'b = bool * int] -> 'a
end = struct let g = g end;;
let g = multifun (`A|`B) as x -> g x;;
(* Other examples *)
let f x =
let a = multimatch x with `A -> 1 | `B -> "1" in
(multifun `A -> print_int | `B -> print_string) x a
;;
let f = multifun (`A|`B) as x -> f x;;
type unit_op = [`Set of int | `Move of int]
type int_op = [`Get]
let op r =
multifun
`Get -> !r
| `Set x -> r := x
| `Move dx -> r := !r + dx
;;
let rec trace r = function
[] -> []
| op1 :: ops ->
multimatch op1 with
#int_op as op1 ->
let x = op r op1 in
x :: trace r ops
| #unit_op as op1 ->
op r op1;
trace r ops
;;
class point x = object
val mutable x : int = x
method get = x
method set y = x <- y
method move dx = x <- x + dx
end;;
let poly sort coeffs x =
let add, mul, zero =
multimatch sort with
`Int -> (+), ( * ), 0
| `Float -> (+.), ( *. ), 0.
in
let rec compute = function
[] -> zero
| c :: cs -> add c (mul x (compute cs))
in
compute coeffs
;;
module M : sig
val poly : [< `Int & 'a = int | `Float & 'a = float] -> 'a list -> 'a -> 'a
end = struct let poly = poly end;;
type ('a,'b) num_sort =
'b constraint 'b = [< `Int & 'a = int | `Float & 'a = float]
module M : sig
val poly : ('a,_) num_sort -> 'a list -> 'a -> 'a
end = struct let poly = poly end;;
(* type dispatch *)
type num = [ `Int | `Float ]
let print0 = multifun
`Int -> print_int
| `Float -> print_float
;;
let print1 = multifun
#num as x -> print0 x
| `List t -> List.iter (print0 t)
| `Pair(t1,t2) -> (fun (x,y) -> print0 t1 x; print0 t2 y)
;;
print1 (`Pair(`Int,`Float)) (1,1.0);;

1458
experimental/garrigue/newlabels.ps
View File

File diff suppressed because it is too large Load Diff

428
experimental/garrigue/nongeneral-let.diff
View File

@ -1,428 +0,0 @@
Index: camlp4/Camlp4/Struct/Grammar/Delete.ml
===================================================================
--- camlp4/Camlp4/Struct/Grammar/Delete.ml (revision 14037)
+++ camlp4/Camlp4/Struct/Grammar/Delete.ml (working copy)
@@ -35,17 +35,17 @@
open Structure;
value raise_rule_not_found entry symbols =
- let to_string f x =
+ let to_string : !'a. (_ -> 'a -> _) -> 'a -> _ = fun [f -> fun [x ->
let buff = Buffer.create 128 in
let ppf = Format.formatter_of_buffer buff in
do {
f ppf x;
Format.pp_print_flush ppf ();
Buffer.contents buff
- } in
- let entry = to_string Print.entry entry in
- let symbols = to_string Print.print_rule symbols in
- raise (Rule_not_found (symbols, entry))
+ }]] in
+ let entry = to_string Print.entry entry in
+ let symbols = to_string Print.print_rule symbols in
+ raise (Rule_not_found (symbols, entry))
;
(* Deleting a rule *)
Index: camlp4/boot/Camlp4.ml
===================================================================
--- camlp4/boot/Camlp4.ml (revision 14037)
+++ camlp4/boot/Camlp4.ml (working copy)
@@ -18022,7 +18022,7 @@
open Structure
let raise_rule_not_found entry symbols =
- let to_string f x =
+ let to_string : 'a. (_ -> 'a -> _) -> 'a -> _ = fun f x ->
let buff = Buffer.create 128 in
let ppf = Format.formatter_of_buffer buff
in
Index: camlp4/Camlp4Filters/Camlp4FoldGenerator.ml
===================================================================
--- camlp4/Camlp4Filters/Camlp4FoldGenerator.ml (revision 14037)
+++ camlp4/Camlp4Filters/Camlp4FoldGenerator.ml (working copy)
@@ -547,14 +547,18 @@
value processor =
let last = ref <:ctyp<>> in
- let generate_class' generator default c s n =
+ let generate_class'
+ : !'a 'b. (_ -> 'a -> _ -> _ -> 'b) -> 'b -> 'a -> _ -> _ -> 'b =
+ fun generator default c s n ->
match s with
[ "Fold" -> generator Fold c last.val n
| "Map" -> generator Map c last.val n
| "FoldMap" -> generator Fold_map c last.val n
| _ -> default ]
in
- let generate_class_from_module_name generator c default m =
+ let generate_class_from_module_name
+ : !'a 'b. (_ -> 'a -> _ -> _ -> 'b) -> 'a -> 'b -> _ -> 'b =
+ fun generator c default m ->
try Scanf.sscanf m "Camlp4%[^G]Generator" begin fun m' ->
try Scanf.sscanf m' "%[^0-9]%d" (generate_class' generator default c)
with [ End_of_file | Scanf.Scan_failure _ -> generate_class' generator default c m' 1 ]
Index: stdlib/arg.ml
===================================================================
--- stdlib/arg.ml (revision 14037)
+++ stdlib/arg.ml (working copy)
@@ -106,7 +106,7 @@
let l = Array.length argv in
let b = Buffer.create 200 in
let initpos = !current in
- let stop error =
+ let stop : 'a. _ -> 'a = fun error ->
let progname = if initpos < l then argv.(initpos) else "(?)" in
begin match error with
| Unknown "-help" -> ()
Index: stdlib/printf.ml
===================================================================
--- stdlib/printf.ml (revision 14037)
+++ stdlib/printf.ml (working copy)
@@ -492,7 +492,7 @@
Don't do this at home, kids. *)
let scan_format fmt args n pos cont_s cont_a cont_t cont_f cont_m =
- let get_arg spec n =
+ let get_arg : 'a. _ -> _ -> 'a = fun spec n ->
Obj.magic (args.(Sformat.int_of_index (get_index spec n))) in
let rec scan_positional n widths i =
Index: stdlib/camlinternalOO.ml
===================================================================
--- stdlib/camlinternalOO.ml (revision 14037)
+++ stdlib/camlinternalOO.ml (working copy)
@@ -349,7 +349,7 @@
init_table.env_init <- env_init
let dummy_class loc =
- let undef = fun _ -> raise (Undefined_recursive_module loc) in
+ let undef : 'a 'b.'a -> 'b = fun _ -> raise (Undefined_recursive_module loc) in
(Obj.magic undef, undef, undef, Obj.repr 0)
(**** Objects ****)
@@ -527,7 +527,7 @@
| Closure of closure
let method_impl table i arr =
- let next () = incr i; magic arr.(!i) in
+ let next : 'a. unit -> 'a = fun () -> incr i; magic arr.(!i) in
match next() with
GetConst -> let x : t = next() in get_const x
| GetVar -> let n = next() in get_var n
Index: stdlib/scanf.ml
===================================================================
--- stdlib/scanf.ml (revision 14037)
+++ stdlib/scanf.ml (working copy)
@@ -1324,10 +1324,11 @@
let limr = Array.length rv - 1 in
- let return v = Obj.magic v () in
- let delay f x () = f x in
- let stack f = delay (return f) in
- let no_stack f _x = f in
+ let return : 'a 'b 'c. ('a -> 'b) -> 'c = fun v -> Obj.magic v () in
+ let delay : 'a 'b. ('a -> 'b) -> 'a -> unit -> 'b = fun f x () -> f x in
+ let stack : 'a 'b 'd 'e. ('a -> 'b) -> 'd -> unit -> 'e =
+ fun f -> delay (return f) in
+ let no_stack : 'a 'b. 'a -> 'b -> 'a = fun f _x -> f in
let rec scan fmt =
@@ -1380,7 +1381,8 @@
scan_conversion skip width_opt prec_opt ir f i
and scan_conversion skip width_opt prec_opt ir f i =
- let stack = if skip then no_stack else stack in
+ let stack : 'b 'd. (unit -> 'b) -> 'd -> unit -> 'b =
+ if skip then no_stack else stack in
let width = int_of_width_opt width_opt in
let prec = int_of_prec_opt prec_opt in
match Sformat.get fmt i with
Index: typing/typemod.ml
===================================================================
--- typing/typemod.ml (revision 14037)
+++ typing/typemod.ml (working copy)
@@ -420,7 +420,7 @@
(* let signature sg = List.map (fun item -> item.sig_type) sg *)
-let rec transl_modtype env smty =
+let rec transl_modtype env smty : Typedtree.module_type =
let loc = smty.pmty_loc in
match smty.pmty_desc with
Pmty_ident lid ->
@@ -609,7 +609,7 @@
List.fold_left
(fun env (id, _, mty) -> Env.add_module id mty.mty_type env)
env curr in
- let transition env_c curr =
+ let transition : 'a. _ -> (_ * _ * 'a) list -> _ = fun env_c curr ->
List.map2
(fun (_,smty) (id,id_loc,mty) -> (id, id_loc, transl_modtype env_c smty))
sdecls curr in
Index: typing/typecore.ml
===================================================================
--- typing/typecore.ml (revision 14037)
+++ typing/typecore.ml (working copy)
@@ -1373,9 +1373,9 @@
let ty_arrow gty ty = newty (Tarrow ("", instance_def gty, ty, Cok)) in
- let bad_conversion fmt i c =
+ let bad_conversion : 'a. string -> int -> char -> 'a = fun fmt i c ->
raise (Error (loc, Env.empty, Bad_conversion (fmt, i, c))) in
- let incomplete_format fmt =
+ let incomplete_format : 'a. string -> 'a = fun fmt ->
raise (Error (loc, Env.empty, Incomplete_format fmt)) in
let rec type_in_format fmt =
@@ -3238,7 +3238,7 @@
(* Typing of let bindings *)
-and type_let ?(check = fun s -> Warnings.Unused_var s)
+and type_let ?(global=false) ?(check = fun s -> Warnings.Unused_var s)
?(check_strict = fun s -> Warnings.Unused_var_strict s)
env rec_flag spat_sexp_list scope allow =
begin_def();
@@ -3368,7 +3368,7 @@
)
pat_list
in
- let exp_list =
+ let exp_gen_list =
List.map2
(fun (spat, sexp) (pat, slot) ->
let sexp =
@@ -3386,9 +3386,12 @@
let exp = type_expect exp_env sexp ty' in
end_def ();
check_univars env true "definition" exp pat.pat_type vars;
- {exp with exp_type = instance env exp.exp_type}
- | _ -> type_expect exp_env sexp pat.pat_type)
+ {exp with exp_type = instance env exp.exp_type}, true
+ | _ ->
+ type_expect exp_env sexp pat.pat_type,
+ match sexp.pexp_desc with Pexp_ident _ -> true | _ -> false)
spat_sexp_list pat_slot_list in
+ let exp_list, gen_list = List.split exp_gen_list in
current_slot := None;
if is_recursive && not !rec_needed
&& Warnings.is_active Warnings.Unused_rec_flag then
@@ -3399,10 +3402,12 @@
pat_list exp_list;
end_def();
List.iter2
- (fun pat exp ->
- if not (is_nonexpansive exp) then
+ (fun pat (exp, gen) ->
+ if not (global || gen) then
+ iter_pattern (fun pat -> generalize_structure pat.pat_type) pat
+ else if not (is_nonexpansive exp) then
iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat)
- pat_list exp_list;
+ pat_list exp_gen_list;
List.iter
(fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat)
pat_list;
@@ -3413,7 +3418,7 @@
let type_binding env rec_flag spat_sexp_list scope =
Typetexp.reset_type_variables();
let (pat_exp_list, new_env, unpacks) =
- type_let
+ type_let ~global:true
~check:(fun s -> Warnings.Unused_value_declaration s)
~check_strict:(fun s -> Warnings.Unused_value_declaration s)
env rec_flag spat_sexp_list scope false
Index: typing/includecore.ml
===================================================================
--- typing/includecore.ml (revision 14037)
+++ typing/includecore.ml (working copy)
@@ -123,7 +123,8 @@
| Record_representation of bool
let report_type_mismatch0 first second decl ppf err =
- let pr fmt = Format.fprintf ppf fmt in
+ let pr : 'a. ('a, Format.formatter, unit) format -> 'a
+ = fun fmt -> Format.fprintf ppf fmt in
match err with
Arity -> pr "They have different arities"
| Privacy -> pr "A private type would be revealed"
Index: ocamldoc/odoc_html.ml
===================================================================
--- ocamldoc/odoc_html.ml (revision 14037)
+++ ocamldoc/odoc_html.ml (working copy)
@@ -508,7 +508,7 @@
bs b "</table>\n"
method html_of_Index_list b =
- let index_if_not_empty l url m =
+ let index_if_not_empty : 'a. 'a list -> _ = fun l url m ->
match l with
[] -> ()
| _ -> bp b "<li><a href=\"%s\">%s</a></li>\n" url m
@@ -977,7 +977,7 @@
(** A function to build the header of pages. *)
method prepare_header module_list =
let f b ?(nav=None) ?(comments=[]) t =
- let link_if_not_empty l m url =
+ let link_if_not_empty : 'a. 'a list -> _ = fun l m url ->
match l with
[] -> ()
| _ ->
Index: bytecomp/translmod.ml
===================================================================
--- bytecomp/translmod.ml (revision 14037)
+++ bytecomp/translmod.ml (working copy)
@@ -773,7 +773,8 @@
Lprim(Psetglobal target_name, [Lprim(Pmakeblock(0, Immutable), components)])
let transl_store_package component_names target_name coercion =
- let rec make_sequence fn pos arg =
+ let rec make_sequence : 'a. (int -> 'a -> _) -> int -> 'a list -> _ =
+ fun fn pos arg ->
match arg with
[] -> lambda_unit
| hd :: tl -> Lsequence(fn pos hd, make_sequence fn (pos + 1) tl) in
Index: otherlibs/labltk/jpf/jpf_font.ml
===================================================================
--- otherlibs/labltk/jpf/jpf_font.ml (revision 14037)
+++ otherlibs/labltk/jpf/jpf_font.ml (working copy)
@@ -131,7 +131,7 @@
}
let string_of_pattern =
- let pat f = function
+ let pat : 'a. ('a -> string) -> 'a option -> string = fun f -> function
Some x -> f x
| None -> "*"
in
Index: otherlibs/labltk/browser/searchid.ml
===================================================================
--- otherlibs/labltk/browser/searchid.ml (revision 14037)
+++ otherlibs/labltk/browser/searchid.ml (working copy)
@@ -396,7 +396,7 @@
let search_string_symbol text =
if text = "" then [] else
let lid = snd (longident_of_string text) [] in
- let try_lookup f k =
+ let try_lookup : 'a. _ -> 'a -> (_ * 'a) list = fun f k ->
try let _ = f lid Env.initial in [lid, k]
with Not_found | Env.Error _ -> []
in
Index: otherlibs/labltk/browser/setpath.ml
===================================================================
--- otherlibs/labltk/browser/setpath.ml (revision 14037)
+++ otherlibs/labltk/browser/setpath.ml (working copy)
@@ -117,12 +117,12 @@
bind_space_toggle dirbox;
bind_space_toggle pathbox;
- let add_paths _ =
+ let add_paths : 'a. 'a -> unit = fun _ ->
add_to_path pathbox ~base:!current_dir
~dirs:(List.map (Listbox.curselection dirbox)
~f:(fun x -> Listbox.get dirbox ~index:x));
Listbox.selection_clear dirbox ~first:(`Num 0) ~last:`End
- and remove_paths _ =
+ and remove_paths : 'a. 'a -> unit = fun _ ->
remove_path pathbox
~dirs:(List.map (Listbox.curselection pathbox)
~f:(fun x -> Listbox.get pathbox ~index:x))
Index: otherlibs/labltk/browser/viewer.ml
===================================================================
--- otherlibs/labltk/browser/viewer.ml (revision 14037)
+++ otherlibs/labltk/browser/viewer.ml (working copy)
@@ -507,7 +507,8 @@
if i < 3 then Listbox.delete box ~first:(`Num 0) ~last:`End
else destroy fm
done;
- let rec firsts n = function [] -> []
+ let rec firsts : 'a. int -> 'a list -> 'a list = fun n -> function
+ [] -> []
| a :: l -> if n > 0 then a :: firsts (pred n) l else [] in
shown_paths <- firsts (n-1) shown_paths;
boxes <- firsts (max 3 n) boxes
Index: otherlibs/labltk/frx/frx_req.ml
===================================================================
--- otherlibs/labltk/frx/frx_req.ml (revision 14037)
+++ otherlibs/labltk/frx/frx_req.ml (working copy)
@@ -40,7 +40,7 @@
let e =
Entry.create t [Relief Sunken; TextVariable memory; TextWidth len] in
- let activate _ =
+ let activate : 'a. 'a -> unit = fun _ ->
let v = Entry.get e in
Grab.release t; (* because of wm *)
destroy t; (* so action can call open_simple *)
@@ -77,7 +77,7 @@
let waiting = Textvariable.create_temporary t in
- let activate _ =
+ let activate : 'a. 'a -> unit = fun _ ->
Grab.release t; (* because of wm *)
destroy t; (* so action can call open_simple *)
Textvariable.set waiting "1" in
@@ -125,7 +125,7 @@
Listbox.insert lb End elements;
(* activation: we have to break() because we destroy the requester *)
- let activate _ =
+ let activate : 'a. 'a -> unit = fun _ ->
let l = List.map (Listbox.get lb) (Listbox.curselection lb) in
Grab.release t;
destroy t;
Index: otherlibs/labltk/support/rawwidget.ml
===================================================================
--- otherlibs/labltk/support/rawwidget.ml (revision 14037)
+++ otherlibs/labltk/support/rawwidget.ml (working copy)
@@ -67,7 +67,7 @@
(* This one is always created by opentk *)
let default_toplevel =
let wname = "." in
- let w = Typed (wname, "toplevel") in
+ let w : 'a. 'a raw_widget = Typed (wname, "toplevel") in
Hashtbl.add table wname w;
w
@@ -145,7 +145,7 @@
then "." ^ name
else parentpath ^ "." ^ name
in
- let w = Typed(path,clas) in
+ let w :'a. 'a raw_widget = Typed(path,clas) in
Hashtbl.add table path w;
w
Index: ocamlbuild/rule.ml
===================================================================
--- ocamlbuild/rule.ml (revision 14037)
+++ ocamlbuild/rule.ml (working copy)
@@ -260,7 +260,8 @@
which is deprecated and ignored."
name
in
- let res_add import xs xopt =
+ let res_add : 'b. ('a -> 'b) -> 'a list -> 'a option -> 'b list =
+ fun import xs xopt ->
let init =
match xopt with
| None -> []
Index: ocamlbuild/main.ml
===================================================================
--- ocamlbuild/main.ml (revision 14037)
+++ ocamlbuild/main.ml (working copy)
@@ -50,7 +50,7 @@
let show_documentation () =
let rules = Rule.get_rules () in
let flags = Flags.get_flags () in
- let pp fmt = Log.raw_dprintf (-1) fmt in
+ let pp : 'a. ('a,_,_) format -> 'a = fun fmt -> Log.raw_dprintf (-1) fmt in
List.iter begin fun rule ->
pp "%a@\n@\n" (Rule.pretty_print Resource.print_pattern) rule
end rules;

354
experimental/garrigue/objvariant.diff
View File

@ -1,354 +0,0 @@
? objvariants-3.09.1.diffs
? objvariants.diffs
Index: btype.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/btype.ml,v
retrieving revision 1.37.4.1
diff -u -r1.37.4.1 btype.ml
--- btype.ml 5 Dec 2005 13:18:42 -0000 1.37.4.1
+++ btype.ml 16 Jan 2006 02:23:14 -0000
@@ -177,7 +177,8 @@
Tvariant row -> iter_row f row
| Tvar | Tunivar | Tsubst _ | Tconstr _ ->
Misc.may (fun (_,l) -> List.iter f l) row.row_name;
- List.iter f row.row_bound
+ List.iter f row.row_bound;
+ List.iter (fun (s,k,t) -> f t) row.row_object
| _ -> assert false
let iter_type_expr f ty =
@@ -224,7 +225,9 @@
| Some (path, tl) -> Some (path, List.map f tl) in
{ row_fields = fields; row_more = more;
row_bound = !bound; row_fixed = row.row_fixed && fixed;
- row_closed = row.row_closed; row_name = name; }
+ row_closed = row.row_closed; row_name = name;
+ row_object = List.map (fun (s,k,t) -> (s,k,f t)) row.row_object;
+ }
let rec copy_kind = function
Fvar{contents = Some k} -> copy_kind k
Index: ctype.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/ctype.ml,v
retrieving revision 1.197.2.6
diff -u -r1.197.2.6 ctype.ml
--- ctype.ml 15 Dec 2005 02:28:38 -0000 1.197.2.6
+++ ctype.ml 16 Jan 2006 02:23:15 -0000
@@ -1421,7 +1421,7 @@
newgenty
(Tvariant
{row_fields = fields; row_closed = closed; row_more = newvar();
- row_bound = []; row_fixed = false; row_name = None })
+ row_bound = []; row_fixed = false; row_name = None; row_object=[]})
(**** Unification ****)
@@ -1724,8 +1724,11 @@
else None
in
let bound = row1.row_bound @ row2.row_bound in
+ let opairs, _, miss2 = associate_fields row1.row_object row2.row_object in
+ let row_object = row1.row_object @ miss2 in
let row0 = {row_fields = []; row_more = more; row_bound = bound;
- row_closed = closed; row_fixed = fixed; row_name = name} in
+ row_closed = closed; row_fixed = fixed; row_name = name;
+ row_object = row_object } in
let set_more row rest =
let rest =
if closed then
@@ -1758,6 +1761,18 @@
raise (Unify ((mkvariant [l,f1] true,
mkvariant [l,f2] true) :: trace)))
pairs;
+ List.iter (fun (s,_,ty1,_,ty2) -> unify env ty1 ty2) opairs;
+ if row_object <> [] then begin
+ List.iter
+ (fun (l,f) ->
+ match row_field_repr f with
+ Rpresent (Some ty) ->
+ let fi = build_fields generic_level row_object (newgenvar()) in
+ unify env (newgenty (Tobject (fi, ref None))) ty
+ | Rpresent None -> raise (Unify [])
+ | _ -> ())
+ (row_repr row1).row_fields
+ end;
with exn ->
log_type rm1; rm1.desc <- md1; log_type rm2; rm2.desc <- md2; raise exn
end
@@ -2789,7 +2804,8 @@
let row =
{ row_fields = List.map fst fields; row_more = newvar();
row_bound = !bound; row_closed = posi; row_fixed = false;
- row_name = if c > Unchanged then None else row.row_name }
+ row_name = if c > Unchanged then None else row.row_name;
+ row_object = [] }
in
(newty (Tvariant row), Changed)
| Tobject (t1, _) ->
Index: oprint.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/oprint.ml,v
retrieving revision 1.22
diff -u -r1.22 oprint.ml
--- oprint.ml 23 Mar 2005 03:08:37 -0000 1.22
+++ oprint.ml 16 Jan 2006 02:23:15 -0000
@@ -185,7 +185,7 @@
fprintf ppf "@[<2>< %a >@]" (print_fields rest) fields
| Otyp_stuff s -> fprintf ppf "%s" s
| Otyp_var (ng, s) -> fprintf ppf "'%s%s" (if ng then "_" else "") s
- | Otyp_variant (non_gen, row_fields, closed, tags) ->
+ | Otyp_variant (non_gen, row_fields, closed, tags, obj) ->
let print_present ppf =
function
None | Some [] -> ()
@@ -198,12 +198,17 @@
ppf fields
| Ovar_name (id, tyl) ->
fprintf ppf "@[%a%a@]" print_typargs tyl print_ident id
+ and print_object ppf obj =
+ if obj <> [] then
+ fprintf ppf "@ as @[<2>< %a >@]" (print_fields (Some false)) obj
in
- fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a ]@]" (if non_gen then "_" else "")
+ fprintf ppf "%s[%s@[<hv>@[<hv>%a@]%a%a ]@]"
+ (if non_gen then "_" else "")
(if closed then if tags = None then " " else "< "
else if tags = None then "> " else "? ")
print_fields row_fields
print_present tags
+ print_object obj
| Otyp_alias _ | Otyp_poly _ | Otyp_arrow _ | Otyp_tuple _ as ty ->
fprintf ppf "@[<1>(%a)@]" print_out_type ty
| Otyp_abstract | Otyp_sum _ | Otyp_record _ | Otyp_manifest (_, _) -> ()
Index: outcometree.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/outcometree.mli,v
retrieving revision 1.14
diff -u -r1.14 outcometree.mli
--- outcometree.mli 23 Mar 2005 03:08:37 -0000 1.14
+++ outcometree.mli 16 Jan 2006 02:23:15 -0000
@@ -59,6 +59,7 @@
| Otyp_var of bool * string
| Otyp_variant of
bool * out_variant * bool * (string list) option
+ * (string * out_type) list
| Otyp_poly of string list * out_type
and out_variant =
| Ovar_fields of (string * bool * out_type list) list
Index: printtyp.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/printtyp.ml,v
retrieving revision 1.139.2.2
diff -u -r1.139.2.2 printtyp.ml
--- printtyp.ml 7 Dec 2005 23:37:27 -0000 1.139.2.2
+++ printtyp.ml 16 Jan 2006 02:23:15 -0000
@@ -244,7 +244,10 @@
visited_objects := px :: !visited_objects;
match row.row_name with
| Some(p, tyl) when namable_row row ->
- List.iter (mark_loops_rec visited) tyl
+ List.iter (mark_loops_rec visited) tyl;
+ if not (static_row row) then
+ List.iter (fun (s,k,t) -> mark_loops_rec visited t)
+ row.row_object
| _ ->
iter_row (mark_loops_rec visited) {row with row_bound = []}
end
@@ -343,25 +346,27 @@
| _ -> false)
fields in
let all_present = List.length present = List.length fields in
+ let static = row.row_closed && all_present in
+ let obj =
+ if static then [] else
+ List.map (fun (s,k,t) -> (s, tree_of_typexp sch t)) row.row_object
+ in
+ let tags = if all_present then None else Some (List.map fst present) in
begin match row.row_name with
| Some(p, tyl) when namable_row row ->
let id = tree_of_path p in
let args = tree_of_typlist sch tyl in
- if row.row_closed && all_present then
+ if static then
Otyp_constr (id, args)
else
let non_gen = is_non_gen sch px in
- let tags =
- if all_present then None else Some (List.map fst present) in
Otyp_variant (non_gen, Ovar_name(tree_of_path p, args),
- row.row_closed, tags)
+ row.row_closed, tags, obj)
| _ ->
- let non_gen =
- not (row.row_closed && all_present) && is_non_gen sch px in
+ let non_gen = not static && is_non_gen sch px in
let fields = List.map (tree_of_row_field sch) fields in
- let tags =
- if all_present then None else Some (List.map fst present) in
- Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags)
+ Otyp_variant (non_gen, Ovar_fields fields, row.row_closed,
+ tags, obj)
end
| Tobject (fi, nm) ->
tree_of_typobject sch fi nm
Index: typecore.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/typecore.ml,v
retrieving revision 1.176.2.2
diff -u -r1.176.2.2 typecore.ml
--- typecore.ml 11 Dec 2005 09:56:33 -0000 1.176.2.2
+++ typecore.ml 16 Jan 2006 02:23:15 -0000
@@ -170,7 +170,8 @@
(* Force check of well-formedness *)
unify_pat pat.pat_env pat
(newty(Tvariant{row_fields=[]; row_more=newvar(); row_closed=false;
- row_bound=[]; row_fixed=false; row_name=None}));
+ row_bound=[]; row_fixed=false; row_name=None;
+ row_object=[]}));
| _ -> ()
let rec iter_pattern f p =
@@ -251,7 +252,7 @@
let ty = may_map (build_as_type env) p' in
newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar();
row_bound=[]; row_name=None;
- row_fixed=false; row_closed=false})
+ row_fixed=false; row_closed=false; row_object=[]})
| Tpat_record lpl ->
let lbl = fst(List.hd lpl) in
if lbl.lbl_private = Private then p.pat_type else
@@ -318,7 +319,8 @@
([],[]) fields in
let row =
{ row_fields = List.rev fields; row_more = newvar(); row_bound = !bound;
- row_closed = false; row_fixed = false; row_name = Some (path, tyl) }
+ row_closed = false; row_fixed = false; row_name = Some (path, tyl);
+ row_object = [] }
in
let ty = newty (Tvariant row) in
let gloc = {loc with Location.loc_ghost=true} in
@@ -428,7 +430,8 @@
row_closed = false;
row_more = newvar ();
row_fixed = false;
- row_name = None } in
+ row_name = None;
+ row_object = [] } in
rp {
pat_desc = Tpat_variant(l, arg, row);
pat_loc = sp.ppat_loc;
@@ -976,7 +979,8 @@
row_bound = [];
row_closed = false;
row_fixed = false;
- row_name = None});
+ row_name = None;
+ row_object = []});
exp_env = env }
| Pexp_record(lid_sexp_list, opt_sexp) ->
let ty = newvar() in
@@ -1261,8 +1265,30 @@
assert false
end
| _ ->
- (Texp_send(obj, Tmeth_name met),
- filter_method env met Public obj.exp_type)
+ let obj, met_ty =
+ match expand_head env obj.exp_type with
+ {desc = Tvariant _} ->
+ let exp_ty = newvar () in
+ let met_ty = filter_method env met Public exp_ty in
+ let row =
+ {row_fields=[]; row_more=newvar();
+ row_bound=[]; row_closed=false;
+ row_fixed=false; row_name=None;
+ row_object=[met, Fpresent, met_ty]} in
+ unify_exp env obj (newty (Tvariant row));
+ let prim = Primitive.parse_declaration 1 ["%field1"] in
+ let ty = newty(Tarrow("", obj.exp_type, exp_ty, Cok)) in
+ let vd = {val_type = ty; val_kind = Val_prim prim} in
+ let esnd =
+ {exp_desc=Texp_ident(Path.Pident(Ident.create"snd"), vd);
+ exp_loc = Location.none; exp_type = ty; exp_env = env}
+ in
+ ({obj with exp_type = exp_ty;
+ exp_desc = Texp_apply(esnd,[Some obj, Required])},
+ met_ty)
+ | _ -> (obj, filter_method env met Public obj.exp_type)
+ in
+ (Texp_send(obj, Tmeth_name met), met_ty)
in
if !Clflags.principal then begin
end_def ();
Index: types.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/types.ml,v
retrieving revision 1.25
diff -u -r1.25 types.ml
--- types.ml 9 Dec 2004 12:40:53 -0000 1.25
+++ types.ml 16 Jan 2006 02:23:15 -0000
@@ -44,7 +44,9 @@
row_bound: type_expr list;
row_closed: bool;
row_fixed: bool;
- row_name: (Path.t * type_expr list) option }
+ row_name: (Path.t * type_expr list) option;
+ row_object: (string * field_kind * type_expr) list;
+ }
and row_field =
Rpresent of type_expr option
Index: types.mli
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/types.mli,v
retrieving revision 1.25
diff -u -r1.25 types.mli
--- types.mli 9 Dec 2004 12:40:53 -0000 1.25
+++ types.mli 16 Jan 2006 02:23:15 -0000
@@ -43,7 +43,9 @@
row_bound: type_expr list;
row_closed: bool;
row_fixed: bool;
- row_name: (Path.t * type_expr list) option }
+ row_name: (Path.t * type_expr list) option;
+ row_object: (string * field_kind * type_expr) list;
+ }
and row_field =
Rpresent of type_expr option
Index: typetexp.ml
===================================================================
RCS file: /net/yquem/devel/caml/repository/csl/typing/typetexp.ml,v
retrieving revision 1.54
diff -u -r1.54 typetexp.ml
--- typetexp.ml 22 Jul 2005 06:42:36 -0000 1.54
+++ typetexp.ml 16 Jan 2006 02:23:15 -0000
@@ -215,7 +215,8 @@
in
let row = { row_closed = true; row_fields = fields;
row_bound = !bound; row_name = Some (path, args);
- row_fixed = false; row_more = newvar () } in
+ row_fixed = false; row_more = newvar ();
+ row_object = [] } in
let static = Btype.static_row row in
let row =
if static then row else
@@ -262,7 +263,7 @@
let mkfield l f =
newty (Tvariant {row_fields=[l,f]; row_more=newvar();
row_bound=[]; row_closed=true;
- row_fixed=false; row_name=None}) in
+ row_fixed=false; row_name=None; row_object=[]}) in
let add_typed_field loc l f fields =
try
let f' = List.assoc l fields in
@@ -345,7 +346,7 @@
let row =
{ row_fields = List.rev fields; row_more = newvar ();
row_bound = !bound; row_closed = closed;
- row_fixed = false; row_name = !name } in
+ row_fixed = false; row_name = !name; row_object = [] } in
let static = Btype.static_row row in
let row =
if static then row else

42
experimental/garrigue/objvariant.ml
View File

@ -1,42 +0,0 @@
(* use with [cvs update -r objvariants typing] *)
let f (x : [> ]) = x#m 3;;
let o = object method m x = x+2 end;;
f (`A o);;
let l = [`A o; `B(object method m x = x -2 method y = 3 end)];;
List.map f l;;
let g = function `A x -> x#m 3 | `B x -> x#y;;
List.map g l;;
fun x -> ignore (x=f); List.map x l;;
fun (x : [< `A of _ | `B of _] -> int) -> ignore (x=f); List.map x l;;
class cvar name =
object
method name = name
method print ppf = Format.pp_print_string ppf name
end
type var = [`Var of cvar]
class cint n =
object
method n = n
method print ppf = Format.pp_print_int ppf n
end
class ['a] cadd (e1 : 'a) (e2 : 'a) =
object
constraint 'a = [> ]
method e1 = e1
method e2 = e2
method print ppf = Format.fprintf ppf "(%t, %t)" e1#print e2#print
end
type 'a expr = [var | `Int of cint | `Add of 'a cadd]
type expr1 = expr1 expr
let print = Format.printf "%t@."
let e1 : expr1 = `Add (new cadd (`Var (new cvar "x")) (`Int (new cint 2)))

77
experimental/garrigue/parser-lessminus.diff
View File

@ -1,77 +0,0 @@
Index: parsing/parser.mly
===================================================================
--- parsing/parser.mly (revision 11929)
+++ parsing/parser.mly (working copy)
@@ -319,6 +319,11 @@
let polyvars, core_type = varify_constructors newtypes core_type in
(exp, ghtyp(Ptyp_poly(polyvars,core_type)))
+let no_lessminus =
+ List.map (fun (p,e,b) ->
+ match b with None -> (p,e)
+ | Some loc -> raise (Syntaxerr.Error (Syntaxerr.Other loc)))
+
%}
/* Tokens */
@@ -597,8 +602,9 @@
structure_item:
LET rec_flag let_bindings
{ match $3 with
- [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp] -> mkstr(Pstr_eval exp)
- | _ -> mkstr(Pstr_value($2, List.rev $3)) }
+ [{ ppat_desc = Ppat_any; ppat_loc = _ }, exp, None] ->
+ mkstr(Pstr_eval exp)
+ | _ -> mkstr(Pstr_value($2, no_lessminus (List.rev $3))) }
| EXTERNAL val_ident COLON core_type EQUAL primitive_declaration
{ mkstr(Pstr_primitive($2, {pval_type = $4; pval_prim = $6})) }
| TYPE type_declarations
@@ -744,7 +750,7 @@
| class_simple_expr simple_labeled_expr_list
{ mkclass(Pcl_apply($1, List.rev $2)) }
| LET rec_flag let_bindings IN class_expr
- { mkclass(Pcl_let ($2, List.rev $3, $5)) }
+ { mkclass(Pcl_let ($2, no_lessminus (List.rev $3), $5)) }
;
class_simple_expr:
LBRACKET core_type_comma_list RBRACKET class_longident
@@ -981,9 +987,15 @@
| simple_expr simple_labeled_expr_list
{ mkexp(Pexp_apply($1, List.rev $2)) }
| LET rec_flag let_bindings IN seq_expr
- { mkexp(Pexp_let($2, List.rev $3, $5)) }
+ { match $3 with
+ | [pat, expr, Some loc] when $2 = Nonrecursive ->
+ mkexp(Pexp_apply(
+ {pexp_desc = Pexp_ident(Lident "bind"); pexp_loc = loc},
+ ["", expr; "", ghexp(Pexp_function("", None, [pat, $5]))]))
+ | bindings ->
+ mkexp(Pexp_let($2, no_lessminus (List.rev $3), $5)) }
| LET DOT simple_expr let_binding IN seq_expr
- { let (pat, expr) = $4 in
+ { let (pat, expr, _) = $4 in
mkexp(Pexp_apply($3, ["", expr; "", ghexp(Pexp_function("", None, [pat, $6]))])) }
| LET MODULE UIDENT module_binding IN seq_expr
{ mkexp(Pexp_letmodule($3, $4, $6)) }
@@ -1197,14 +1209,17 @@
;
let_binding:
val_ident fun_binding
- { (mkpatvar $1 1, $2) }
+ { (mkpatvar $1 1, $2, None) }
| val_ident COLON typevar_list DOT core_type EQUAL seq_expr
- { (ghpat(Ppat_constraint(mkpatvar $1 1, ghtyp(Ptyp_poly($3,$5)))), $7) }
+ { (ghpat(Ppat_constraint(mkpatvar $1 1, ghtyp(Ptyp_poly($3,$5)))), $7,
+ None) }
| val_ident COLON TYPE lident_list DOT core_type EQUAL seq_expr
{ let exp, poly = wrap_type_annotation $4 $6 $8 in
- (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp) }
+ (ghpat(Ppat_constraint(mkpatvar $1 1, poly)), exp, None) }
| pattern EQUAL seq_expr
- { ($1, $3) }
+ { ($1, $3, None) }
+ | pattern LESSMINUS seq_expr
+ { ($1, $3, Some (rhs_loc 2)) }
;
fun_binding:
strict_binding

467
experimental/garrigue/pattern-local-types.diff
View File

@ -1,467 +0,0 @@
Index: typing/typecore.ml
===================================================================
--- typing/typecore.ml (revision 13003)
+++ typing/typecore.ml (working copy)
@@ -61,6 +61,7 @@
| Not_a_packed_module of type_expr
| Recursive_local_constraint of (type_expr * type_expr) list
| Unexpected_existential
+ | Pattern_newtype_non_closed of string * type_expr
exception Error of Location.t * error
@@ -121,7 +122,7 @@
| Pexp_function (_, eo, pel) ->
may expr eo; List.iter (fun (_, e) -> expr e) pel
| Pexp_apply (e, lel) -> expr e; List.iter (fun (_, e) -> expr e) lel
- | Pexp_let (_, pel, e)
+ | Pexp_let (_, pel, e) -> expr e; List.iter (fun (_, e) -> expr e) pel
| Pexp_match (e, pel)
| Pexp_try (e, pel) -> expr e; List.iter (fun (_, e) -> expr e) pel
| Pexp_array el
@@ -1454,7 +1455,7 @@
let duplicate_ident_types loc caselist env =
let caselist =
- List.filter (fun (pat, _) -> contains_gadt env pat) caselist in
+ List.filter (fun ((_,pat), _) -> contains_gadt env pat) caselist in
let idents = all_idents (List.map snd caselist) in
List.fold_left
(fun env s ->
@@ -1552,7 +1553,7 @@
exp_env = env }
| Pexp_let(Nonrecursive, [spat, sval], sbody) when contains_gadt env spat ->
type_expect ?in_function env
- {sexp with pexp_desc = Pexp_match (sval, [spat, sbody])}
+ {sexp with pexp_desc = Pexp_match (sval, [([],spat), sbody])}
ty_expected
| Pexp_let(rec_flag, spat_sexp_list, sbody) ->
let scp =
@@ -1572,20 +1573,21 @@
exp_env = env }
| Pexp_function (l, Some default, [spat, sbody]) ->
let default_loc = default.pexp_loc in
- let scases = [
+ let scases = [([],
{ppat_loc = default_loc;
ppat_desc =
Ppat_construct
(mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))),
Some {ppat_loc = default_loc;
ppat_desc = Ppat_var (mknoloc "*sth*")},
- false)},
+ false)}),
{pexp_loc = default_loc;
pexp_desc = Pexp_ident(mknoloc (Longident.Lident "*sth*"))};
+ ([],
{ppat_loc = default_loc;
ppat_desc = Ppat_construct
(mknoloc (Longident.(Ldot (Lident "*predef*", "None"))),
- None, false)},
+ None, false)}),
default;
] in
let smatch = {
@@ -1603,10 +1605,10 @@
pexp_desc =
Pexp_function (
l, None,
- [ {ppat_loc = loc;
- ppat_desc = Ppat_var (mknoloc "*opt*")},
+ [ ([], {ppat_loc = loc;
+ ppat_desc = Ppat_var (mknoloc "*opt*")}),
{pexp_loc = loc;
- pexp_desc = Pexp_let(Default, [spat, smatch], sbody);
+ pexp_desc = Pexp_let(Default, [snd spat, smatch], sbody);
}
]
)
@@ -2733,10 +2735,10 @@
and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
(* ty_arg is _fully_ generalized *)
let dont_propagate, has_gadts =
- let patterns = List.map fst caselist in
+ let patterns = List.map (fun ((_,p),_) -> p) caselist in
List.exists contains_polymorphic_variant patterns,
- List.exists (contains_gadt env) patterns in
-(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
+ List.exists (contains_gadt env) patterns ||
+ List.exists (fun ((l,_),_) -> l <> []) caselist in
let ty_arg, ty_res, env =
if has_gadts && not !Clflags.principal then
correct_levels ty_arg, correct_levels ty_res,
@@ -2761,9 +2763,21 @@
Printtyp.raw_type_expr ty_arg; *)
let pat_env_list =
List.map
- (fun (spat, sexp) ->
+ (fun ((stypes,spat), sexp) ->
let loc = sexp.pexp_loc in
if !Clflags.principal then begin_def (); (* propagation of pattern *)
+ (* For local types *)
+ if stypes <> [] then begin_def ();
+ let lev' = get_current_level () in
+ let types = List.map (fun name -> name, newvar ~name ()) stypes in
+ let env =
+ List.fold_left (fun env (name, manifest) ->
+ (* "Vanishing" definition *)
+ let decl = new_declaration ~manifest (lev',lev') in
+ snd (Env.enter_type name decl env))
+ env types
+ in
+ (* Type the pattern itself *)
let scope = Some (Annot.Idef loc) in
let (pat, ext_env, force, unpacks) =
let partial =
@@ -2773,14 +2787,42 @@
in type_pattern ~lev env spat scope ty_arg
in
pattern_force := force @ !pattern_force;
+ (* For local types *)
+ let ext_env =
+ List.fold_left (fun env (name, ty) ->
+ let ty = expand_head env ty in
+ match ty.desc with
+ Tconstr ((Path.Pident id as p), [], _) when
+ let decl = Env.find_type p env in
+ decl.type_newtype_level = Some (lev, lev) &&
+ decl.type_kind = Type_abstract ->
+ let (id', env) =
+ Env.enter_type name (new_declaration (lev, lev)) env in
+ let manifest = newconstr (Path.Pident id') [] in
+ (* Make previous existential "vanish" *)
+ Env.add_type id (new_declaration ~manifest (lev',lev')) env
+ | _ ->
+ if free_variables ty <> [] then
+ raise (Error (spat.ppat_loc,
+ Pattern_newtype_non_closed (name,ty)));
+ let manifest = correct_levels ty in
+ let decl = new_declaration ~manifest (lev, lev) in
+ snd (Env.enter_type name decl env))
+ ext_env types
+ in
+ if stypes <> [] then begin
+ end_def ();
+ iter_pattern (fun p -> unify_pat ext_env p (newvar())) pat;
+ end;
+ (* Principality *)
let pat =
if !Clflags.principal then begin
end_def ();
iter_pattern (fun {pat_type=t} -> generalize_structure t) pat;
- { pat with pat_type = instance env pat.pat_type }
+ { pat with pat_type = instance ext_env pat.pat_type }
end else pat
in
- unify_pat env pat ty_arg';
+ unify_pat ext_env pat ty_arg';
(pat, (ext_env, unpacks)))
caselist in
(* Check for polymorphic variants to close *)
@@ -2802,7 +2844,7 @@
let in_function = if List.length caselist = 1 then in_function else None in
let cases =
List.map2
- (fun (pat, (ext_env, unpacks)) (spat, sexp) ->
+ (fun (pat, (ext_env, unpacks)) ((stypes,spat), sexp) ->
let sexp = wrap_unpacks sexp unpacks in
let ty_res' =
if !Clflags.principal then begin
@@ -2811,8 +2853,8 @@
end_def ();
generalize_structure ty; ty
end
- else if contains_gadt env spat then correct_levels ty_res
- else ty_res in
+ else if contains_gadt env spat || stypes <> []
+ then correct_levels ty_res else ty_res in
(* Format.printf "@[%i %i, ty_res' =@ %a@]@." lev (get_current_level())
Printtyp.raw_type_expr ty_res'; *)
let exp = type_expect ?in_function ext_env sexp ty_res' in
@@ -3218,6 +3260,11 @@
| Unexpected_existential ->
fprintf ppf
"Unexpected existential"
+ | Pattern_newtype_non_closed (name, ty) ->
+ reset_and_mark_loops ty;
+ fprintf ppf
+ "@[In this pattern, local type %s has been inferred as@ %a@ %s@]"
+ name type_expr ty "It should not contain variables."
let () =
Env.add_delayed_check_forward := add_delayed_check
Index: typing/ctype.mli
===================================================================
--- typing/ctype.mli (revision 13003)
+++ typing/ctype.mli (working copy)
@@ -140,6 +140,9 @@
the parameters [pi] and returns the corresponding instance of
[t]. Exception [Cannot_apply] is raised in case of failure. *)
+val new_declaration:
+ ?manifest:type_expr -> ?loc:Location.t -> (int * int) -> type_declaration
+
val expand_head_once: Env.t -> type_expr -> type_expr
val expand_head: Env.t -> type_expr -> type_expr
val try_expand_once_opt: Env.t -> type_expr -> type_expr
Index: typing/typeclass.ml
===================================================================
--- typing/typeclass.ml (revision 13003)
+++ typing/typeclass.ml (working copy)
@@ -347,8 +347,8 @@
let mkid s = mkloc s self_loc in
{ pexp_desc =
Pexp_function ("", None,
- [mkpat (Ppat_alias (mkpat (Ppat_var (mkid "self-*")),
- mkid ("self-" ^ cl_num))),
+ [([],mkpat (Ppat_alias (mkpat (Ppat_var (mkid "self-*")),
+ mkid ("self-" ^ cl_num)))),
expr]);
pexp_loc = expr.pexp_loc }
@@ -836,15 +836,15 @@
| Pcl_fun (l, Some default, spat, sbody) ->
let loc = default.pexp_loc in
let scases =
- [{ppat_loc = loc; ppat_desc = Ppat_construct (
+ [([], {ppat_loc = loc; ppat_desc = Ppat_construct (
mknoloc (Longident.(Ldot (Lident"*predef*", "Some"))),
Some{ppat_loc = loc; ppat_desc = Ppat_var (mknoloc "*sth*")},
- false)},
+ false)}),
{pexp_loc = loc; pexp_desc =
Pexp_ident(mknoloc (Longident.Lident"*sth*"))};
- {ppat_loc = loc; ppat_desc =
+ ([], {ppat_loc = loc; ppat_desc =
Ppat_construct(mknoloc (Longident.(Ldot (Lident"*predef*", "None"))),
- None, false)},
+ None, false)}),
default] in
let smatch =
{pexp_loc = loc; pexp_desc =
Index: typing/ctype.ml
===================================================================
--- typing/ctype.ml (revision 13003)
+++ typing/ctype.ml (working copy)
@@ -696,6 +696,7 @@
Path.binding_time p
let rec update_level env level ty =
+ (* Format.eprintf "update_level %d %a@." level !Btype.print_raw ty; *)
let ty = repr ty in
if ty.level > level then begin
if Env.has_local_constraints env then begin
@@ -1043,7 +1044,7 @@
reified_var_counter := Vars.add s index !reified_var_counter;
Printf.sprintf "%s#%d" s index
-let new_declaration newtype manifest =
+let new_declaration ?manifest ?(loc=Location.none) newtype =
{
type_params = [];
type_arity = 0;
@@ -1051,7 +1052,7 @@
type_private = Public;
type_manifest = manifest;
type_variance = [];
- type_newtype_level = newtype;
+ type_newtype_level = Some newtype;
type_loc = Location.none;
}
@@ -1060,7 +1061,7 @@
| None -> ()
| Some (env, newtype_lev) ->
let process existential =
- let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in
+ let decl = new_declaration (newtype_lev, newtype_lev) in
let name =
match repr existential with
{desc = Tvar (Some name)} -> name
@@ -1808,7 +1809,7 @@
let reify env t =
let newtype_level = get_newtype_level () in
let create_fresh_constr lev name =
- let decl = new_declaration (Some (newtype_level, newtype_level)) None in
+ let decl = new_declaration (newtype_level, newtype_level) in
let name = get_new_abstract_name name in
let (id, new_env) = Env.enter_type name decl !env in
let t = newty2 lev (Tconstr (Path.Pident id,[],ref Mnil)) in
@@ -2039,7 +2040,7 @@
let add_gadt_equation env source destination =
let destination = duplicate_type destination in
let source_lev = find_newtype_level !env (Path.Pident source) in
- let decl = new_declaration (Some source_lev) (Some destination) in
+ let decl = new_declaration ~manifest:destination source_lev in
let newtype_level = get_newtype_level () in
env := Env.add_local_constraint source decl newtype_level !env;
cleanup_abbrev ()
Index: typing/typecore.mli
===================================================================
--- typing/typecore.mli (revision 13003)
+++ typing/typecore.mli (working copy)
@@ -103,6 +103,7 @@
| Not_a_packed_module of type_expr
| Recursive_local_constraint of (type_expr * type_expr) list
| Unexpected_existential
+ | Pattern_newtype_non_closed of string * type_expr
exception Error of Location.t * error
Index: testsuite/tests/typing-gadts/test.ml.reference
===================================================================
--- testsuite/tests/typing-gadts/test.ml.reference (revision 13003)
+++ testsuite/tests/typing-gadts/test.ml.reference (working copy)
@@ -293,4 +293,18 @@
# type 'a ty = Int : int -> int ty
# val f : 'a ty -> 'a = <fun>
# val g : 'a ty -> 'a = <fun>
+# - : unit -> unit list = <fun>
+# - : unit list = []
+# Characters 17-19:
+ function type a. () -> ();; (* fail *)
+ ^^
+Error: In this pattern, local type a has been inferred as 'a
+ It should not contain variables.
+# type t = D : 'a * ('a -> int) -> t
+# val f : t -> int = <fun>
+# Characters 42-43:
+ let f = function type b. D ((x:b), f) -> (f:t->int) x;; (* fail *)
+ ^
+Error: This expression has type b -> int
+ but an expression was expected of type t -> int
#
Index: testsuite/tests/typing-gadts/test.ml
===================================================================
--- testsuite/tests/typing-gadts/test.ml (revision 13003)
+++ testsuite/tests/typing-gadts/test.ml (working copy)
@@ -512,3 +512,15 @@
let g : type a. a ty -> a =
let () = () in
fun x -> match x with Int y -> y;;
+
+(* Implicit type declarations in patterns *)
+
+(* alias *)
+function type a. (() : a) -> ([] : a list);;
+(function type a. (() : a) -> ([] : a list)) ();;
+function type a. () -> ();; (* fail *)
+
+(* existential *)
+type t = D : 'a * ('a -> int) -> t;;
+let f = function type b. D ((x:b), f) -> (f:b->int) x;;
+let f = function type b. D ((x:b), f) -> (f:t->int) x;; (* fail *)
Index: testsuite/tests/typing-gadts/test.ml.principal.reference
===================================================================
--- testsuite/tests/typing-gadts/test.ml.principal.reference (revision 13003)
+++ testsuite/tests/typing-gadts/test.ml.principal.reference (working copy)
@@ -306,4 +306,18 @@
# type 'a ty = Int : int -> int ty
# val f : 'a ty -> 'a = <fun>
# val g : 'a ty -> 'a = <fun>
+# - : unit -> unit list = <fun>
+# - : unit list = []
+# Characters 17-19:
+ function type a. () -> ();; (* fail *)
+ ^^
+Error: In this pattern, local type a has been inferred as 'a
+ It should not contain variables.
+# type t = D : 'a * ('a -> int) -> t
+# val f : t -> int = <fun>
+# Characters 42-43:
+ let f = function type b. D ((x:b), f) -> (f:t->int) x;; (* fail *)
+ ^
+Error: This expression has type b -> int
+ but an expression was expected of type t -> int
#
Index: parsing/parser.mly
===================================================================
--- parsing/parser.mly (revision 13003)
+++ parsing/parser.mly (working copy)
@@ -967,7 +967,7 @@
| FUNCTION opt_bar match_cases
{ mkexp(Pexp_function("", None, List.rev $3)) }
| FUN labeled_simple_pattern fun_def
- { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [p, $3])) }
+ { let (l,o,p) = $2 in mkexp(Pexp_function(l, o, [([],p), $3])) }
| FUN LPAREN TYPE LIDENT RPAREN fun_def
{ mkexp(Pexp_newtype($4, $6)) }
| MATCH seq_expr WITH opt_bar match_cases
@@ -1187,18 +1187,18 @@
EQUAL seq_expr
{ $2 }
| labeled_simple_pattern fun_binding
- { let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
+ { let (l, o, p) = $1 in ghexp(Pexp_function(l, o, [([],p), $2])) }
| LPAREN TYPE LIDENT RPAREN fun_binding
{ mkexp(Pexp_newtype($3, $5)) }
;
match_cases:
- pattern match_action { [$1, $2] }
- | match_cases BAR pattern match_action { ($3, $4) :: $1 }
+ match_pattern match_action { [$1, $2] }
+ | match_cases BAR match_pattern match_action { ($3, $4) :: $1 }
;
fun_def:
match_action { $1 }
| labeled_simple_pattern fun_def
- { let (l,o,p) = $1 in ghexp(Pexp_function(l, o, [p, $2])) }
+ { let (l,o,p) = $1 in ghexp(Pexp_function(l, o, [([],p), $2])) }
| LPAREN TYPE LIDENT RPAREN fun_def
{ mkexp(Pexp_newtype($3, $5)) }
;
@@ -1245,6 +1245,10 @@
/* Patterns */
+match_pattern:
+ pattern { [], $1 }
+ | TYPE lident_list DOT pattern { $2, $4 }
+;
pattern:
simple_pattern
{ $1 }
Index: parsing/parsetree.mli
===================================================================
--- parsing/parsetree.mli (revision 13003)
+++ parsing/parsetree.mli (working copy)
@@ -90,10 +90,11 @@
Pexp_ident of Longident.t loc
| Pexp_constant of constant
| Pexp_let of rec_flag * (pattern * expression) list * expression
- | Pexp_function of label * expression option * (pattern * expression) list
+ | Pexp_function of
+ label * expression option * ((string list * pattern) * expression) list
| Pexp_apply of expression * (label * expression) list
- | Pexp_match of expression * (pattern * expression) list
- | Pexp_try of expression * (pattern * expression) list
+ | Pexp_match of expression * ((string list * pattern) * expression) list
+ | Pexp_try of expression * ((string list * pattern) * expression) list
| Pexp_tuple of expression list
| Pexp_construct of Longident.t loc * expression option * bool
| Pexp_variant of label * expression option
@@ -104,7 +105,8 @@
| Pexp_ifthenelse of expression * expression * expression option
| Pexp_sequence of expression * expression
| Pexp_while of expression * expression
- | Pexp_for of string loc * expression * expression * direction_flag * expression
+ | Pexp_for of
+ string loc * expression * expression * direction_flag * expression
| Pexp_constraint of expression * core_type option * core_type option
| Pexp_when of expression * expression
| Pexp_send of expression * string
Index: parsing/printast.ml
===================================================================
--- parsing/printast.ml (revision 13003)
+++ parsing/printast.ml (working copy)
@@ -686,8 +686,9 @@
line i ppf "%a\n" fmt_longident li;
pattern (i+1) ppf p;
-and pattern_x_expression_case i ppf (p, e) =
+and pattern_x_expression_case i ppf ((l,p), e) =
line i ppf "<case>\n";
+ list (i+1) string ppf l;
pattern (i+1) ppf p;
expression (i+1) ppf e;

11
experimental/garrigue/printers.ml
View File

@ -1,11 +0,0 @@
(* $Id$ *)
open Types
let ignore_abbrevs ppf ab =
let s = match ab with
Mnil -> "Mnil"
| Mlink _ -> "Mlink _"
| Mcons _ -> "Mcons _"
in
Format.pp_print_string ppf s

212
experimental/garrigue/propagation-to-patterns.diff
View File

@ -1,212 +0,0 @@
Index: Changes
===================================================================
--- Changes (revision 13157)
+++ Changes (working copy)
@@ -1,6 +1,11 @@
Next version
------------
+Type system:
+- Propagate type information towards pattern-matching, even in the presence
+ of polymorphic variants (discarding only information about possibly-present
+ constructors)
+
Compilers:
- PR#5861: raise an error when multiple private keywords are used in type declarations
- PR#5634: parsetree rewriter (-ppx flag)
Index: typing/typecore.ml
===================================================================
--- typing/typecore.ml (revision 13157)
+++ typing/typecore.ml (working copy)
@@ -326,7 +326,7 @@
| _ -> assert false
in
begin match row_field tag row with
- | Rabsent -> assert false
+ | Rabsent -> () (* assert false *)
| Reither (true, [], _, e) when not row.row_closed ->
set_row_field e (Rpresent None)
| Reither (false, ty::tl, _, e) when not row.row_closed ->
@@ -1657,6 +1657,28 @@
sexp unpacks
(* Helpers for type_cases *)
+
+let contains_variant_either ty =
+ let rec loop ty =
+ let ty = repr ty in
+ if ty.level >= lowest_level then begin
+ mark_type_node ty;
+ match ty.desc with
+ Tvariant row ->
+ let row = row_repr row in
+ if not row.row_fixed then
+ List.iter
+ (fun (_,f) ->
+ match row_field_repr f with Reither _ -> raise Exit | _ -> ())
+ row.row_fields;
+ iter_row loop row
+ | _ ->
+ iter_type_expr loop ty
+ end
+ in
+ try loop ty; unmark_type ty; false
+ with Exit -> unmark_type ty; true
+
let iter_ppat f p =
match p.ppat_desc with
| Ppat_any | Ppat_var _ | Ppat_constant _
@@ -1690,6 +1712,24 @@
in
try loop p; false with Exit -> true
+let check_absent_variant env =
+ iter_pattern
+ (function {pat_desc = Tpat_variant (s, arg, row)} as pat ->
+ let row = row_repr !row in
+ if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent)
+ row.row_fields
+ then () else
+ let ty_arg =
+ match arg with None -> [] | Some p -> [correct_levels p.pat_type] in
+ let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)];
+ row_more = newvar (); row_bound = ();
+ row_closed = false; row_fixed = false; row_name = None} in
+ (* Should fail *)
+ unify_pat env {pat with pat_type = newty (Tvariant row')}
+ (correct_levels pat.pat_type)
+ | _ -> ())
+
+
let dummy_expr = {pexp_desc = Pexp_tuple []; pexp_loc = Location.none}
(* Duplicate types of values in the environment *)
@@ -3037,16 +3077,20 @@
and type_cases ?in_function env ty_arg ty_res partial_flag loc caselist =
(* ty_arg is _fully_ generalized *)
- let dont_propagate, has_gadts =
- let patterns = List.map fst caselist in
- List.exists contains_polymorphic_variant patterns,
- List.exists (contains_gadt env) patterns in
+ let patterns = List.map fst caselist in
+ let erase_either =
+ List.exists contains_polymorphic_variant patterns
+ && contains_variant_either ty_arg
+ and has_gadts = List.exists (contains_gadt env) patterns in
(* prerr_endline ( if has_gadts then "contains gadt" else "no gadt"); *)
- let ty_arg, ty_res, env =
+ let ty_arg =
+ if (has_gadts || erase_either) && not !Clflags.principal
+ then correct_levels ty_arg else ty_arg
+ and ty_res, env =
if has_gadts && not !Clflags.principal then
- correct_levels ty_arg, correct_levels ty_res,
- duplicate_ident_types loc caselist env
- else ty_arg, ty_res, env in
+ correct_levels ty_res, duplicate_ident_types loc caselist env
+ else ty_res, env
+ in
let lev, env =
if has_gadts then begin
(* raise level for existentials *)
@@ -3072,10 +3116,10 @@
let scope = Some (Annot.Idef loc) in
let (pat, ext_env, force, unpacks) =
let partial =
- if !Clflags.principal then Some false else None in
- let ty_arg =
- if dont_propagate then newvar () else instance ?partial env ty_arg
- in type_pattern ~lev env spat scope ty_arg
+ if !Clflags.principal || erase_either
+ then Some false else None in
+ let ty_arg = instance ?partial env ty_arg in
+ type_pattern ~lev env spat scope ty_arg
in
pattern_force := force @ !pattern_force;
let pat =
@@ -3134,7 +3178,11 @@
else
Partial
in
- add_delayed_check (fun () -> Parmatch.check_unused env cases);
+ add_delayed_check
+ (fun () ->
+ List.iter (fun (pat, (env, _)) -> check_absent_variant env pat)
+ pat_env_list;
+ Parmatch.check_unused env cases);
if has_gadts then begin
end_def ();
(* Ensure that existential types do not escape *)
Index: typing/ctype.ml
===================================================================
--- typing/ctype.ml (revision 13157)
+++ typing/ctype.ml (working copy)
@@ -981,6 +981,25 @@
if keep then more else newty more.desc
| _ -> assert false
in
+ (* Open row if partial for pattern and contains Reither *)
+ let more', row =
+ match partial with
+ Some (free_univars, false) when row.row_closed
+ && not row.row_fixed && TypeSet.is_empty (free_univars ty) ->
+ let not_reither (_, f) =
+ match row_field_repr f with
+ Reither _ -> false
+ | _ -> true
+ in
+ if List.for_all not_reither row.row_fields
+ then (more', row) else
+ (newty2 (if keep then more.level else !current_level)
+ (Tvar None),
+ {row_fields = List.filter not_reither row.row_fields;
+ row_more = more; row_bound = ();
+ row_closed = false; row_fixed = false; row_name = None})
+ | _ -> (more', row)
+ in
(* Register new type first for recursion *)
more.desc <- Tsubst(newgenty(Ttuple[more';t]));
(* Return a new copy *)
Index: testsuite/tests/typing-gadts/test.ml.reference
===================================================================
--- testsuite/tests/typing-gadts/test.ml.reference (revision 13157)
+++ testsuite/tests/typing-gadts/test.ml.reference (working copy)
@@ -62,11 +62,11 @@
^^^^^^^^
Error: This pattern matches values of type int t
but a pattern was expected which matches values of type s t
-# Characters 224-237:
- | `A, BoolLit _ -> ()
- ^^^^^^^^^^^^^
-Error: This pattern matches values of type ([? `A ] as 'a) * bool t
- but a pattern was expected which matches values of type 'a * int t
+# module Polymorphic_variants :
+ sig
+ type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+ val eval : [ `A ] * 's t -> unit
+ end
# module Propagation :
sig
type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
Index: testsuite/tests/typing-gadts/test.ml.principal.reference
===================================================================
--- testsuite/tests/typing-gadts/test.ml.principal.reference (revision 13157)
+++ testsuite/tests/typing-gadts/test.ml.principal.reference (working copy)
@@ -62,11 +62,11 @@
^^^^^^^^
Error: This pattern matches values of type int t
but a pattern was expected which matches values of type s t
-# Characters 224-237:
- | `A, BoolLit _ -> ()
- ^^^^^^^^^^^^^
-Error: This pattern matches values of type ([? `A ] as 'a) * bool t
- but a pattern was expected which matches values of type 'a * int t
+# module Polymorphic_variants :
+ sig
+ type _ t = IntLit : int -> int t | BoolLit : bool -> bool t
+ val eval : [ `A ] * 's t -> unit
+ end
# Characters 299-300:
| BoolLit b -> b
^

419
experimental/garrigue/show_types.diff
View File

@ -1,419 +0,0 @@
Index: parsing/printast.mli
===================================================================
--- parsing/printast.mli (revision 13955)
+++ parsing/printast.mli (working copy)
@@ -16,3 +16,4 @@
val interface : formatter -> signature_item list -> unit;;
val implementation : formatter -> structure_item list -> unit;;
val top_phrase : formatter -> toplevel_phrase -> unit;;
+val string_of_kind : ident_kind -> string;;
Index: parsing/pprintast.ml
===================================================================
--- parsing/pprintast.ml (revision 13955)
+++ parsing/pprintast.ml (working copy)
@@ -1192,8 +1192,10 @@
| Pdir_none -> ()
| Pdir_string (s) -> pp f "@ %S" s
| Pdir_int (i) -> pp f "@ %d" i
- | Pdir_ident (li) -> pp f "@ %a" self#longident li
- | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b))
+ | Pdir_ident {txt=li} -> pp f "@ %a" self#longident li
+ | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b)
+ | Pdir_show (k, {txt=li}) ->
+ pp f "@ %s %a" (Printast.string_of_kind k) self#longident li)
method toplevel_phrase f x =
match x with
Index: parsing/parser.mly
===================================================================
--- parsing/parser.mly (revision 13955)
+++ parsing/parser.mly (working copy)
@@ -516,9 +516,9 @@
| SEMISEMI EOF { [] }
| SEMISEMI seq_expr use_file_tail { Ptop_def[mkstrexp $2] :: $3 }
| SEMISEMI structure_item use_file_tail { Ptop_def[$2] :: $3 }
- | SEMISEMI toplevel_directive use_file_tail { $2 :: $3 }
| structure_item use_file_tail { Ptop_def[$1] :: $2 }
- | toplevel_directive use_file_tail { $1 :: $2 }
+ | SEMISEMI toplevel_directive SEMISEMI use_file_tail { $2 :: $4 }
+ | toplevel_directive SEMISEMI use_file_tail { $1 :: $3 }
;
/* Module expressions */
@@ -1779,16 +1779,26 @@
| FALSE { Lident "false" }
| TRUE { Lident "true" }
;
+ident_kind:
+ VAL { Pkind_val }
+ | TYPE { Pkind_type }
+ | EXCEPTION { Pkind_exception }
+ | MODULE { Pkind_module }
+ | MODULE TYPE { Pkind_modtype }
+ | CLASS { Pkind_class }
+ | CLASS TYPE { Pkind_cltype }
+;
/* Toplevel directives */
toplevel_directive:
- HASH ident { Ptop_dir($2, Pdir_none) }
- | HASH ident STRING { Ptop_dir($2, Pdir_string $3) }
- | HASH ident INT { Ptop_dir($2, Pdir_int $3) }
- | HASH ident val_longident { Ptop_dir($2, Pdir_ident $3) }
- | HASH ident FALSE { Ptop_dir($2, Pdir_bool false) }
- | HASH ident TRUE { Ptop_dir($2, Pdir_bool true) }
+ HASH ident { Ptop_dir($2, Pdir_none) }
+ | HASH ident STRING { Ptop_dir($2, Pdir_string $3) }
+ | HASH ident INT { Ptop_dir($2, Pdir_int $3) }
+ | HASH ident val_longident { Ptop_dir($2, Pdir_ident (mkrhs $3 3)) }
+ | HASH ident ident_kind any_longident { Ptop_dir($2, Pdir_show ($3, mkrhs $4 4)) }
+ | HASH ident FALSE { Ptop_dir($2, Pdir_bool false) }
+ | HASH ident TRUE { Ptop_dir($2, Pdir_bool true) }
;
/* Miscellaneous */
Index: parsing/parsetree.mli
===================================================================
--- parsing/parsetree.mli (revision 13955)
+++ parsing/parsetree.mli (working copy)
@@ -294,6 +294,15 @@
(* Toplevel phrases *)
+type ident_kind =
+ Pkind_val
+ | Pkind_type
+ | Pkind_exception
+ | Pkind_module
+ | Pkind_modtype
+ | Pkind_class
+ | Pkind_cltype
+
type toplevel_phrase =
Ptop_def of structure
| Ptop_dir of string * directive_argument
@@ -302,5 +311,6 @@
Pdir_none
| Pdir_string of string
| Pdir_int of int
- | Pdir_ident of Longident.t
+ | Pdir_ident of Longident.t Location.loc
+ | Pdir_show of ident_kind * Longident.t Location.loc
| Pdir_bool of bool
Index: parsing/printast.ml
===================================================================
--- parsing/printast.ml (revision 13955)
+++ parsing/printast.ml (working copy)
@@ -737,6 +737,16 @@
core_type (i+1) ppf ct
;;
+let string_of_kind = function
+ Pkind_val -> "val"
+ | Pkind_type -> "type"
+ | Pkind_exception -> "exception"
+ | Pkind_module -> "module"
+ | Pkind_modtype -> "module type"
+ | Pkind_class -> "class"
+ | Pkind_cltype -> "class type"
+;;
+
let rec toplevel_phrase i ppf x =
match x with
| Ptop_def (s) ->
@@ -751,7 +761,9 @@
| Pdir_none -> line i ppf "Pdir_none\n"
| Pdir_string (s) -> line i ppf "Pdir_string \"%s\"\n" s;
| Pdir_int (i) -> line i ppf "Pdir_int %d\n" i;
- | Pdir_ident (li) -> line i ppf "Pdir_ident %a\n" fmt_longident li;
+ | Pdir_ident {txt=li} -> line i ppf "Pdir_ident %a\n" fmt_longident li;
+ | Pdir_show (kind,{txt=li}) ->
+ line i ppf "Pdir_show %s %a\n" (string_of_kind kind) fmt_longident li;
| Pdir_bool (b) -> line i ppf "Pdir_bool %s\n" (string_of_bool b);
;;
Index: toplevel/opttoploop.ml
===================================================================
--- toplevel/opttoploop.ml (revision 13955)
+++ toplevel/opttoploop.ml (working copy)
@@ -53,6 +53,7 @@
| Directive_string of (string -> unit)
| Directive_int of (int -> unit)
| Directive_ident of (Longident.t -> unit)
+ | Directive_show of (ident_kind -> Longident.t -> unit)
| Directive_bool of (bool -> unit)
@@ -270,6 +271,7 @@
| (Directive_string f, Pdir_string s) -> f s; true
| (Directive_int f, Pdir_int n) -> f n; true
| (Directive_ident f, Pdir_ident lid) -> f lid; true
+ | (Directive_show f, Pdir_show (kind,lid)) -> f kind lid; true
| (Directive_bool f, Pdir_bool b) -> f b; true
| (_, _) ->
fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name;
Index: toplevel/topdirs.ml
===================================================================
--- toplevel/topdirs.ml (revision 13955)
+++ toplevel/topdirs.ml (working copy)
@@ -15,6 +15,7 @@
open Format
open Misc
open Longident
+open Parsetree
open Types
open Cmo_format
open Trace
@@ -191,9 +192,9 @@
Ctype.generalize ty_arg;
ty_arg
-let find_printer_type ppf lid =
+let find_printer_type ppf {Location.loc; txt=lid} =
try
- let (path, desc) = Env.lookup_value lid !toplevel_env in
+ let (path, desc) = Typetexp.find_value !toplevel_env loc lid in
let (ty_arg, is_old_style) =
try
(match_printer_type ppf desc "printer_type_new", false)
@@ -201,12 +202,12 @@
(match_printer_type ppf desc "printer_type_old", true) in
(ty_arg, path, is_old_style)
with
- | Not_found ->
- fprintf ppf "Unbound value %a.@." Printtyp.longident lid;
+ Typetexp.Error _ as exn ->
+ Errors.report_error ppf exn;
raise Exit
| Ctype.Unify _ ->
fprintf ppf "%a has a wrong type for a printing function.@."
- Printtyp.longident lid;
+ Printtyp.longident lid;
raise Exit
let dir_install_printer ppf lid =
@@ -227,7 +228,7 @@
begin try
remove_printer path
with Not_found ->
- fprintf ppf "No printer named %a.@." Printtyp.longident lid
+ fprintf ppf "No printer named %a.@." Printtyp.longident lid.Location.txt
end
with Exit -> ()
@@ -244,9 +245,9 @@
get_code_pointer
(Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg))
-let dir_trace ppf lid =
+let dir_trace ppf {Location.loc; txt=lid} =
try
- let (path, desc) = Env.lookup_value lid !toplevel_env in
+ let (path, desc) = Typetexp.find_value !toplevel_env loc lid in
(* Check if this is a primitive *)
match desc.val_kind with
| Val_prim p ->
@@ -278,11 +279,11 @@
fprintf ppf "%a is now traced.@." Printtyp.longident lid
end else fprintf ppf "%a is not a function.@." Printtyp.longident lid
with
- | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid
+ Typetexp.Error _ as exn -> Errors.report_error ppf exn
-let dir_untrace ppf lid =
+let dir_untrace ppf {Location.loc; txt=lid} =
try
- let (path, desc) = Env.lookup_value lid !toplevel_env in
+ let (path, desc) = Typetexp.find_value !toplevel_env loc lid in
let rec remove = function
| [] ->
fprintf ppf "%a was not traced.@." Printtyp.longident lid;
@@ -295,7 +296,7 @@
end else f :: remove rem in
traced_functions := remove !traced_functions
with
- | Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid
+ Typetexp.Error _ as exn -> Errors.report_error ppf exn
let dir_untrace_all ppf () =
List.iter
@@ -305,10 +306,74 @@
!traced_functions;
traced_functions := []
+(* Warnings *)
+
let parse_warnings ppf iserr s =
try Warnings.parse_options iserr s
with Arg.Bad err -> fprintf ppf "%s.@." err
+(* Typing information *)
+
+let rec trim_modtype = function
+ Mty_signature _ -> Mty_signature []
+ | Mty_functor (id, mty, mty') ->
+ Mty_functor (id, mty, trim_modtype mty')
+ | Mty_ident _ as mty -> mty
+
+let trim_signature = function
+ Mty_signature sg ->
+ Mty_signature
+ (List.map
+ (function
+ Sig_module (id, mty, rs) ->
+ Sig_module (id, trim_modtype mty, rs)
+ (*| Sig_modtype (id, Modtype_manifest mty) ->
+ Sig_modtype (id, Modtype_manifest (trim_modtype mty))*)
+ | item -> item)
+ sg)
+ | mty -> mty
+
+let dir_show ppf kind {Location.loc; txt=lid} =
+ let env = !Toploop.toplevel_env in
+ try
+ let id =
+ let s = match lid with
+ Longident.Lident s -> s
+ | Longident.Ldot (_,s) -> s
+ | Longident.Lapply _ -> failwith "invalid"
+ in Ident.create_persistent s
+ in
+ let item =
+ match kind with
+ Pkind_val ->
+ let path, desc = Typetexp.find_value env loc lid in
+ Sig_value (id, desc)
+ | Pkind_type ->
+ let path, desc = Typetexp.find_type env loc lid in
+ Sig_type (id, desc, Trec_not)
+ | Pkind_exception ->
+ let desc = Typetexp.find_constructor env loc lid in
+ Sig_exception (id, {exn_args=desc.cstr_args; exn_loc=Location.none})
+ | Pkind_module ->
+ let path, desc = Typetexp.find_module env loc lid in
+ Sig_module (id, trim_signature desc, Trec_not)
+ | Pkind_modtype ->
+ let path, desc = Typetexp.find_modtype env loc lid in
+ Sig_modtype (id, desc)
+ | Pkind_class ->
+ let path, desc = Typetexp.find_class env loc lid in
+ Sig_class (id, desc, Trec_not)
+ | Pkind_cltype ->
+ let path, desc = Typetexp.find_class_type env loc lid in
+ Sig_class_type (id, desc, Trec_not)
+ in
+ fprintf ppf "%a@." Printtyp.signature [item]
+ with
+ Not_found ->
+ fprintf ppf "Unknown %s.@." (Printast.string_of_kind kind)
+ | Failure "invalid" ->
+ fprintf ppf "Invalid path %a@." Printtyp.longident lid
+
let _ =
Hashtbl.add directive_table "trace" (Directive_ident (dir_trace std_out));
Hashtbl.add directive_table "untrace" (Directive_ident (dir_untrace std_out));
@@ -337,4 +402,7 @@
(Directive_string (parse_warnings std_out false));
Hashtbl.add directive_table "warn_error"
- (Directive_string (parse_warnings std_out true))
+ (Directive_string (parse_warnings std_out true));
+
+ Hashtbl.add directive_table "show"
+ (Directive_show (dir_show std_out))
Index: toplevel/toploop.ml
===================================================================
--- toplevel/toploop.ml (revision 13955)
+++ toplevel/toploop.ml (working copy)
@@ -25,7 +25,8 @@
| Directive_none of (unit -> unit)
| Directive_string of (string -> unit)
| Directive_int of (int -> unit)
- | Directive_ident of (Longident.t -> unit)
+ | Directive_ident of (Longident.t Location.loc -> unit)
+ | Directive_show of (ident_kind -> Longident.t Location.loc -> unit)
| Directive_bool of (bool -> unit)
(* The table of toplevel value bindings and its accessors *)
@@ -280,6 +281,7 @@
| (Directive_string f, Pdir_string s) -> f s; true
| (Directive_int f, Pdir_int n) -> f n; true
| (Directive_ident f, Pdir_ident lid) -> f lid; true
+ | (Directive_show f, Pdir_show (kind,lid)) -> f kind lid; true
| (Directive_bool f, Pdir_bool b) -> f b; true
| (_, _) ->
fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name;
Index: toplevel/topdirs.mli
===================================================================
--- toplevel/topdirs.mli (revision 13955)
+++ toplevel/topdirs.mli (working copy)
@@ -20,11 +20,12 @@
val dir_cd : string -> unit
val dir_load : formatter -> string -> unit
val dir_use : formatter -> string -> unit
-val dir_install_printer : formatter -> Longident.t -> unit
-val dir_remove_printer : formatter -> Longident.t -> unit
-val dir_trace : formatter -> Longident.t -> unit
-val dir_untrace : formatter -> Longident.t -> unit
+val dir_install_printer : formatter -> Longident.t Location.loc -> unit
+val dir_remove_printer : formatter -> Longident.t Location.loc -> unit
+val dir_trace : formatter -> Longident.t Location.loc -> unit
+val dir_untrace : formatter -> Longident.t Location.loc -> unit
val dir_untrace_all : formatter -> unit -> unit
+val dir_show : formatter -> Parsetree.ident_kind -> Longident.t Location.loc -> unit
type 'a printer_type_new = Format.formatter -> 'a -> unit
type 'a printer_type_old = 'a -> unit
Index: toplevel/toploop.mli
===================================================================
--- toplevel/toploop.mli (revision 13955)
+++ toplevel/toploop.mli (working copy)
@@ -37,7 +37,8 @@
| Directive_none of (unit -> unit)
| Directive_string of (string -> unit)
| Directive_int of (int -> unit)
- | Directive_ident of (Longident.t -> unit)
+ | Directive_ident of (Longident.t Location.loc -> unit)
+ | Directive_show of (Parsetree.ident_kind -> Longident.t Location.loc -> unit)
| Directive_bool of (bool -> unit)
val directive_table : (string, directive_fun) Hashtbl.t
Index: tools/Makefile.shared
===================================================================
--- tools/Makefile.shared (revision 13955)
+++ tools/Makefile.shared (working copy)
@@ -210,6 +210,7 @@
../parsing/location.cmo \
../parsing/longident.cmo \
../parsing/lexer.cmo \
+ ../parsing/printast.cmo \
../parsing/pprintast.cmo \
../typing/ident.cmo \
../typing/path.cmo \
Index: camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml
===================================================================
--- camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml (revision 13955)
+++ camlp4/Camlp4/Struct/Camlp4Ast2OCamlAst.ml (working copy)
@@ -1229,7 +1229,7 @@
| ExInt _ i -> Pdir_int (int_of_string i)
| <:expr< True >> -> Pdir_bool True
| <:expr< False >> -> Pdir_bool False
- | e -> Pdir_ident (ident_noloc (ident_of_expr e)) ]
+ | e -> Pdir_ident (ident (ident_of_expr e)) ]
;
value phrase =
Index: camlp4/boot/Camlp4.ml
===================================================================
--- camlp4/boot/Camlp4.ml (revision 13955)
+++ camlp4/boot/Camlp4.ml (working copy)
@@ -15686,7 +15686,7 @@
| ExInt (_, i) -> Pdir_int (int_of_string i)
| Ast.ExId (_, (Ast.IdUid (_, "True"))) -> Pdir_bool true
| Ast.ExId (_, (Ast.IdUid (_, "False"))) -> Pdir_bool false
- | e -> Pdir_ident (ident_noloc (ident_of_expr e))
+ | e -> Pdir_ident (ident (ident_of_expr e))
let phrase =
function

22
experimental/garrigue/tests.ml
View File

@ -1,22 +0,0 @@
(* $Id$ *)
let f1 = function `a x -> x=1 | `b -> true
let f2 = function `a x -> x | `b -> true
let f3 = function `b -> true
let f x = f1 x && f2 x
let sub s ?:pos{=0} ?:len{=String.length s - pos} () =
String.sub s pos len
let cCAMLtoTKpack_options w = function
`After v1 -> "-after"
| `Anchor v1 -> "-anchor"
| `Before v1 -> "-before"
| `Expand v1 -> "-expand"
| `Fill v1 -> "-fill"
| `In v1 -> "-in"
| `Ipadx v1 -> "-ipadx"
| `Ipady v1 -> "-ipady"
| `Padx v1 -> "-padx"
| `Pady v1 -> "-pady"
| `Side v1 -> "-side"

2349
experimental/garrigue/valvirt.diff
View File

File diff suppressed because it is too large Load Diff

1656
experimental/garrigue/variable-names-Tvar.diff
View File

File diff suppressed because it is too large Load Diff

4
experimental/garrigue/variable-names.ml
View File

@ -1,4 +0,0 @@
let f (x : < a:int; .. > as 'me1) = (x : < b:bool; .. > as 'me2);;
let f (x : < a:int; .. > as 'me1) = (x : < a:int; b:bool; .. > as 'me2);;
let f (x : [> `A of int] as 'me1) = (x : [> `B of bool] as 'me2);;
let f (x : [> `A of int] as 'me1) = (x : [`A of int | `B of 'me2] as 'me2);;

435
experimental/garrigue/varunion.ml
View File

@ -1,435 +0,0 @@
(* cvs update -r varunion parsing typing bytecomp toplevel *)
type t = private [> ];;
type u = private [> ] ~ [t];;
type v = [t | u];;
let f x = (x : t :> v);;
(* bad *)
module Mix(X: sig type t = private [> ] end)
(Y: sig type t = private [> ] end) =
struct type t = [X.t | Y.t] end;;
(* bad *)
module Mix(X: sig type t = private [> `A of int ] end)
(Y: sig type t = private [> `A of bool] ~ [X.t] end) =
struct type t = [X.t | Y.t] end;;
(* ok *)
module Mix(X: sig type t = private [> `A of int ] end)
(Y: sig type t = private [> `A of int] ~ [X.t] end) =
struct type t = [X.t | Y.t] end;;
(* bad *)
module Mix(X: sig type t = private [> `A of int ] end)
(Y: sig type t = private [> `B of bool] ~ [X.t] end) =
struct type t = [X.t | Y.t] end;;
type 'a t = private [> `L of 'a] ~ [`L];;
(* ok *)
module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
(Y: sig type t = private [> `B of bool] ~ [X.t] end) =
struct type t = [X.t | Y.t] let is_t = function #t -> true | _ -> false end;;
module Mix(X: sig type t = private [> `A of int ] ~ [`B] end)
(Y: sig type t = private [> `B of bool] ~ [X.t] end) =
struct
type t = [X.t | Y.t]
let which = function #X.t -> `X | #Y.t -> `Y
end;;
module Mix(I: sig type t = private [> ] ~ [`A;`B] end)
(X: sig type t = private [> I.t | `A of int ] ~ [`B] end)
(Y: sig type t = private [> I.t | `B of bool] ~ [X.t] end) =
struct
type t = [X.t | Y.t]
let which = function #X.t -> `X | #Y.t -> `Y
end;;
(* ok *)
module M =
Mix(struct type t = [`C of char] end)
(struct type t = [`A of int | `C of char] end)
(struct type t = [`B of bool | `C of char] end);;
(* bad *)
module M =
Mix(struct type t = [`B of bool] end)
(struct type t = [`A of int | `B of bool] end)
(struct type t = [`B of bool | `C of char] end);;
(* ok *)
module M1 = struct type t = [`A of int | `C of char] end
module M2 = struct type t = [`B of bool | `C of char] end
module I = struct type t = [`C of char] end
module M = Mix(I)(M1)(M2) ;;
let c = (`C 'c' : M.t) ;;
module M(X : sig type t = private [> `A] end) =
struct let f (#X.t as x) = x end;;
(* code generation *)
type t = private [> `A ] ~ [`B];;
match `B with #t -> 1 | `B -> 2;;
module M : sig type t = private [> `A of int | `B] ~ [`C] end =
struct type t = [`A of int | `B | `D of bool] end;;
let f = function (`C | #M.t) -> 1+1 ;;
let f = function (`A _ | `B #M.t) -> 1+1 ;;
(* expression *)
module Mix(X:sig type t = private [> ] val show: t -> string end)
(Y:sig type t = private [> ] ~ [X.t] val show: t -> string end) =
struct
type t = [X.t | Y.t]
let show : t -> string = function
#X.t as x -> X.show x
| #Y.t as y -> Y.show y
end;;
module EStr = struct
type t = [`Str of string]
let show (`Str s) = s
end
module EInt = struct
type t = [`Int of int]
let show (`Int i) = string_of_int i
end
module M = Mix(EStr)(EInt);;
module type T = sig type t = private [> ] val show: t -> string end
module Mix(X:T)(Y:T with type t = private [> ] ~ [X.t]) :
T with type t = [X.t | Y.t] =
struct
type t = [X.t | Y.t]
let show = function
#X.t as x -> X.show x
| #Y.t as y -> Y.show y
end;;
module M = Mix(EStr)(EInt);;
(* deep *)
module M : sig type t = private [> `A] end = struct type t = [`A] end
module M' : sig type t = private [> ] end = struct type t = [M.t | `A] end;;
(* bad *)
type t = private [> ]
type u = private [> `A of int] ~ [t] ;;
(* ok *)
type t = private [> `A of int]
type u = private [> `A of int] ~ [t] ;;
module F(X: sig
type t = private [> ] ~ [`A;`B;`C;`D]
type u = private [> `A|`B|`C] ~ [t; `D]
end) : sig type v = private [< X.t | X.u | `D] end = struct
open X
let f = function #u -> 1 | #t -> 2 | `D -> 3
let g = function #u|#t|`D -> 2
type v = [t|u|`D]
end
(* ok *)
module M = struct type t = private [> `A] end;;
module M' : sig type t = private [> ] ~ [`A] end = M;;
(* ok *)
module type T = sig type t = private [> ] ~ [`A] end;;
module type T' = T with type t = private [> `A];;
(* ok *)
type t = private [> ] ~ [`A]
let f = function `A x -> x | #t -> 0
type t' = private [< `A of int | t];;
(* should be ok *)
module F(X:sig end) :
sig type t = private [> ] type u = private [> ] ~ [t] end =
struct type t = [ `A] type u = [`B] end
module M = F(String)
let f = function #M.t -> 1 | #M.u -> 2
let f = function #M.t -> 1 | _ -> 2
type t = [M.t | M.u]
let f = function #t -> 1 | _ -> 2;;
module G(X : sig type t = private [> ] type u = private [> ] ~ [t] end) =
struct let f = function #X.t -> 1 | _ -> 2 end;;
module M1 = G(struct module N = F(String) type t = N.t type u = N.u end) ;;
module M1 = G(struct type t = M.t type u = M.u end) ;;
(* bad *)
let f = function #F(String).t -> 1 | _ -> 2;;
type t = [F(String).t | M.u]
let f = function #t -> 1 | _ -> 2;;
module N : sig type t = private [> ] end =
struct type t = [F(String).t | M.u] end;;
(* compatibility improvement *)
type a = [`A of int | `B]
type b = [`A of bool | `B]
type c = private [> ] ~ [a;b]
let f = function #c -> 1 | `A x -> truncate x
type d = private [> ] ~ [a]
let g = function #d -> 1 | `A x -> truncate x;;
(* Expression Problem: functorial form *)
type num = [ `Num of int ]
module type Exp = sig
type t = private [> num]
val eval : t -> t
val show : t -> string
end
module Num(X : Exp) = struct
type t = num
let eval (`Num _ as x) : X.t = x
let show (`Num n) = string_of_int n
end
type 'a add = [ `Add of 'a * 'a ]
module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
type t = X.t add
let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
let eval (`Add(e1, e2) : t) =
let e1 = X.eval e1 and e2 = X.eval e2 in
match e1, e2 with
`Num n1, `Num n2 -> `Num (n1+n2)
| `Num 0, e | e, `Num 0 -> e
| e12 -> `Add e12
end
type 'a mul = [`Mul of 'a * 'a]
module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
type t = X.t mul
let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
let eval (`Mul(e1, e2) : t) =
let e1 = X.eval e1 and e2 = X.eval e2 in
match e1, e2 with
`Num n1, `Num n2 -> `Num (n1*n2)
| `Num 0, e | e, `Num 0 -> `Num 0
| `Num 1, e | e, `Num 1 -> e
| e12 -> `Mul e12
end
module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
module type S =
sig
type t = private [> ] ~ [ X.t ]
val eval : t -> Y.t
val show : t -> string
end
end
module Dummy = struct type t = [`Dummy] end
module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
struct
type t = [E1.t | E2.t]
let eval = function
#E1.t as x -> E1.eval x
| #E2.t as x -> E2.eval x
let show = function
#E1.t as x -> E1.show x
| #E2.t as x -> E2.show x
end
module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
Mix(EAdd)(Num(EAdd))(Add(EAdd))
(* A bit heavy: one must pass E to everybody *)
module rec E : Exp with type t = [num | E.t add | E.t mul] =
Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E))
let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))
(* Alternatives *)
(* Direct approach, no need of Mix *)
module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
struct
module E1 = Num(E)
module E2 = Add(E)
module E3 = Mul(E)
type t = E.t
let show = function
| #num as x -> E1.show x
| #add as x -> E2.show x
| #mul as x -> E3.show x
let eval = function
| #num as x -> E1.eval x
| #add as x -> E2.eval x
| #mul as x -> E3.eval x
end
(* Do functor applications in Mix *)
module type T = sig type t = private [> ] end
module type Tnum = sig type t = private [> num] end
module Ext(E : Tnum) = struct
module type S = functor (Y : Exp with type t = E.t) ->
sig
type t = private [> num]
val eval : t -> Y.t
val show : t -> string
end
end
module Ext'(E : Tnum)(X : T) = struct
module type S = functor (Y : Exp with type t = E.t) ->
sig
type t = private [> ] ~ [ X.t ]
val eval : t -> Y.t
val show : t -> string
end
end
module Mix(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S) =
struct
module E1 = F1(E)
module E2 = F2(E)
type t = [E1.t | E2.t]
let eval = function
#E1.t as x -> E1.eval x
| #E2.t as x -> E2.eval x
let show = function
#E1.t as x -> E1.show x
| #E2.t as x -> E2.show x
end
module Join(E : Exp)(F1 : Ext(E).S)(F2 : Ext'(E)(F1(E)).S)
(E' : Exp with type t = E.t) =
Mix(E)(F1)(F2)
module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
Mix(EAdd)(Num)(Add)
module rec EMul : (Exp with type t = [num | EMul.t mul]) =
Mix(EMul)(Num)(Mul)
module rec E : (Exp with type t = [num | E.t add | E.t mul]) =
Mix(E)(Join(E)(Num)(Add))(Mul)
(* Linear extension by the end: not so nice *)
module LExt(X : T) = struct
module type S =
sig
type t
val eval : t -> X.t
val show : t -> string
end
end
module LNum(E: Exp)(X : LExt(E).S with type t = private [> ] ~ [num]) =
struct
type t = [num | X.t]
let show = function
`Num n -> string_of_int n
| #X.t as x -> X.show x
let eval = function
#num as x -> x
| #X.t as x -> X.eval x
end
module LAdd(E : Exp with type t = private [> num | 'a add] as 'a)
(X : LExt(E).S with type t = private [> ] ~ [add]) =
struct
type t = [E.t add | X.t]
let show = function
`Add(e1,e2) -> "("^ E.show e1 ^"+"^ E.show e2 ^")"
| #X.t as x -> X.show x
let eval = function
`Add(e1,e2) ->
let e1 = E.eval e1 and e2 = E.eval e2 in
begin match e1, e2 with
`Num n1, `Num n2 -> `Num (n1+n2)
| `Num 0, e | e, `Num 0 -> e
| e12 -> `Add e12
end
| #X.t as x -> X.eval x
end
module LEnd = struct
type t = [`Dummy]
let show `Dummy = ""
let eval `Dummy = `Dummy
end
module rec L : Exp with type t = [num | L.t add | `Dummy] =
LAdd(L)(LNum(L)(LEnd))
(* Back to first form, but add map *)
module Num(X : Exp) = struct
type t = num
let map f x = x
let eval1 (`Num _ as x) : X.t = x
let show (`Num n) = string_of_int n
end
module Add(X : Exp with type t = private [> num | 'a add] as 'a) = struct
type t = X.t add
let show (`Add(e1, e2) : t) = "("^ X.show e1 ^"+"^ X.show e2 ^")"
let map f (`Add(e1, e2) : t) = `Add(f e1, f e2)
let eval1 (`Add(e1, e2) as e : t) =
match e1, e2 with
`Num n1, `Num n2 -> `Num (n1+n2)
| `Num 0, e | e, `Num 0 -> e
| _ -> e
end
module Mul(X : Exp with type t = private [> num | 'a mul] as 'a) = struct
type t = X.t mul
let show (`Mul(e1, e2) : t) = "("^ X.show e1 ^"*"^ X.show e2 ^")"
let map f (`Mul(e1, e2) : t) = `Mul(f e1, f e2)
let eval1 (`Mul(e1, e2) as e : t) =
match e1, e2 with
`Num n1, `Num n2 -> `Num (n1*n2)
| `Num 0, e | e, `Num 0 -> `Num 0
| `Num 1, e | e, `Num 1 -> e
| _ -> e
end
module Ext(X : sig type t = private [> ] end)(Y : sig type t end) = struct
module type S =
sig
type t = private [> ] ~ [ X.t ]
val map : (Y.t -> Y.t) -> t -> t
val eval1 : t -> Y.t
val show : t -> string
end
end
module Mix(E : Exp)(E1 : Ext(Dummy)(E).S)(E2 : Ext(E1)(E).S) =
struct
type t = [E1.t | E2.t]
let map f = function
#E1.t as x -> (E1.map f x : E1.t :> t)
| #E2.t as x -> (E2.map f x : E2.t :> t)
let eval1 = function
#E1.t as x -> E1.eval1 x
| #E2.t as x -> E2.eval1 x
let show = function
#E1.t as x -> E1.show x
| #E2.t as x -> E2.show x
end
module type ET = sig
type t
val map : (t -> t) -> t -> t
val eval1 : t -> t
val show : t -> string
end
module Fin(E : ET) = struct
include E
let rec eval e = eval1 (map eval e)
end
module rec EAdd : (Exp with type t = [num | EAdd.t add]) =
Fin(Mix(EAdd)(Num(EAdd))(Add(EAdd)))
module rec E : Exp with type t = [num | E.t add | E.t mul] =
Fin(Mix(E)(Mix(E)(Num(E))(Add(E)))(Mul(E)))
let e = E.eval (`Add(`Mul(`Num 2,`Num 3),`Num 1))

530
experimental/garrigue/with-module-type.diff
View File

@ -1,530 +0,0 @@
Index: typing/typemod.ml
===================================================================
--- typing/typemod.ml (revision 13947)
+++ typing/typemod.ml (working copy)
@@ -80,6 +80,9 @@
Typedtree.module_expr * Types.module_type) ref
= ref (fun env m -> assert false)
+let transl_modtype_fwd =
+ ref (fun env m -> (assert false : Typedtree.module_type))
+
(* Merge one "with" constraint in a signature *)
let rec add_rec_types env = function
@@ -191,6 +194,21 @@
merge env (extract_sig env loc mty) namelist None in
(path_concat id path, lid, tcstr),
Sig_module(id, Mty_signature newsg, rs) :: rem
+ | (Sig_modtype(id, mtd) :: rem, [s], Pwith_modtype pmty)
+ when Ident.name id = s ->
+ let mty = !transl_modtype_fwd initial_env pmty in
+ let mtd' = Modtype_manifest mty.mty_type in
+ Includemod.modtype_declarations env id mtd' mtd;
+ (Pident id, lid, Twith_modtype (Tmodtype_manifest mty)),
+ Sig_modtype(id, mtd') :: rem
+ | (Sig_modtype(id, mtd) :: rem, [s], Pwith_modtypesubst pmty)
+ when Ident.name id = s ->
+ let mty = !transl_modtype_fwd initial_env pmty in
+ let mtd' = Modtype_manifest mty.mty_type in
+ Includemod.modtype_declarations env id mtd' mtd;
+ real_id := Some id;
+ (Pident id, lid, Twith_modtypesubst (Tmodtype_manifest mty)),
+ rem
| (item :: rem, _, _) ->
let (cstr, items) = merge (Env.add_item item env) rem namelist row_id
in
@@ -233,6 +251,12 @@
let (path, _) = Typetexp.find_module initial_env loc lid.txt in
let sub = Subst.add_module id path Subst.identity in
Subst.signature sub sg
+ | [s], Pwith_modtypesubst pmty ->
+ let id =
+ match !real_id with None -> assert false | Some id -> id in
+ let mty = !transl_modtype_fwd initial_env pmty in
+ let sub = Subst.add_modtype id mty.mty_type Subst.identity in
+ Subst.signature sub sg
| _ ->
sg
in
@@ -649,6 +673,8 @@
check_recmod_typedecls env2 sdecls dcl2;
(dcl2, env2)
+let () = transl_modtype_fwd := transl_modtype
+
(* Try to convert a module expression to a module path. *)
exception Not_a_path
Index: typing/typedtreeMap.ml
===================================================================
--- typing/typedtreeMap.ml (revision 13947)
+++ typing/typedtreeMap.ml (working copy)
@@ -457,6 +457,9 @@
| Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
| Twith_module (path, lid) -> cstr
| Twith_modsubst (path, lid) -> cstr
+ | Twith_modtype decl -> Twith_modtype (map_modtype_declaration decl)
+ | Twith_modtypesubst decl ->
+ Twith_modtypesubst (map_modtype_declaration decl)
in
Map.leave_with_constraint cstr
Index: typing/typedtree.ml
===================================================================
--- typing/typedtree.ml (revision 13947)
+++ typing/typedtree.ml (working copy)
@@ -255,6 +255,8 @@
| Twith_module of Path.t * Longident.t loc
| Twith_typesubst of type_declaration
| Twith_modsubst of Path.t * Longident.t loc
+ | Twith_modtype of modtype_declaration
+ | Twith_modtypesubst of modtype_declaration
and core_type =
(* mutable because of [Typeclass.declare_method] *)
Index: typing/typedtree.mli
===================================================================
--- typing/typedtree.mli (revision 13947)
+++ typing/typedtree.mli (working copy)
@@ -254,6 +254,8 @@
| Twith_module of Path.t * Longident.t loc
| Twith_typesubst of type_declaration
| Twith_modsubst of Path.t * Longident.t loc
+ | Twith_modtype of modtype_declaration
+ | Twith_modtypesubst of modtype_declaration
and core_type =
(* mutable because of [Typeclass.declare_method] *)
Index: typing/includemod.ml
===================================================================
--- typing/includemod.ml (revision 13947)
+++ typing/includemod.ml (working copy)
@@ -346,10 +346,10 @@
(* Hide the context and substitution parameters to the outside world *)
-let modtypes env mty1 mty2 = modtypes env [] Subst.identity mty1 mty2
-let signatures env sig1 sig2 = signatures env [] Subst.identity sig1 sig2
-let type_declarations env id decl1 decl2 =
- type_declarations env [] Subst.identity id decl1 decl2
+let modtypes env = modtypes env [] Subst.identity
+let signatures env = signatures env [] Subst.identity
+let type_declarations env = type_declarations env [] Subst.identity
+let modtype_declarations env = modtype_infos env [] Subst.identity
(* Error report *)
Index: typing/typedtreeIter.ml
===================================================================
--- typing/typedtreeIter.ml (revision 13947)
+++ typing/typedtreeIter.ml (working copy)
@@ -408,6 +408,8 @@
| Twith_module _ -> ()
| Twith_typesubst decl -> iter_type_declaration decl
| Twith_modsubst _ -> ()
+ | Twith_modtype decl -> iter_modtype_declaration decl
+ | Twith_modtypesubst decl -> iter_modtype_declaration decl
end;
Iter.leave_with_constraint cstr;
Index: typing/includemod.mli
===================================================================
--- typing/includemod.mli (revision 13947)
+++ typing/includemod.mli (working copy)
@@ -21,6 +21,8 @@
val compunit: string -> signature -> string -> signature -> module_coercion
val type_declarations:
Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
+val modtype_declarations:
+ Env.t -> Ident.t -> modtype_declaration -> modtype_declaration -> unit
type symptom =
Missing_field of Ident.t
Index: typing/printtyped.ml
===================================================================
--- typing/printtyped.ml (revision 13947)
+++ typing/printtyped.ml (working copy)
@@ -608,6 +608,12 @@
type_declaration (i+1) ppf td;
| Twith_module (li,_) -> line i ppf "Pwith_module %a\n" fmt_path li;
| Twith_modsubst (li,_) -> line i ppf "Pwith_modsubst %a\n" fmt_path li;
+ | Twith_modtype (td) ->
+ line i ppf "Pwith_modtype\n";
+ modtype_declaration (i+1) ppf td;
+ | Twith_modtypesubst (td) ->
+ line i ppf "Pwith_modtypesubst\n";
+ modtype_declaration (i+1) ppf td;
and module_expr i ppf x =
line i ppf "module_expr %a\n" fmt_location x.mod_loc;
Index: experimental/garrigue/with-module-type.diffs
===================================================================
--- experimental/garrigue/with-module-type.diffs (revision 13947)
+++ experimental/garrigue/with-module-type.diffs (working copy)
@@ -1,95 +1,53 @@
-Index: parsing/parser.mly
-===================================================================
---- parsing/parser.mly (revision 12005)
-+++ parsing/parser.mly (working copy)
-@@ -1504,6 +1504,10 @@
- { ($2, Pwith_module $4) }
- | MODULE mod_longident COLONEQUAL mod_ext_longident
- { ($2, Pwith_modsubst $4) }
-+ | MODULE TYPE mod_longident EQUAL module_type
-+ { ($3, Pwith_modtype $5) }
-+ | MODULE TYPE mod_longident COLONEQUAL module_type
-+ { ($3, Pwith_modtypesubst $5) }
- ;
- with_type_binder:
- EQUAL { Public }
-Index: parsing/parsetree.mli
-===================================================================
---- parsing/parsetree.mli (revision 12005)
-+++ parsing/parsetree.mli (working copy)
-@@ -239,6 +239,8 @@
- | Pwith_module of Longident.t
- | Pwith_typesubst of type_declaration
- | Pwith_modsubst of Longident.t
-+ | Pwith_modtype of module_type
-+ | Pwith_modtypesubst of module_type
-
- (* Value expressions for the module language *)
-
-Index: parsing/printast.ml
-===================================================================
---- parsing/printast.ml (revision 12005)
-+++ parsing/printast.ml (working copy)
-@@ -575,6 +575,12 @@
- type_declaration (i+1) ppf td;
- | Pwith_module (li) -> line i ppf "Pwith_module %a\n" fmt_longident li;
- | Pwith_modsubst (li) -> line i ppf "Pwith_modsubst %a\n" fmt_longident li;
-+ | Pwith_modtype (mty) ->
-+ line i ppf "Pwith_modtype\n";
-+ module_type (i+1) ppf mty;
-+ | Pwith_modtypesubst (mty) ->
-+ line i ppf "Pwith_modtype\n";
-+ module_type (i+1) ppf mty;
-
- and module_expr i ppf x =
- line i ppf "module_expr %a\n" fmt_location x.pmod_loc;
Index: typing/typemod.ml
===================================================================
---- typing/typemod.ml (revision 12005)
+--- typing/typemod.ml (revision 13947)
+++ typing/typemod.ml (working copy)
-@@ -74,6 +74,8 @@
- : (Env.t -> Parsetree.module_expr -> module_type) ref
+@@ -80,6 +80,9 @@
+ Typedtree.module_expr * Types.module_type) ref
= ref (fun env m -> assert false)
-+let transl_modtype_fwd = ref (fun env m -> assert false)
++let transl_modtype_fwd =
++ ref (fun env m -> (assert false : Typedtree.module_type))
+
(* Merge one "with" constraint in a signature *)
let rec add_rec_types env = function
-@@ -163,6 +165,19 @@
- ignore(Includemod.modtypes env newmty mty);
- real_id := Some id;
- make_next_first rs rem
-+ | (Tsig_modtype(id, mtd) :: rem, [s], Pwith_modtype pmty)
+@@ -191,6 +194,21 @@
+ merge env (extract_sig env loc mty) namelist None in
+ (path_concat id path, lid, tcstr),
+ Sig_module(id, Mty_signature newsg, rs) :: rem
++ | (Sig_modtype(id, mtd) :: rem, [s], Pwith_modtype pmty)
+ when Ident.name id = s ->
+ let mty = !transl_modtype_fwd initial_env pmty in
-+ let mtd' = Tmodtype_manifest mty in
++ let mtd' = Modtype_manifest mty.mty_type in
+ Includemod.modtype_declarations env id mtd' mtd;
-+ Tsig_modtype(id, mtd') :: rem
-+ | (Tsig_modtype(id, mtd) :: rem, [s], Pwith_modtypesubst pmty)
++ (Pident id, lid, Twith_modtype (Tmodtype_manifest mty)),
++ Sig_modtype(id, mtd') :: rem
++ | (Sig_modtype(id, mtd) :: rem, [s], Pwith_modtypesubst pmty)
+ when Ident.name id = s ->
+ let mty = !transl_modtype_fwd initial_env pmty in
-+ let mtd' = Tmodtype_manifest mty in
++ let mtd' = Modtype_manifest mty.mty_type in
+ Includemod.modtype_declarations env id mtd' mtd;
+ real_id := Some id;
++ (Pident id, lid, Twith_modtypesubst (Tmodtype_manifest mty)),
+ rem
- | (Tsig_module(id, mty, rs) :: rem, s :: namelist, _)
- when Ident.name id = s ->
- let newsg = merge env (extract_sig env loc mty) namelist None in
-@@ -200,6 +215,12 @@
- let (path, _) = Typetexp.find_module initial_env loc lid in
+ | (item :: rem, _, _) ->
+ let (cstr, items) = merge (Env.add_item item env) rem namelist row_id
+ in
+@@ -233,6 +251,12 @@
+ let (path, _) = Typetexp.find_module initial_env loc lid.txt in
let sub = Subst.add_module id path Subst.identity in
Subst.signature sub sg
+ | [s], Pwith_modtypesubst pmty ->
+ let id =
+ match !real_id with None -> assert false | Some id -> id in
+ let mty = !transl_modtype_fwd initial_env pmty in
-+ let sub = Subst.add_modtype id mty Subst.identity in
++ let sub = Subst.add_modtype id mty.mty_type Subst.identity in
+ Subst.signature sub sg
| _ ->
- sg
- with Includemod.Error explanation ->
-@@ -499,6 +520,8 @@
+ sg
+ in
+@@ -649,6 +673,8 @@
check_recmod_typedecls env2 sdecls dcl2;
(dcl2, env2)
@@ -98,11 +56,51 @@
(* Try to convert a module expression to a module path. *)
exception Not_a_path
+Index: typing/typedtreeMap.ml
+===================================================================
+--- typing/typedtreeMap.ml (revision 13947)
++++ typing/typedtreeMap.ml (working copy)
+@@ -457,6 +457,9 @@
+ | Twith_typesubst decl -> Twith_typesubst (map_type_declaration decl)
+ | Twith_module (path, lid) -> cstr
+ | Twith_modsubst (path, lid) -> cstr
++ | Twith_modtype decl -> Twith_modtype (map_modtype_declaration decl)
++ | Twith_modtypesubst decl ->
++ Twith_modtypesubst (map_modtype_declaration decl)
+ in
+ Map.leave_with_constraint cstr
+
+Index: typing/typedtree.ml
+===================================================================
+--- typing/typedtree.ml (revision 13947)
++++ typing/typedtree.ml (working copy)
+@@ -255,6 +255,8 @@
+ | Twith_module of Path.t * Longident.t loc
+ | Twith_typesubst of type_declaration
+ | Twith_modsubst of Path.t * Longident.t loc
++ | Twith_modtype of modtype_declaration
++ | Twith_modtypesubst of modtype_declaration
+
+ and core_type =
+ (* mutable because of [Typeclass.declare_method] *)
+Index: typing/typedtree.mli
+===================================================================
+--- typing/typedtree.mli (revision 13947)
++++ typing/typedtree.mli (working copy)
+@@ -254,6 +254,8 @@
+ | Twith_module of Path.t * Longident.t loc
+ | Twith_typesubst of type_declaration
+ | Twith_modsubst of Path.t * Longident.t loc
++ | Twith_modtype of modtype_declaration
++ | Twith_modtypesubst of modtype_declaration
+
+ and core_type =
+ (* mutable because of [Typeclass.declare_method] *)
Index: typing/includemod.ml
===================================================================
---- typing/includemod.ml (revision 12005)
+--- typing/includemod.ml (revision 13947)
+++ typing/includemod.ml (working copy)
-@@ -326,10 +326,10 @@
+@@ -346,10 +346,10 @@
(* Hide the context and substitution parameters to the outside world *)
@@ -117,11 +115,24 @@
(* Error report *)
+Index: typing/typedtreeIter.ml
+===================================================================
+--- typing/typedtreeIter.ml (revision 13947)
++++ typing/typedtreeIter.ml (working copy)
+@@ -408,6 +408,8 @@
+ | Twith_module _ -> ()
+ | Twith_typesubst decl -> iter_type_declaration decl
+ | Twith_modsubst _ -> ()
++ | Twith_modtype decl -> iter_modtype_declaration decl
++ | Twith_modtypesubst decl -> iter_modtype_declaration decl
+ end;
+ Iter.leave_with_constraint cstr;
+
Index: typing/includemod.mli
===================================================================
---- typing/includemod.mli (revision 12005)
+--- typing/includemod.mli (revision 13947)
+++ typing/includemod.mli (working copy)
-@@ -23,6 +23,8 @@
+@@ -21,6 +21,8 @@
val compunit: string -> signature -> string -> signature -> module_coercion
val type_declarations:
Env.t -> Ident.t -> type_declaration -> type_declaration -> unit
@@ -130,53 +141,20 @@
type symptom =
Missing_field of Ident.t
-Index: testsuite/tests/typing-modules/Test.ml.reference
+Index: typing/printtyped.ml
===================================================================
---- testsuite/tests/typing-modules/Test.ml.reference (revision 12005)
-+++ testsuite/tests/typing-modules/Test.ml.reference (working copy)
-@@ -6,4 +6,12 @@
- # type -'a t
- class type c = object method m : [ `A ] t end
- # module M : sig val v : (#c as 'a) -> 'a end
-+# module type S = sig module type T module F : functor (X : T) -> T end
-+# module type T0 = sig type t end
-+# module type S1 = sig module type T = T0 module F : functor (X : T) -> T end
-+# module type S2 = sig module F : functor (X : T0) -> T0 end
-+# module type S3 =
-+ sig
-+ module F : functor (X : sig type t = int end) -> sig type t = int end
-+ end
- #
-Index: testsuite/tests/typing-modules/Test.ml.principal.reference
-===================================================================
---- testsuite/tests/typing-modules/Test.ml.principal.reference (revision 12005)
-+++ testsuite/tests/typing-modules/Test.ml.principal.reference (working copy)
-@@ -6,4 +6,12 @@
- # type -'a t
- class type c = object method m : [ `A ] t end
- # module M : sig val v : (#c as 'a) -> 'a end
-+# module type S = sig module type T module F : functor (X : T) -> T end
-+# module type T0 = sig type t end
-+# module type S1 = sig module type T = T0 module F : functor (X : T) -> T end
-+# module type S2 = sig module F : functor (X : T0) -> T0 end
-+# module type S3 =
-+ sig
-+ module F : functor (X : sig type t = int end) -> sig type t = int end
-+ end
- #
-Index: testsuite/tests/typing-modules/Test.ml
-===================================================================
---- testsuite/tests/typing-modules/Test.ml (revision 12005)
-+++ testsuite/tests/typing-modules/Test.ml (working copy)
-@@ -9,3 +9,11 @@
- class type c = object method m : [ `A ] t end;;
- module M : sig val v : (#c as 'a) -> 'a end =
- struct let v x = ignore (x :> c); x end;;
-+
-+(* with module type *)
-+
-+module type S = sig module type T module F(X:T) : T end;;
-+module type T0 = sig type t end;;
-+module type S1 = S with module type T = T0;;
-+module type S2 = S with module type T := T0;;
-+module type S3 = S with module type T := sig type t = int end;;
+--- typing/printtyped.ml (revision 13947)
++++ typing/printtyped.ml (working copy)
+@@ -608,6 +608,12 @@
+ type_declaration (i+1) ppf td;
+ | Twith_module (li,_) -> line i ppf "Pwith_module %a\n" fmt_path li;
+ | Twith_modsubst (li,_) -> line i ppf "Pwith_modsubst %a\n" fmt_path li;
++ | Twith_modtype (td) ->
++ line i ppf "Pwith_modtype\n";
++ modtype_declaration (i+1) ppf td;
++ | Twith_modtypesubst (td) ->
++ line i ppf "Pwith_modtypesubst\n";
++ modtype_declaration (i+1) ppf td;
+
+ and module_expr i ppf x =
+ line i ppf "module_expr %a\n" fmt_location x.mod_loc;
Index: parsing/pprintast.ml
===================================================================
--- parsing/pprintast.ml (revision 13947)
+++ parsing/pprintast.ml (working copy)
@@ -847,18 +847,28 @@
(self#list self#type_var_option ~sep:"," ~first:"(" ~last:")")
ls self#longident_loc li self#type_declaration td
| Pwith_module (li2) ->
- pp f "module %a =@ %a" self#longident_loc li self#longident_loc li2;
+ pp f "module %a =@ %a"
+ self#longident_loc li self#longident_loc li2
| Pwith_typesubst ({ptype_params=ls;_} as td) ->
pp f "type@ %a %a :=@ %a"
(self#list self#type_var_option ~sep:"," ~first:"(" ~last:")")
ls self#longident_loc li
self#type_declaration td
| Pwith_modsubst (li2) ->
- pp f "module %a :=@ %a" self#longident_loc li self#longident_loc li2 in
+ pp f "module %a :=@ %a"
+ self#longident_loc li self#longident_loc li2
+ | Pwith_modtype mty ->
+ pp f "module type %a =@ %a"
+ self#longident_loc li self#module_type mty
+ | Pwith_modtypesubst mty ->
+ pp f "module type %a :=@ %a"
+ self#longident_loc li self#module_type mty
+ in
(match l with
| [] -> pp f "@[<hov2>%a@]" self#module_type mt
| _ -> pp f "@[<hov2>(%a@ with@ %a)@]"
- self#module_type mt (self#list longident_x_with_constraint ~sep:"@ and@ ") l )
+ self#module_type mt
+ (self#list longident_x_with_constraint ~sep:"@ and@ ") l )
| Pmty_typeof me ->
pp f "@[<hov2>module@ type@ of@ %a@]"
self#module_expr me
Index: parsing/parser.mly
===================================================================
--- parsing/parser.mly (revision 13947)
+++ parsing/parser.mly (working copy)
@@ -1506,6 +1506,10 @@
{ (mkrhs $2 2, Pwith_module (mkrhs $4 4)) }
| MODULE UIDENT COLONEQUAL mod_ext_longident
{ (mkrhs (Lident $2) 2, Pwith_modsubst (mkrhs $4 4)) }
+ | MODULE TYPE mty_longident EQUAL module_type
+ { (mkrhs $3 3, Pwith_modtype $5) }
+ | MODULE TYPE ident COLONEQUAL module_type
+ { (mkrhs (Lident $3) 3, Pwith_modtypesubst $5) }
;
with_type_binder:
EQUAL { Public }
Index: parsing/ast_mapper.ml
===================================================================
--- parsing/ast_mapper.ml (revision 13947)
+++ parsing/ast_mapper.ml (working copy)
@@ -164,6 +164,8 @@
| Pwith_module s -> Pwith_module (map_loc sub s)
| Pwith_typesubst d -> Pwith_typesubst (sub # type_declaration d)
| Pwith_modsubst s -> Pwith_modsubst (map_loc sub s)
+ | Pwith_modtype m -> Pwith_modtype (sub # module_type m)
+ | Pwith_modtypesubst m -> Pwith_modtypesubst (sub # module_type m)
let mk_item ?(loc = Location.none) x = {psig_desc = x; psig_loc = loc}
Index: parsing/parsetree.mli
===================================================================
--- parsing/parsetree.mli (revision 13947)
+++ parsing/parsetree.mli (working copy)
@@ -256,6 +256,8 @@
| Pwith_module of Longident.t loc
| Pwith_typesubst of type_declaration
| Pwith_modsubst of Longident.t loc
+ | Pwith_modtype of module_type
+ | Pwith_modtypesubst of module_type
(* Value expressions for the module language *)
Index: parsing/printast.ml
===================================================================
--- parsing/printast.ml (revision 13947)
+++ parsing/printast.ml (working copy)
@@ -590,6 +590,12 @@
type_declaration (i+1) ppf td;
| Pwith_module li -> line i ppf "Pwith_module %a\n" fmt_longident_loc li;
| Pwith_modsubst li -> line i ppf "Pwith_modsubst %a\n" fmt_longident_loc li;
+ | Pwith_modtype (mty) ->
+ line i ppf "Pwith_modtype\n";
+ module_type (i+1) ppf mty;
+ | Pwith_modtypesubst (mty) ->
+ line i ppf "Pwith_modtype\n";
+ module_type (i+1) ppf mty;
and module_expr i ppf x =
line i ppf "module_expr %a\n" fmt_location x.pmod_loc;