summaryrefslogtreecommitdiff
path: root/camlp4/lib/extfun.ml
diff options
context:
space:
mode:
Diffstat (limited to 'camlp4/lib/extfun.ml')
-rw-r--r--camlp4/lib/extfun.ml109
1 files changed, 0 insertions, 109 deletions
diff --git a/camlp4/lib/extfun.ml b/camlp4/lib/extfun.ml
deleted file mode 100644
index 866ea221c1..0000000000
--- a/camlp4/lib/extfun.ml
+++ /dev/null
@@ -1,109 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-(* Copyright 2001 INRIA *)
-
-(* Extensible Functions *)
-
-type t 'a 'b = list (matching 'a 'b)
-and matching 'a 'b = { patt : patt; has_when : bool; expr : expr 'a 'b }
-and patt =
- [ Eapp of list patt
- | Eacc of list patt
- | Econ of string
- | Estr of string
- | Eint of string
- | Etup of list patt
- | Evar of unit ]
-and expr 'a 'b = 'a -> option 'b
-;
-
-exception Failure;
-
-value empty = [];
-
-(*** Apply ***)
-
-value rec apply_matchings a =
- fun
- [ [m :: ml] ->
- match m.expr a with
- [ None -> apply_matchings a ml
- | x -> x ]
- | [] -> None ]
-;
-
-value apply ef a =
- match apply_matchings a ef with
- [ Some x -> x
- | None -> raise Failure ]
-;
-
-(*** Trace ***)
-
-value rec list_iter_sep f s =
- fun
- [ [] -> ()
- | [x] -> f x
- | [x :: l] -> do { f x; s (); list_iter_sep f s l } ]
-;
-
-value rec print_patt =
- fun
- [ Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl
- | p -> print_patt2 p ]
-and print_patt2 =
- fun
- [ Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl
- | p -> print_patt1 p ]
-and print_patt1 =
- fun
- [ Econ s -> print_string s
- | Estr s -> do { print_string "\""; print_string s; print_string "\"" }
- | Eint s -> print_string s
- | Evar () -> print_string "_"
- | Etup pl ->
- do {
- print_string "(";
- list_iter_sep print_patt (fun () -> print_string ", ") pl;
- print_string ")"
- }
- | Eapp _ | Eacc _ as p ->
- do { print_string "("; print_patt p; print_string ")" } ]
-;
-
-value print ef =
- List.iter
- (fun m ->
- do {
- print_patt m.patt;
- if m.has_when then print_string " when ..." else ();
- print_newline ()
- })
- ef
-;
-
-(*** Extension ***)
-
-value insert_matching matchings (patt, has_when, expr) =
- let m1 = {patt = patt; has_when = has_when; expr = expr} in
- let rec loop =
- fun
- [ [m :: ml] as gml ->
- if m1.has_when && not m.has_when then [m1 :: gml]
- else if not m1.has_when && m.has_when then [m :: loop ml]
- else
- let c = compare m1.patt m.patt in
- if c < 0 then [m1 :: gml]
- else if c > 0 then [m :: loop ml]
- else if m.has_when then [m1 :: gml]
- else [m1 :: ml]
- | [] -> [m1] ]
- in
- loop matchings
-;
-
-(* available extension function *)
-
-value extend ef matchings_def =
- List.fold_left insert_matching ef matchings_def
-;