summaryrefslogtreecommitdiff
path: root/camlp4/lib
diff options
context:
space:
mode:
Diffstat (limited to 'camlp4/lib')
-rw-r--r--camlp4/lib/.cvsignore3
-rw-r--r--camlp4/lib/.depend20
-rw-r--r--camlp4/lib/Makefile48
-rw-r--r--camlp4/lib/Makefile.Mac46
-rw-r--r--camlp4/lib/Makefile.Mac.depend13
-rw-r--r--camlp4/lib/extfold.ml91
-rw-r--r--camlp4/lib/extfold.mli24
-rw-r--r--camlp4/lib/extfun.ml109
-rw-r--r--camlp4/lib/extfun.mli36
-rw-r--r--camlp4/lib/fstream.ml77
-rw-r--r--camlp4/lib/fstream.mli60
-rw-r--r--camlp4/lib/gramext.ml565
-rw-r--r--camlp4/lib/gramext.mli81
-rw-r--r--camlp4/lib/grammar.ml1064
-rw-r--r--camlp4/lib/grammar.mli209
-rw-r--r--camlp4/lib/plexer.ml1006
-rw-r--r--camlp4/lib/plexer.mli72
-rw-r--r--camlp4/lib/stdpp.ml79
-rw-r--r--camlp4/lib/stdpp.mli37
-rw-r--r--camlp4/lib/token.ml229
-rw-r--r--camlp4/lib/token.mli133
21 files changed, 0 insertions, 4002 deletions
diff --git a/camlp4/lib/.cvsignore b/camlp4/lib/.cvsignore
deleted file mode 100644
index c77a681dd6..0000000000
--- a/camlp4/lib/.cvsignore
+++ /dev/null
@@ -1,3 +0,0 @@
-*.cm[oiax]
-*.cmxa
-*.lib
diff --git a/camlp4/lib/.depend b/camlp4/lib/.depend
deleted file mode 100644
index 0d5adc691f..0000000000
--- a/camlp4/lib/.depend
+++ /dev/null
@@ -1,20 +0,0 @@
-extfold.cmi: gramext.cmi
-gramext.cmi: token.cmi
-grammar.cmi: gramext.cmi token.cmi
-plexer.cmi: token.cmi
-extfold.cmo: gramext.cmi grammar.cmi extfold.cmi
-extfold.cmx: gramext.cmx grammar.cmx extfold.cmi
-extfun.cmo: extfun.cmi
-extfun.cmx: extfun.cmi
-fstream.cmo: fstream.cmi
-fstream.cmx: fstream.cmi
-gramext.cmo: token.cmi gramext.cmi
-gramext.cmx: token.cmx gramext.cmi
-grammar.cmo: gramext.cmi stdpp.cmi token.cmi grammar.cmi
-grammar.cmx: gramext.cmx stdpp.cmx token.cmx grammar.cmi
-plexer.cmo: stdpp.cmi token.cmi plexer.cmi
-plexer.cmx: stdpp.cmx token.cmx plexer.cmi
-stdpp.cmo: stdpp.cmi
-stdpp.cmx: stdpp.cmi
-token.cmo: token.cmi
-token.cmx: token.cmi
diff --git a/camlp4/lib/Makefile b/camlp4/lib/Makefile
deleted file mode 100644
index ece72d1519..0000000000
--- a/camlp4/lib/Makefile
+++ /dev/null
@@ -1,48 +0,0 @@
-# $Id$
-
-include ../config/Makefile
-
-INCLUDES=
-OCAMLCFLAGS=-warn-error A $(INCLUDES)
-OBJS=stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfold.cmo extfun.cmo fstream.cmo
-SHELL=/bin/sh
-TARGET=gramlib.cma
-
-all: $(TARGET)
-opt: $(TARGET:.cma=.cmxa)
-
-$(TARGET): $(OBJS)
- $(OCAMLC) $(OBJS) -a -o $(TARGET)
-
-$(TARGET:.cma=.cmxa): $(OBJS:.cmo=.cmx)
- $(OCAMLOPT) $(OBJS:.cmo=.cmx) -a -o $(TARGET:.cma=.cmxa)
-
-clean::
- rm -f *.cm[ioax] *.cmxa *.pp[io] *.$(O) *.$(A) *.bak .*.bak $(TARGET)
-
-depend:
- cp .depend .depend.bak
- > .depend
- @for i in *.mli *.ml; do \
- ../tools/apply.sh pr_depend.cmo -- $(INCLUDES) $$i >> .depend; \
- done
-
-promote:
- cp $(OBJS) $(OBJS:.cmo=.cmi) ../boot/.
-
-compare:
- @for j in $(OBJS) $(OBJS:.cmo=.cmi); do \
- if cmp $$j ../boot/$$j; then :; else exit 1; fi; \
- done
-
-install:
- -$(MKDIR) "$(LIBDIR)/camlp4"
- cp $(TARGET) *.mli "$(LIBDIR)/camlp4/."
- cp *.cmi "$(LIBDIR)/camlp4/."
- if test -f $(TARGET:.cma=.cmxa); then $(MAKE) installopt LIBDIR="$(LIBDIR)"; fi
-
-installopt:
- cp $(TARGET:.cma=.cmxa) *.cmx "$(LIBDIR)/camlp4/."
- tar cf - $(TARGET:.cma=.$(A)) | (cd "$(LIBDIR)/camlp4/."; tar xf -)
-
-include .depend
diff --git a/camlp4/lib/Makefile.Mac b/camlp4/lib/Makefile.Mac
deleted file mode 100644
index 90034c5c74..0000000000
--- a/camlp4/lib/Makefile.Mac
+++ /dev/null
@@ -1,46 +0,0 @@
-#######################################################################
-# #
-# Camlp4 #
-# #
-# Damien Doligez, projet Para, INRIA Rocquencourt #
-# #
-# Copyright 1999 Institut National de Recherche en Informatique et #
-# en Automatique. Distributed only by permission. #
-# #
-#######################################################################
-
-# $Id$
-
-INCLUDES =
-OCAMLCFLAGS = {INCLUDES}
-OBJS = stdpp.cmo token.cmo plexer.cmo gramext.cmo grammar.cmo extfun.cmo fstream.cmo
-INTF = stdpp.cmi token.cmi plexer.cmi gramext.cmi grammar.cmi extfun.cmi fstream.cmi
-TARGETS = gramlib.cma
-
-all Ä {TARGETS}
-
-{TARGETS} Ä {OBJS}
- {OCAMLC} {OBJS} -a -o {TARGETS}
-
-steal Ä
-
-compare_stolen Ä
-
-clean ÄÄ
- delete -i {TARGETS}
-
-{dependrule}
-
-promote Ä
- duplicate -y {OBJS} {INTF} ::boot:
-
-compare Ä
- for i in {OBJS} {INTF}
- equal -s ::boot:{i} || exit 1
- end
-
-install Ä
- (newfolder "{P4LIBDIR}" || set status 0) ³ dev:null
- duplicate -y {TARGETS} Å.mli Å.cmi "{P4LIBDIR}"
-
-{defrules}
diff --git a/camlp4/lib/Makefile.Mac.depend b/camlp4/lib/Makefile.Mac.depend
deleted file mode 100644
index 8d12e3e08a..0000000000
--- a/camlp4/lib/Makefile.Mac.depend
+++ /dev/null
@@ -1,13 +0,0 @@
-gramext.cmoÄ token.cmi gramext.cmi
-gramext.cmxÄ token.cmx gramext.cmi
-gramext.cmiÄ token.cmi
-grammar.cmoÄ gramext.cmi stdpp.cmi token.cmi grammar.cmi
-grammar.cmxÄ gramext.cmx stdpp.cmx token.cmx grammar.cmi
-grammar.cmiÄ gramext.cmi token.cmi
-plexer.cmoÄ stdpp.cmi token.cmi plexer.cmi
-plexer.cmxÄ stdpp.cmx token.cmx plexer.cmi
-plexer.cmiÄ token.cmi
-stdpp.cmoÄ stdpp.cmi
-stdpp.cmxÄ stdpp.cmi
-token.cmoÄ token.cmi
-token.cmxÄ token.cmi
diff --git a/camlp4/lib/extfold.ml b/camlp4/lib/extfold.ml
deleted file mode 100644
index b612d15248..0000000000
--- a/camlp4/lib/extfold.ml
+++ /dev/null
@@ -1,91 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-type t 'te 'a 'b =
- Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) ->
- (Stream.t 'te -> 'a) -> Stream.t 'te -> 'b
-;
-
-type tsep 'te 'a 'b =
- Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) ->
- (Stream.t 'te -> 'a) -> (Stream.t 'te -> unit) -> Stream.t 'te -> 'b
-;
-
-value gen_fold0 final f e entry symbl psymb =
- let rec fold accu =
- parser
- [ [: a = psymb; s :] -> fold (f a accu) s
- | [: :] -> accu ]
- in
- parser [: a = fold e :] -> final a
-;
-
-value gen_fold1 final f e entry symbl psymb =
- let rec fold accu =
- parser
- [ [: a = psymb; s :] -> fold (f a accu) s
- | [: :] -> accu ]
- in
- parser [: a = psymb; a = fold (f a e) :] -> final a
-;
-
-value gen_fold0sep final f e entry symbl psymb psep =
- let failed =
- fun
- [ [symb; sep] -> Grammar.symb_failed_txt entry sep symb
- | _ -> "failed" ]
- in
- let rec kont accu =
- parser
- [ [: v = psep; a = psymb ? failed symbl; s :] -> kont (f a accu) s
- | [: :] -> accu ]
- in
- parser
- [ [: a = psymb; s :] -> final (kont (f a e) s)
- | [: :] -> e ]
-;
-
-value gen_fold1sep final f e entry symbl psymb psep =
- let failed =
- fun
- [ [symb; sep] -> Grammar.symb_failed_txt entry sep symb
- | _ -> "failed" ]
- in
- let parse_top =
- fun
- [ [symb; _] -> Grammar.parse_top_symb entry symb
- | _ -> raise Stream.Failure ]
- in
- let rec kont accu =
- parser
- [ [: v = psep;
- a =
- parser
- [ [: a = psymb :] -> a
- | [: a = parse_top symbl :] -> Obj.magic a
- | [: :] -> raise (Stream.Error (failed symbl)) ];
- s :] ->
- kont (f a accu) s
- | [: :] -> accu ]
- in
- parser [: a = psymb; s :] -> final (kont (f a e) s)
-;
-
-value sfold0 f e = gen_fold0 (fun x -> x) f e;
-value sfold1 f e = gen_fold1 (fun x -> x) f e;
-value sfold0sep f e = gen_fold0sep (fun x -> x) f e;
-value sfold1sep f e = gen_fold1sep (fun x -> x) f e;
-
-value cons x y = [x :: y];
-value nil = [];
-
-value slist0 entry = gen_fold0 List.rev cons nil entry;
-value slist1 entry = gen_fold1 List.rev cons nil entry;
-value slist0sep entry = gen_fold0sep List.rev cons nil entry;
-value slist1sep entry = gen_fold1sep List.rev cons nil entry;
-
-value sopt entry symbl psymb =
- parser
- [ [: a = psymb :] -> Some a
- | [: :] -> None ]
-;
diff --git a/camlp4/lib/extfold.mli b/camlp4/lib/extfold.mli
deleted file mode 100644
index 639631e27d..0000000000
--- a/camlp4/lib/extfold.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-type t 'te 'a 'b =
- Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) ->
- (Stream.t 'te -> 'a) -> Stream.t 'te -> 'b
-;
-
-type tsep 'te 'a 'b =
- Gramext.g_entry 'te -> list (Gramext.g_symbol 'te) ->
- (Stream.t 'te -> 'a) -> (Stream.t 'te -> unit) -> Stream.t 'te -> 'b
-;
-
-value sfold0 : ('a -> 'b -> 'b) -> 'b -> t _ 'a 'b;
-value sfold1 : ('a -> 'b -> 'b) -> 'b -> t _ 'a 'b;
-value sfold0sep : ('a -> 'b -> 'b) -> 'b -> tsep _ 'a 'b;
-value sfold1sep : ('a -> 'b -> 'b) -> 'b -> tsep _ 'a 'b;
-
-value slist0 : t _ 'a (list 'a);
-value slist1 : t _ 'a (list 'a);
-value slist0sep : tsep _ 'a (list 'a);
-value slist1sep : tsep _ 'a (list 'a);
-
-value sopt : t _ 'a (option 'a);
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
-;
diff --git a/camlp4/lib/extfun.mli b/camlp4/lib/extfun.mli
deleted file mode 100644
index 01b3cbd76b..0000000000
--- a/camlp4/lib/extfun.mli
+++ /dev/null
@@ -1,36 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-(** Extensible functions.
-
- This module implements pattern matching extensible functions.
- To extend, use syntax [pa_extfun.cmo]:
-
- [extfun e with [ pattern_matching ]] *)
-
-type t 'a 'b = 'x;
- (** The type of the extensible functions of type ['a -> 'b] *)
-value empty : t 'a 'b;
- (** Empty extensible function *)
-value apply : t 'a 'b -> 'a -> 'b;
- (** Apply an extensible function *)
-exception Failure;
- (** Match failure while applying an extensible function *)
-value print : t 'a 'b -> unit;
- (** Print patterns in the order they are recorded *)
-
-(**/**)
-
-type 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
-;
-
-value extend : t 'a 'b -> list (patt * bool * expr 'a 'b) -> t 'a 'b;
diff --git a/camlp4/lib/fstream.ml b/camlp4/lib/fstream.ml
deleted file mode 100644
index 14ab3a3d1c..0000000000
--- a/camlp4/lib/fstream.ml
+++ /dev/null
@@ -1,77 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-(* Copyright 2001 INRIA *)
-
-type t 'a = { count : int; data : Lazy.t (data 'a) }
-and data 'a =
- [ Nil
- | Cons of 'a and t 'a
- | App of t 'a and t 'a ]
-;
-
-value from f =
- loop 0 where rec loop i =
- {count = 0;
- data =
- lazy
- (match f i with
- [ Some x -> Cons x (loop (i + 1))
- | None -> Nil ])}
-;
-
-value rec next s =
- let count = s.count + 1 in
- match Lazy.force s.data with
- [ Nil -> None
- | Cons a s -> Some (a, {count = count; data = s.data})
- | App s1 s2 ->
- match next s1 with
- [ Some (a, s1) -> Some (a, {count = count; data = lazy (App s1 s2)})
- | None ->
- match next s2 with
- [ Some (a, s2) -> Some (a, {count = count; data = s2.data})
- | None -> None ] ] ]
-;
-
-value empty s =
- match next s with
- [ Some _ -> None
- | None -> Some ((), s) ]
-;
-
-value nil = {count = 0; data = lazy Nil};
-value cons a s = Cons a s;
-value app s1 s2 = App s1 s2;
-value flazy f = {count = 0; data = Lazy.lazy_from_fun f};
-
-value of_list l =
- List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil
-;
-
-value of_string s =
- from (fun c -> if c < String.length s then Some s.[c] else None)
-;
-
-value of_channel ic =
- from (fun _ -> try Some (input_char ic) with [ End_of_file -> None ])
-;
-
-value iter f =
- do_rec where rec do_rec strm =
- match next strm with
- [ Some (a, strm) ->
- let _ = f a in
- do_rec strm
- | None -> () ]
-;
-
-value count s = s.count;
-
-value count_unfrozen s =
- loop 0 s where rec loop cnt s =
- if Lazy.lazy_is_val s.data then
- match Lazy.force s.data with
- [ Cons _ s -> loop (cnt + 1) s
- | _ -> cnt ]
- else cnt
-;
diff --git a/camlp4/lib/fstream.mli b/camlp4/lib/fstream.mli
deleted file mode 100644
index 12926d99ff..0000000000
--- a/camlp4/lib/fstream.mli
+++ /dev/null
@@ -1,60 +0,0 @@
-(* camlp4r *)
-(* $Id$ *)
-
-(* Module [Fstream]: functional streams *)
-
-(* This module implement functional streams.
- To be used with syntax [pa_fstream.cmo]. The syntax is:
-- stream: [fstream [: ... :]]
-- parser: [parser [ [: ... :] -> ... | ... ]]
-
- Functional parsers are of type: [Fstream.t 'a -> option ('a * Fstream.t 'a)]
-
- They have limited backtrack, i.e if a rule fails, the next rule is tested
- with the initial stream; limited because when in case of a rule with two
- consecutive symbols [a] and [b], if [b] fails, the rule fails: there is
- no try with the next rule of [a].
-*)
-
-type t 'a = 'x;
- (* The type of 'a functional streams *)
-value from : (int -> option 'a) -> t 'a;
- (* [Fstream.from f] returns a stream built from the function [f].
- To create a new stream element, the function [f] is called with
- the current stream count. The user function [f] must return either
- [Some <value>] for a value or [None] to specify the end of the
- stream. *)
-
-value of_list : list 'a -> t 'a;
- (* Return the stream holding the elements of the list in the same
- order. *)
-value of_string : string -> t char;
- (* Return the stream of the characters of the string parameter. *)
-value of_channel : in_channel -> t char;
- (* Return the stream of the characters read from the input channel. *)
-
-value iter : ('a -> unit) -> t 'a -> unit;
- (* [Fstream.iter f s] scans the whole stream s, applying function [f]
- in turn to each stream element encountered. *)
-
-value next : t 'a -> option ('a * t 'a);
- (* Return [Some (a, s)] where [a] is the first element of the stream
- and [s] the remaining stream, or [None] if the stream is empty. *)
-value empty : t 'a -> option (unit * t 'a);
- (* Return [Some ((), s)] if the stream is empty where [s] is itself,
- else [None] *)
-value count : t 'a -> int;
- (* Return the current count of the stream elements, i.e. the number
- of the stream elements discarded. *)
-value count_unfrozen : t 'a -> int;
- (* Return the number of unfrozen elements in the beginning of the
- stream; useful to determine the position of a parsing error (longuest
- path). *)
-
-(*--*)
-
-value nil : t 'a;
-type data 'a = 'x;
-value cons : 'a -> t 'a -> data 'a;
-value app : t 'a -> t 'a -> data 'a;
-value flazy : (unit -> data 'a) -> t 'a;
diff --git a/camlp4/lib/gramext.ml b/camlp4/lib/gramext.ml
deleted file mode 100644
index 980f0918d8..0000000000
--- a/camlp4/lib/gramext.ml
+++ /dev/null
@@ -1,565 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Printf;
-
-type grammar 'te =
- { gtokens : Hashtbl.t Token.pattern (ref int);
- glexer : mutable Token.glexer 'te }
-;
-
-type g_entry 'te =
- { egram : grammar 'te;
- ename : string;
- estart : mutable int -> Stream.t 'te -> Obj.t;
- econtinue : mutable int -> int -> Obj.t -> Stream.t 'te -> Obj.t;
- edesc : mutable g_desc 'te }
-and g_desc 'te =
- [ Dlevels of list (g_level 'te)
- | Dparser of Stream.t 'te -> Obj.t ]
-and g_level 'te =
- { assoc : g_assoc;
- lname : option string;
- lsuffix : g_tree 'te;
- lprefix : g_tree 'te }
-and g_assoc =
- [ NonA
- | RightA
- | LeftA ]
-and g_symbol 'te =
- [ Smeta of string and list (g_symbol 'te) and Obj.t
- | Snterm of g_entry 'te
- | Snterml of g_entry 'te and string
- | Slist0 of g_symbol 'te
- | Slist0sep of g_symbol 'te and g_symbol 'te
- | Slist1 of g_symbol 'te
- | Slist1sep of g_symbol 'te and g_symbol 'te
- | Sopt of g_symbol 'te
- | Sself
- | Snext
- | Stoken of Token.pattern
- | Stree of g_tree 'te ]
-and g_action = Obj.t
-and g_tree 'te =
- [ Node of g_node 'te
- | LocAct of g_action and list g_action
- | DeadEnd ]
-and g_node 'te =
- { node : g_symbol 'te; son : g_tree 'te; brother : g_tree 'te }
-;
-
-type position =
- [ First
- | Last
- | Before of string
- | After of string
- | Level of string ]
-;
-
-value warning_verbose = ref True;
-
-value rec derive_eps =
- fun
- [ Slist0 _ -> True
- | Slist0sep _ _ -> True
- | Sopt _ -> True
- | Stree t -> tree_derive_eps t
- | Smeta _ _ _ | Slist1 _ | Slist1sep _ _ | Snterm _ | Snterml _ _ | Snext |
- Sself | Stoken _ ->
- False ]
-and tree_derive_eps =
- fun
- [ LocAct _ _ -> True
- | Node {node = s; brother = bro; son = son} ->
- derive_eps s && tree_derive_eps son || tree_derive_eps bro
- | DeadEnd -> False ]
-;
-
-value rec eq_symbol s1 s2 =
- match (s1, s2) with
- [ (Snterm e1, Snterm e2) -> e1 == e2
- | (Snterml e1 l1, Snterml e2 l2) -> e1 == e2 && l1 = l2
- | (Slist0 s1, Slist0 s2) -> eq_symbol s1 s2
- | (Slist0sep s1 sep1, Slist0sep s2 sep2) ->
- eq_symbol s1 s2 && eq_symbol sep1 sep2
- | (Slist1 s1, Slist1 s2) -> eq_symbol s1 s2
- | (Slist1sep s1 sep1, Slist1sep s2 sep2) ->
- eq_symbol s1 s2 && eq_symbol sep1 sep2
- | (Sopt s1, Sopt s2) -> eq_symbol s1 s2
- | (Stree _, Stree _) -> False
- | _ -> s1 = s2 ]
-;
-
-value is_before s1 s2 =
- match (s1, s2) with
- [ (Stoken ("ANY", _), _) -> False
- | (_, Stoken ("ANY", _)) -> True
- | (Stoken (_, s), Stoken (_, "")) when s <> "" -> True
- | (Stoken _, Stoken _) -> False
- | (Stoken _, _) -> True
- | _ -> False ]
-;
-
-value insert_tree entry_name gsymbols action tree =
- let rec insert symbols tree =
- match symbols with
- [ [s :: sl] -> insert_in_tree s sl tree
- | [] ->
- match tree with
- [ Node {node = s; son = son; brother = bro} ->
- Node {node = s; son = son; brother = insert [] bro}
- | LocAct old_action action_list ->
- do {
- if warning_verbose.val then do {
- eprintf "<W> Grammar extension: ";
- if entry_name <> "" then eprintf "in [%s], " entry_name
- else ();
- eprintf "some rule has been masked\n";
- flush stderr
- }
- else ();
- LocAct action [old_action :: action_list]
- }
- | DeadEnd -> LocAct action [] ] ]
- and insert_in_tree s sl tree =
- match try_insert s sl tree with
- [ Some t -> t
- | None -> Node {node = s; son = insert sl DeadEnd; brother = tree} ]
- and try_insert s sl tree =
- match tree with
- [ Node {node = s1; son = son; brother = bro} ->
- if eq_symbol s s1 then
- let t = Node {node = s1; son = insert sl son; brother = bro} in
- Some t
- else if is_before s1 s || derive_eps s && not (derive_eps s1) then
- let bro =
- match try_insert s sl bro with
- [ Some bro -> bro
- | None ->
- Node {node = s; son = insert sl DeadEnd; brother = bro} ]
- in
- let t = Node {node = s1; son = son; brother = bro} in
- Some t
- else
- match try_insert s sl bro with
- [ Some bro ->
- let t = Node {node = s1; son = son; brother = bro} in
- Some t
- | None -> None ]
- | LocAct _ _ | DeadEnd -> None ]
- and insert_new =
- fun
- [ [s :: sl] -> Node {node = s; son = insert_new sl; brother = DeadEnd}
- | [] -> LocAct action [] ]
- in
- insert gsymbols tree
-;
-
-value srules rl =
- let t =
- List.fold_left
- (fun tree (symbols, action) -> insert_tree "" symbols action tree)
- DeadEnd rl
- in
- Stree t
-;
-
-external action : 'a -> g_action = "%identity";
-
-value is_level_labelled n lev =
- match lev.lname with
- [ Some n1 -> n = n1
- | None -> False ]
-;
-
-value insert_level entry_name e1 symbols action slev =
- match e1 with
- [ True ->
- {assoc = slev.assoc; lname = slev.lname;
- lsuffix = insert_tree entry_name symbols action slev.lsuffix;
- lprefix = slev.lprefix}
- | False ->
- {assoc = slev.assoc; lname = slev.lname; lsuffix = slev.lsuffix;
- lprefix = insert_tree entry_name symbols action slev.lprefix} ]
-;
-
-value empty_lev lname assoc =
- let assoc =
- match assoc with
- [ Some a -> a
- | None -> LeftA ]
- in
- {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd}
-;
-
-value change_lev lev n lname assoc =
- let a =
- match assoc with
- [ None -> lev.assoc
- | Some a ->
- do {
- if a <> lev.assoc && warning_verbose.val then do {
- eprintf "<W> Changing associativity of level \"%s\"\n" n;
- flush stderr
- }
- else ();
- a
- } ]
- in
- do {
- match lname with
- [ Some n ->
- if lname <> lev.lname && warning_verbose.val then do {
- eprintf "<W> Level label \"%s\" ignored\n" n; flush stderr
- }
- else ()
- | None -> () ];
- {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix;
- lprefix = lev.lprefix}
- }
-;
-
-value get_level entry position levs =
- match position with
- [ Some First -> ([], empty_lev, levs)
- | Some Last -> (levs, empty_lev, [])
- | Some (Level n) ->
- let rec get =
- fun
- [ [] ->
- do {
- eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
- entry.ename;
- flush stderr;
- failwith "Grammar.extend"
- }
- | [lev :: levs] ->
- if is_level_labelled n lev then ([], change_lev lev n, levs)
- else
- let (levs1, rlev, levs2) = get levs in
- ([lev :: levs1], rlev, levs2) ]
- in
- get levs
- | Some (Before n) ->
- let rec get =
- fun
- [ [] ->
- do {
- eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
- entry.ename;
- flush stderr;
- failwith "Grammar.extend"
- }
- | [lev :: levs] ->
- if is_level_labelled n lev then ([], empty_lev, [lev :: levs])
- else
- let (levs1, rlev, levs2) = get levs in
- ([lev :: levs1], rlev, levs2) ]
- in
- get levs
- | Some (After n) ->
- let rec get =
- fun
- [ [] ->
- do {
- eprintf "No level labelled \"%s\" in entry \"%s\"\n" n
- entry.ename;
- flush stderr;
- failwith "Grammar.extend"
- }
- | [lev :: levs] ->
- if is_level_labelled n lev then ([lev], empty_lev, levs)
- else
- let (levs1, rlev, levs2) = get levs in
- ([lev :: levs1], rlev, levs2) ]
- in
- get levs
- | None ->
- match levs with
- [ [lev :: levs] -> ([], change_lev lev "<top>", levs)
- | [] -> ([], empty_lev, []) ] ]
-;
-
-value rec check_gram entry =
- fun
- [ Snterm e ->
- if e.egram != entry.egram then do {
- eprintf "\
-Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
- entry.ename e.ename;
- flush stderr;
- failwith "Grammar.extend error"
- }
- else ()
- | Snterml e _ ->
- if e.egram != entry.egram then do {
- eprintf "\
-Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
- entry.ename e.ename;
- flush stderr;
- failwith "Grammar.extend error"
- }
- else ()
- | Smeta _ sl _ -> List.iter (check_gram entry) sl
- | Slist0sep s t -> do { check_gram entry t; check_gram entry s }
- | Slist1sep s t -> do { check_gram entry t; check_gram entry s }
- | Slist0 s -> check_gram entry s
- | Slist1 s -> check_gram entry s
- | Sopt s -> check_gram entry s
- | Stree t -> tree_check_gram entry t
- | Snext | Sself | Stoken _ -> () ]
-and tree_check_gram entry =
- fun
- [ Node {node = n; brother = bro; son = son} ->
- do {
- check_gram entry n;
- tree_check_gram entry bro;
- tree_check_gram entry son
- }
- | LocAct _ _ | DeadEnd -> () ]
-;
-
-value change_to_self entry =
- fun
- [ Snterm e when e == entry -> Sself
- | x -> x ]
-;
-
-value get_initial entry =
- fun
- [ [Sself :: symbols] -> (True, symbols)
- | symbols -> (False, symbols) ]
-;
-
-value insert_tokens gram symbols =
- let rec insert =
- fun
- [ Smeta _ sl _ -> List.iter insert sl
- | Slist0 s -> insert s
- | Slist1 s -> insert s
- | Slist0sep s t -> do { insert s; insert t }
- | Slist1sep s t -> do { insert s; insert t }
- | Sopt s -> insert s
- | Stree t -> tinsert t
- | Stoken ("ANY", _) -> ()
- | Stoken tok ->
- do {
- gram.glexer.Token.tok_using tok;
- let r =
- try Hashtbl.find gram.gtokens tok with
- [ Not_found ->
- let r = ref 0 in
- do { Hashtbl.add gram.gtokens tok r; r } ]
- in
- incr r
- }
- | Snterm _ | Snterml _ _ | Snext | Sself -> () ]
- and tinsert =
- fun
- [ Node {node = s; brother = bro; son = son} ->
- do { insert s; tinsert bro; tinsert son }
- | LocAct _ _ | DeadEnd -> () ]
- in
- List.iter insert symbols
-;
-
-value levels_of_rules entry position rules =
- let elev =
- match entry.edesc with
- [ Dlevels elev -> elev
- | Dparser _ ->
- do {
- eprintf "Error: entry not extensible: \"%s\"\n" entry.ename;
- flush stderr;
- failwith "Grammar.extend"
- } ]
- in
- if rules = [] then elev
- else
- let (levs1, make_lev, levs2) = get_level entry position elev in
- let (levs, _) =
- List.fold_left
- (fun (levs, make_lev) (lname, assoc, level) ->
- let lev = make_lev lname assoc in
- let lev =
- List.fold_left
- (fun lev (symbols, action) ->
- let symbols = List.map (change_to_self entry) symbols in
- do {
- List.iter (check_gram entry) symbols;
- let (e1, symbols) = get_initial entry symbols in
- insert_tokens entry.egram symbols;
- insert_level entry.ename e1 symbols action lev
- })
- lev level
- in
- ([lev :: levs], empty_lev))
- ([], make_lev) rules
- in
- levs1 @ List.rev levs @ levs2
-;
-
-value logically_eq_symbols entry =
- let rec eq_symbols s1 s2 =
- match (s1, s2) with
- [ (Snterm e1, Snterm e2) -> e1.ename = e2.ename
- | (Snterm e1, Sself) -> e1.ename = entry.ename
- | (Sself, Snterm e2) -> entry.ename = e2.ename
- | (Snterml e1 l1, Snterml e2 l2) -> e1.ename = e2.ename && l1 = l2
- | (Slist0 s1, Slist0 s2) -> eq_symbols s1 s2
- | (Slist0sep s1 sep1, Slist0sep s2 sep2) ->
- eq_symbols s1 s2 && eq_symbols sep1 sep2
- | (Slist1 s1, Slist1 s2) -> eq_symbols s1 s2
- | (Slist1sep s1 sep1, Slist1sep s2 sep2) ->
- eq_symbols s1 s2 && eq_symbols sep1 sep2
- | (Sopt s1, Sopt s2) -> eq_symbols s1 s2
- | (Stree t1, Stree t2) -> eq_trees t1 t2
- | _ -> s1 = s2 ]
- and eq_trees t1 t2 =
- match (t1, t2) with
- [ (Node n1, Node n2) ->
- eq_symbols n1.node n2.node && eq_trees n1.son n2.son &&
- eq_trees n1.brother n2.brother
- | (LocAct _ _ | DeadEnd, LocAct _ _ | DeadEnd) -> True
- | _ -> False ]
- in
- eq_symbols
-;
-
-(* [delete_rule_in_tree] returns
- [Some (dsl, t)] if success
- [dsl] =
- Some (list of deleted nodes) if branch deleted
- None if action replaced by previous version of action
- [t] = remaining tree
- [None] if failure *)
-
-value delete_rule_in_tree entry =
- let rec delete_in_tree symbols tree =
- match (symbols, tree) with
- [ ([s :: sl], Node n) ->
- if logically_eq_symbols entry s n.node then delete_son sl n
- else
- match delete_in_tree symbols n.brother with
- [ Some (dsl, t) ->
- Some (dsl, Node {node = n.node; son = n.son; brother = t})
- | None -> None ]
- | ([s :: sl], _) -> None
- | ([], Node n) ->
- match delete_in_tree [] n.brother with
- [ Some (dsl, t) ->
- Some (dsl, Node {node = n.node; son = n.son; brother = t})
- | None -> None ]
- | ([], DeadEnd) -> None
- | ([], LocAct _ []) -> Some (Some [], DeadEnd)
- | ([], LocAct _ [action :: list]) -> Some (None, LocAct action list) ]
- and delete_son sl n =
- match delete_in_tree sl n.son with
- [ Some (Some dsl, DeadEnd) -> Some (Some [n.node :: dsl], n.brother)
- | Some (Some dsl, t) ->
- let t = Node {node = n.node; son = t; brother = n.brother} in
- Some (Some [n.node :: dsl], t)
- | Some (None, t) ->
- let t = Node {node = n.node; son = t; brother = n.brother} in
- Some (None, t)
- | None -> None ]
- in
- delete_in_tree
-;
-
-value rec decr_keyw_use gram =
- fun
- [ Stoken tok ->
- let r = Hashtbl.find gram.gtokens tok in
- do {
- decr r;
- if r.val == 0 then do {
- Hashtbl.remove gram.gtokens tok; gram.glexer.Token.tok_removing tok
- }
- else ()
- }
- | Smeta _ sl _ -> List.iter (decr_keyw_use gram) sl
- | Slist0 s -> decr_keyw_use gram s
- | Slist1 s -> decr_keyw_use gram s
- | Slist0sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 }
- | Slist1sep s1 s2 -> do { decr_keyw_use gram s1; decr_keyw_use gram s2 }
- | Sopt s -> decr_keyw_use gram s
- | Stree t -> decr_keyw_use_in_tree gram t
- | Sself | Snext | Snterm _ | Snterml _ _ -> () ]
-and decr_keyw_use_in_tree gram =
- fun
- [ DeadEnd | LocAct _ _ -> ()
- | Node n ->
- do {
- decr_keyw_use gram n.node;
- decr_keyw_use_in_tree gram n.son;
- decr_keyw_use_in_tree gram n.brother
- } ]
-;
-
-value rec delete_rule_in_suffix entry symbols =
- fun
- [ [lev :: levs] ->
- match delete_rule_in_tree entry symbols lev.lsuffix with
- [ Some (dsl, t) ->
- do {
- match dsl with
- [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
- | None -> () ];
- match t with
- [ DeadEnd when lev.lprefix == DeadEnd -> levs
- | _ ->
- let lev =
- {assoc = lev.assoc; lname = lev.lname; lsuffix = t;
- lprefix = lev.lprefix}
- in
- [lev :: levs] ]
- }
- | None ->
- let levs = delete_rule_in_suffix entry symbols levs in
- [lev :: levs] ]
- | [] -> raise Not_found ]
-;
-
-value rec delete_rule_in_prefix entry symbols =
- fun
- [ [lev :: levs] ->
- match delete_rule_in_tree entry symbols lev.lprefix with
- [ Some (dsl, t) ->
- do {
- match dsl with
- [ Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
- | None -> () ];
- match t with
- [ DeadEnd when lev.lsuffix == DeadEnd -> levs
- | _ ->
- let lev =
- {assoc = lev.assoc; lname = lev.lname;
- lsuffix = lev.lsuffix; lprefix = t}
- in
- [lev :: levs] ]
- }
- | None ->
- let levs = delete_rule_in_prefix entry symbols levs in
- [lev :: levs] ]
- | [] -> raise Not_found ]
-;
-
-value rec delete_rule_in_level_list entry symbols levs =
- match symbols with
- [ [Sself :: symbols] -> delete_rule_in_suffix entry symbols levs
- | [Snterm e :: symbols] when e == entry ->
- delete_rule_in_suffix entry symbols levs
- | _ -> delete_rule_in_prefix entry symbols levs ]
-;
diff --git a/camlp4/lib/gramext.mli b/camlp4/lib/gramext.mli
deleted file mode 100644
index bd0fed514b..0000000000
--- a/camlp4/lib/gramext.mli
+++ /dev/null
@@ -1,81 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type grammar 'te =
- { gtokens : Hashtbl.t Token.pattern (ref int);
- glexer : mutable Token.glexer 'te }
-;
-
-type g_entry 'te =
- { egram : grammar 'te;
- ename : string;
- estart : mutable int -> Stream.t 'te -> Obj.t;
- econtinue : mutable int -> int -> Obj.t -> Stream.t 'te -> Obj.t;
- edesc : mutable g_desc 'te }
-and g_desc 'te =
- [ Dlevels of list (g_level 'te)
- | Dparser of Stream.t 'te -> Obj.t ]
-and g_level 'te =
- { assoc : g_assoc;
- lname : option string;
- lsuffix : g_tree 'te;
- lprefix : g_tree 'te }
-and g_assoc =
- [ NonA
- | RightA
- | LeftA ]
-and g_symbol 'te =
- [ Smeta of string and list (g_symbol 'te) and Obj.t
- | Snterm of g_entry 'te
- | Snterml of g_entry 'te and string
- | Slist0 of g_symbol 'te
- | Slist0sep of g_symbol 'te and g_symbol 'te
- | Slist1 of g_symbol 'te
- | Slist1sep of g_symbol 'te and g_symbol 'te
- | Sopt of g_symbol 'te
- | Sself
- | Snext
- | Stoken of Token.pattern
- | Stree of g_tree 'te ]
-and g_action = Obj.t
-and g_tree 'te =
- [ Node of g_node 'te
- | LocAct of g_action and list g_action
- | DeadEnd ]
-and g_node 'te =
- { node : g_symbol 'te; son : g_tree 'te; brother : g_tree 'te }
-;
-
-type position =
- [ First
- | Last
- | Before of string
- | After of string
- | Level of string ]
-;
-
-value levels_of_rules :
- g_entry 'te -> option position ->
- list
- (option string * option g_assoc *
- list (list (g_symbol 'te) * g_action)) ->
- list (g_level 'te);
-value srules : list (list (g_symbol 'te) * g_action) -> g_symbol 'te;
-external action : 'a -> g_action = "%identity";
-
-value delete_rule_in_level_list :
- g_entry 'te -> list (g_symbol 'te) -> list (g_level 'te) ->
- list (g_level 'te);
-
-value warning_verbose : ref bool;
diff --git a/camlp4/lib/grammar.ml b/camlp4/lib/grammar.ml
deleted file mode 100644
index b8c22d5073..0000000000
--- a/camlp4/lib/grammar.ml
+++ /dev/null
@@ -1,1064 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Stdpp;
-open Gramext;
-open Format;
-
-value rec flatten_tree =
- fun
- [ DeadEnd -> []
- | LocAct _ _ -> [[]]
- | Node {node = n; brother = b; son = s} ->
- List.map (fun l -> [n :: l]) (flatten_tree s) @ flatten_tree b ]
-;
-
-value print_str ppf s = fprintf ppf "\"%s\"" (String.escaped s);
-
-value rec print_symbol ppf =
- fun
- [ Smeta n sl _ -> print_meta ppf n sl
- | Slist0 s -> fprintf ppf "LIST0 %a" print_symbol1 s
- | Slist0sep s t ->
- fprintf ppf "LIST0 %a SEP %a" print_symbol1 s print_symbol1 t
- | Slist1 s -> fprintf ppf "LIST1 %a" print_symbol1 s
- | Slist1sep s t ->
- fprintf ppf "LIST1 %a SEP %a" print_symbol1 s print_symbol1 t
- | Sopt s -> fprintf ppf "OPT %a" print_symbol1 s
- | Stoken (con, prm) when con <> "" && prm <> "" ->
- fprintf ppf "%s@ %a" con print_str prm
- | Snterml e l -> fprintf ppf "%s@ LEVEL@ %a" e.ename print_str l
- | Snterm _ | Snext | Sself | Stoken _ | Stree _ as s ->
- print_symbol1 ppf s ]
-and print_meta ppf n sl =
- loop 0 sl where rec loop i =
- fun
- [ [] -> ()
- | [s :: sl] ->
- let j =
- try String.index_from n i ' ' with [ Not_found -> String.length n ]
- in
- do {
- fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s;
- if sl = [] then ()
- else do { fprintf ppf " "; loop (min (j + 1) (String.length n)) sl }
- } ]
-and print_symbol1 ppf =
- fun
- [ Snterm e -> pp_print_string ppf e.ename
- | Sself -> pp_print_string ppf "SELF"
- | Snext -> pp_print_string ppf "NEXT"
- | Stoken ("", s) -> print_str ppf s
- | Stoken (con, "") -> pp_print_string ppf con
- | Stree t -> print_level ppf pp_print_space (flatten_tree t)
- | Smeta _ _ _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ |
- Slist1sep _ _ | Sopt _ | Stoken _ as s ->
- fprintf ppf "(%a)" print_symbol s ]
-and print_rule ppf symbols =
- do {
- fprintf ppf "@[<hov 0>";
- let _ =
- List.fold_left
- (fun sep symbol ->
- do {
- fprintf ppf "%t%a" sep print_symbol symbol;
- fun ppf -> fprintf ppf ";@ "
- })
- (fun ppf -> ()) symbols
- in
- fprintf ppf "@]"
- }
-and print_level ppf pp_print_space rules =
- do {
- fprintf ppf "@[<hov 0>[ ";
- let _ =
- List.fold_left
- (fun sep rule ->
- do {
- fprintf ppf "%t%a" sep print_rule rule;
- fun ppf -> fprintf ppf "%a| " pp_print_space ()
- })
- (fun ppf -> ()) rules
- in
- fprintf ppf " ]@]"
- }
-;
-
-value print_levels ppf elev =
- let _ =
- List.fold_left
- (fun sep lev ->
- let rules =
- List.map (fun t -> [Sself :: t]) (flatten_tree lev.lsuffix) @
- flatten_tree lev.lprefix
- in
- do {
- fprintf ppf "%t@[<hov 2>" sep;
- match lev.lname with
- [ Some n -> fprintf ppf "%a@;<1 2>" print_str n
- | None -> () ];
- match lev.assoc with
- [ LeftA -> fprintf ppf "LEFTA"
- | RightA -> fprintf ppf "RIGHTA"
- | NonA -> fprintf ppf "NONA" ];
- fprintf ppf "@]@;<1 2>";
- print_level ppf pp_force_newline rules;
- fun ppf -> fprintf ppf "@,| "
- })
- (fun ppf -> ()) elev
- in
- ()
-;
-
-value print_entry ppf e =
- do {
- fprintf ppf "@[<v 0>[ ";
- match e.edesc with
- [ Dlevels elev -> print_levels ppf elev
- | Dparser _ -> fprintf ppf "<parser>" ];
- fprintf ppf " ]@]"
- }
-;
-
-value iter_entry f e =
- let treated = ref [] in
- let rec do_entry e =
- if List.memq e treated.val then ()
- else do {
- treated.val := [e :: treated.val];
- f e;
- match e.edesc with
- [ Dlevels ll -> List.iter do_level ll
- | Dparser _ -> () ]
- }
- and do_level lev = do { do_tree lev.lsuffix; do_tree lev.lprefix }
- and do_tree =
- fun
- [ Node n -> do_node n
- | LocAct _ _ | DeadEnd -> () ]
- and do_node n = do { do_symbol n.node; do_tree n.son; do_tree n.brother }
- and do_symbol =
- fun
- [ Smeta _ sl _ -> List.iter do_symbol sl
- | Snterm e | Snterml e _ -> do_entry e
- | Slist0 s | Slist1 s | Sopt s -> do_symbol s
- | Slist0sep s1 s2 | Slist1sep s1 s2 -> do { do_symbol s1; do_symbol s2 }
- | Stree t -> do_tree t
- | Sself | Snext | Stoken _ -> () ]
- in
- do_entry e
-;
-
-value fold_entry f e init =
- let treated = ref [] in
- let rec do_entry accu e =
- if List.memq e treated.val then accu
- else do {
- treated.val := [e :: treated.val];
- let accu = f e accu in
- match e.edesc with
- [ Dlevels ll -> List.fold_left do_level accu ll
- | Dparser _ -> accu ]
- }
- and do_level accu lev =
- let accu = do_tree accu lev.lsuffix in
- do_tree accu lev.lprefix
- and do_tree accu =
- fun
- [ Node n -> do_node accu n
- | LocAct _ _ | DeadEnd -> accu ]
- and do_node accu n =
- let accu = do_symbol accu n.node in
- let accu = do_tree accu n.son in
- do_tree accu n.brother
- and do_symbol accu =
- fun
- [ Smeta _ sl _ -> List.fold_left do_symbol accu sl
- | Snterm e | Snterml e _ -> do_entry accu e
- | Slist0 s | Slist1 s | Sopt s -> do_symbol accu s
- | Slist0sep s1 s2 | Slist1sep s1 s2 ->
- let accu = do_symbol accu s1 in
- do_symbol accu s2
- | Stree t -> do_tree accu t
- | Sself | Snext | Stoken _ -> accu ]
- in
- do_entry init e
-;
-
-type g = Gramext.grammar Token.t;
-
-external grammar_obj : g -> grammar Token.t = "%identity";
-
-value floc = ref (fun _ -> failwith "internal error when computing location");
-value loc_of_token_interval bp ep =
- if bp == ep then
- if bp == 0 then (0, 1)
- else
- let a = snd (floc.val (bp - 1)) in
- (a, a + 1)
- else
- let (bp1, bp2) = floc.val bp in
- let (ep1, ep2) = floc.val (pred ep) in
- (if bp1 < ep1 then bp1 else ep1, if bp2 > ep2 then bp2 else ep2)
-;
-
-value rec name_of_symbol entry =
- fun
- [ Snterm e -> "[" ^ e.ename ^ "]"
- | Snterml e l -> "[" ^ e.ename ^ " level " ^ l ^ "]"
- | Sself | Snext -> "[" ^ entry.ename ^ "]"
- | Stoken tok -> entry.egram.glexer.Token.tok_text tok
- | _ -> "???" ]
-;
-
-value rec get_token_list entry tokl last_tok tree =
- match tree with
- [ Node {node = (Stoken tok as s); son = son; brother = DeadEnd} ->
- get_token_list entry [last_tok :: tokl] tok son
- | _ ->
- if tokl = [] then None
- else Some (List.rev [last_tok :: tokl], last_tok, tree) ]
-;
-
-value rec name_of_symbol_failed entry =
- fun
- [ Slist0 s -> name_of_symbol_failed entry s
- | Slist0sep s _ -> name_of_symbol_failed entry s
- | Slist1 s -> name_of_symbol_failed entry s
- | Slist1sep s _ -> name_of_symbol_failed entry s
- | Sopt s -> name_of_symbol_failed entry s
- | Stree t -> name_of_tree_failed entry t
- | s -> name_of_symbol entry s ]
-and name_of_tree_failed entry =
- fun
- [ Node {node = s; brother = bro; son = son} ->
- let tokl =
- match s with
- [ Stoken tok -> get_token_list entry [] tok son
- | _ -> None ]
- in
- match tokl with
- [ None ->
- let txt = name_of_symbol_failed entry s in
- let txt =
- match (s, son) with
- [ (Sopt _, Node _) -> txt ^ " or " ^ name_of_tree_failed entry son
- | _ -> txt ]
- in
- let txt =
- match bro with
- [ DeadEnd | LocAct _ _ -> txt
- | Node _ -> txt ^ " or " ^ name_of_tree_failed entry bro ]
- in
- txt
- | Some (tokl, last_tok, son) ->
- List.fold_left
- (fun s tok ->
- (if s = "" then "" else s ^ " ") ^
- entry.egram.glexer.Token.tok_text tok)
- "" tokl ]
- | DeadEnd | LocAct _ _ -> "???" ]
-;
-
-value search_tree_in_entry prev_symb tree =
- fun
- [ Dlevels levels ->
- let rec search_levels =
- fun
- [ [] -> tree
- | [level :: levels] ->
- match search_level level with
- [ Some tree -> tree
- | None -> search_levels levels ] ]
- and search_level level =
- match search_tree level.lsuffix with
- [ Some t -> Some (Node {node = Sself; son = t; brother = DeadEnd})
- | None -> search_tree level.lprefix ]
- and search_tree t =
- if tree <> DeadEnd && t == tree then Some t
- else
- match t with
- [ Node n ->
- match search_symbol n.node with
- [ Some symb ->
- Some (Node {node = symb; son = n.son; brother = DeadEnd})
- | None ->
- match search_tree n.son with
- [ Some t ->
- Some (Node {node = n.node; son = t; brother = DeadEnd})
- | None -> search_tree n.brother ] ]
- | LocAct _ _ | DeadEnd -> None ]
- and search_symbol symb =
- match symb with
- [ Snterm _ | Snterml _ _ | Slist0 _ | Slist0sep _ _ | Slist1 _ |
- Slist1sep _ _ | Sopt _ | Stoken _ | Stree _
- when symb == prev_symb ->
- Some symb
- | Slist0 symb ->
- match search_symbol symb with
- [ Some symb -> Some (Slist0 symb)
- | None -> None ]
- | Slist0sep symb sep ->
- match search_symbol symb with
- [ Some symb -> Some (Slist0sep symb sep)
- | None ->
- match search_symbol sep with
- [ Some sep -> Some (Slist0sep symb sep)
- | None -> None ] ]
- | Slist1 symb ->
- match search_symbol symb with
- [ Some symb -> Some (Slist1 symb)
- | None -> None ]
- | Slist1sep symb sep ->
- match search_symbol symb with
- [ Some symb -> Some (Slist1sep symb sep)
- | None ->
- match search_symbol sep with
- [ Some sep -> Some (Slist1sep symb sep)
- | None -> None ] ]
- | Sopt symb ->
- match search_symbol symb with
- [ Some symb -> Some (Sopt symb)
- | None -> None ]
- | Stree t ->
- match search_tree t with
- [ Some t -> Some (Stree t)
- | None -> None ]
- | _ -> None ]
- in
- search_levels levels
- | Dparser _ -> tree ]
-;
-
-value error_verbose = ref False;
-
-value tree_failed entry prev_symb_result prev_symb tree =
- let txt = name_of_tree_failed entry tree in
- let txt =
- match prev_symb with
- [ Slist0 s ->
- let txt1 = name_of_symbol_failed entry s in
- txt1 ^ " or " ^ txt ^ " expected"
- | Slist1 s ->
- let txt1 = name_of_symbol_failed entry s in
- txt1 ^ " or " ^ txt ^ " expected"
- | Slist0sep s sep ->
- match Obj.magic prev_symb_result with
- [ [] ->
- let txt1 = name_of_symbol_failed entry s in
- txt1 ^ " or " ^ txt ^ " expected"
- | _ ->
- let txt1 = name_of_symbol_failed entry sep in
- txt1 ^ " or " ^ txt ^ " expected" ]
- | Slist1sep s sep ->
- match Obj.magic prev_symb_result with
- [ [] ->
- let txt1 = name_of_symbol_failed entry s in
- txt1 ^ " or " ^ txt ^ " expected"
- | _ ->
- let txt1 = name_of_symbol_failed entry sep in
- txt1 ^ " or " ^ txt ^ " expected" ]
- | Sopt _ | Stree _ -> txt ^ " expected"
- | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb ]
- in
- do {
- if error_verbose.val then do {
- let tree = search_tree_in_entry prev_symb tree entry.edesc in
- let ppf = err_formatter in
- fprintf ppf "@[<v 0>@,";
- fprintf ppf "----------------------------------@,";
- fprintf ppf "Parse error in entry [%s], rule:@;<0 2>" entry.ename;
- fprintf ppf "@[";
- print_level ppf pp_force_newline (flatten_tree tree);
- fprintf ppf "@]@,";
- fprintf ppf "----------------------------------@,";
- fprintf ppf "@]@."
- }
- else ();
- txt ^ " (in [" ^ entry.ename ^ "])"
- }
-;
-
-value symb_failed entry prev_symb_result prev_symb symb =
- let tree = Node {node = symb; brother = DeadEnd; son = DeadEnd} in
- tree_failed entry prev_symb_result prev_symb tree
-;
-
-external app : Obj.t -> 'a = "%identity";
-
-value is_level_labelled n lev =
- match lev.lname with
- [ Some n1 -> n = n1
- | None -> False ]
-;
-
-value level_number entry lab =
- let rec lookup levn =
- fun
- [ [] -> failwith ("unknown level " ^ lab)
- | [lev :: levs] ->
- if is_level_labelled lab lev then levn else lookup (succ levn) levs ]
- in
- match entry.edesc with
- [ Dlevels elev -> lookup 0 elev
- | Dparser _ -> raise Not_found ]
-;
-
-value rec top_symb entry =
- fun
- [ Sself | Snext -> Snterm entry
- | Snterml e _ -> Snterm e
- | Slist1sep s sep -> Slist1sep (top_symb entry s) sep
- | _ -> raise Stream.Failure ]
-;
-
-value entry_of_symb entry =
- fun
- [ Sself | Snext -> entry
- | Snterm e -> e
- | Snterml e _ -> e
- | _ -> raise Stream.Failure ]
-;
-
-value top_tree entry =
- fun
- [ Node {node = s; brother = bro; son = son} ->
- Node {node = top_symb entry s; brother = bro; son = son}
- | LocAct _ _ | DeadEnd -> raise Stream.Failure ]
-;
-
-value skip_if_empty bp p strm =
- if Stream.count strm == bp then Gramext.action (fun a -> p strm)
- else raise Stream.Failure
-;
-
-value continue entry bp a s son p1 =
- parser
- [: a = (entry_of_symb entry s).econtinue 0 bp a;
- act = p1 ? tree_failed entry a s son :] ->
- Gramext.action (fun _ -> app act a)
-;
-
-value do_recover parser_of_tree entry nlevn alevn bp a s son =
- parser
- [ [: a = parser_of_tree entry nlevn alevn (top_tree entry son) :] -> a
- | [: a = skip_if_empty bp (parser []) :] -> a
- | [: a =
- continue entry bp a s son
- (parser_of_tree entry nlevn alevn son) :] ->
- a ]
-;
-
-value strict_parsing = ref False;
-
-value recover parser_of_tree entry nlevn alevn bp a s son strm =
- if strict_parsing.val then raise (Stream.Error (tree_failed entry a s son))
- else do_recover parser_of_tree entry nlevn alevn bp a s son strm
-;
-
-value token_count = ref 0;
-
-value peek_nth n strm =
- let list = Stream.npeek n strm in
- do {
- token_count.val := Stream.count strm + n;
- let rec loop list n =
- match (list, n) with
- [ ([x :: _], 1) -> Some x
- | ([_ :: l], n) -> loop l (n - 1)
- | ([], _) -> None ]
- in
- loop list n
- }
-;
-
-value rec parser_of_tree entry nlevn alevn =
- fun
- [ DeadEnd -> parser []
- | LocAct act _ -> parser [: :] -> act
- | Node {node = Sself; son = LocAct act _; brother = DeadEnd} ->
- parser [: a = entry.estart alevn :] -> app act a
- | Node {node = Sself; son = LocAct act _; brother = bro} ->
- let p2 = parser_of_tree entry nlevn alevn bro in
- parser
- [ [: a = entry.estart alevn :] -> app act a
- | [: a = p2 :] -> a ]
- | Node {node = s; son = son; brother = DeadEnd} ->
- let tokl =
- match s with
- [ Stoken tok -> get_token_list entry [] tok son
- | _ -> None ]
- in
- match tokl with
- [ None ->
- let ps = parser_of_symbol entry nlevn s in
- let p1 = parser_of_tree entry nlevn alevn son in
- let p1 = parser_cont p1 entry nlevn alevn s son in
- parser bp [: a = ps; act = p1 bp a :] -> app act a
- | Some (tokl, last_tok, son) ->
- let p1 = parser_of_tree entry nlevn alevn son in
- let p1 = parser_cont p1 entry nlevn alevn (Stoken last_tok) son in
- parser_of_token_list entry.egram p1 tokl ]
- | Node {node = s; son = son; brother = bro} ->
- let tokl =
- match s with
- [ Stoken tok -> get_token_list entry [] tok son
- | _ -> None ]
- in
- match tokl with
- [ None ->
- let ps = parser_of_symbol entry nlevn s in
- let p1 = parser_of_tree entry nlevn alevn son in
- let p1 = parser_cont p1 entry nlevn alevn s son in
- let p2 = parser_of_tree entry nlevn alevn bro in
- parser bp
- [ [: a = ps; act = p1 bp a :] -> app act a
- | [: a = p2 :] -> a ]
- | Some (tokl, last_tok, son) ->
- let p1 = parser_of_tree entry nlevn alevn son in
- let p1 = parser_cont p1 entry nlevn alevn (Stoken last_tok) son in
- let p1 = parser_of_token_list entry.egram p1 tokl in
- let p2 = parser_of_tree entry nlevn alevn bro in
- parser
- [ [: a = p1 :] -> a
- | [: a = p2 :] -> a ] ] ]
-and parser_cont p1 entry nlevn alevn s son bp a =
- parser
- [ [: a = p1 :] -> a
- | [: a = recover parser_of_tree entry nlevn alevn bp a s son :] -> a
- | [: :] -> raise (Stream.Error (tree_failed entry a s son)) ]
-and parser_of_token_list gram p1 tokl =
- loop 1 tokl where rec loop n =
- fun
- [ [tok :: tokl] ->
- let tematch = gram.glexer.Token.tok_match tok in
- match tokl with
- [ [] ->
- let ps strm =
- match peek_nth n strm with
- [ Some tok ->
- let r = tematch tok in
- do { for i = 1 to n do { Stream.junk strm }; Obj.repr r }
- | None -> raise Stream.Failure ]
- in
- parser bp [: a = ps; act = p1 bp a :] -> app act a
- | _ ->
- let ps strm =
- match peek_nth n strm with
- [ Some tok -> tematch tok
- | None -> raise Stream.Failure ]
- in
- let p1 = loop (n + 1) tokl in
- parser
- [: a = ps; s :] ->
- let act = p1 s in
- app act a ]
- | [] -> invalid_arg "parser_of_token_list" ]
-and parser_of_symbol entry nlevn =
- fun
- [ Smeta _ symbl act ->
- let act = Obj.magic act entry symbl in
- Obj.magic
- (List.fold_left
- (fun act symb -> Obj.magic act (parser_of_symbol entry nlevn symb))
- act symbl)
- | Slist0 s ->
- let ps = parser_of_symbol entry nlevn s in
- let rec loop al =
- parser
- [ [: a = ps; s :] -> loop [a :: al] s
- | [: :] -> al ]
- in
- parser [: a = loop [] :] -> Obj.repr (List.rev a)
- | Slist0sep symb sep ->
- let ps = parser_of_symbol entry nlevn symb in
- let pt = parser_of_symbol entry nlevn sep in
- let rec kont al =
- parser
- [ [: v = pt; a = ps ? symb_failed entry v sep symb; s :] ->
- kont [a :: al] s
- | [: :] -> al ]
- in
- parser
- [ [: a = ps; s :] -> Obj.repr (List.rev (kont [a] s))
- | [: :] -> Obj.repr [] ]
- | Slist1 s ->
- let ps = parser_of_symbol entry nlevn s in
- let rec loop al =
- parser
- [ [: a = ps; s :] -> loop [a :: al] s
- | [: :] -> al ]
- in
- parser [: a = ps; s :] -> Obj.repr (List.rev (loop [a] s))
- | Slist1sep symb sep ->
- let ps = parser_of_symbol entry nlevn symb in
- let pt = parser_of_symbol entry nlevn sep in
- let rec kont al =
- parser
- [ [: v = pt;
- a =
- parser
- [ [: a = ps :] -> a
- | [: a = parse_top_symb entry symb :] -> a
- | [: :] ->
- raise (Stream.Error (symb_failed entry v sep symb)) ];
- s :] ->
- kont [a :: al] s
- | [: :] -> al ]
- in
- parser [: a = ps; s :] -> Obj.repr (List.rev (kont [a] s))
- | Sopt s ->
- let ps = parser_of_symbol entry nlevn s in
- parser
- [ [: a = ps :] -> Obj.repr (Some a)
- | [: :] -> Obj.repr None ]
- | Stree t ->
- let pt = parser_of_tree entry 1 0 t in
- parser bp
- [: a = pt :] ep ->
- let loc = loc_of_token_interval bp ep in
- app a loc
- | Snterm e -> parser [: a = e.estart 0 :] -> a
- | Snterml e l -> parser [: a = e.estart (level_number e l) :] -> a
- | Sself -> parser [: a = entry.estart 0 :] -> a
- | Snext -> parser [: a = entry.estart nlevn :] -> a
- | Stoken tok ->
- let f = entry.egram.glexer.Token.tok_match tok in
- fun strm ->
- match Stream.peek strm with
- [ Some tok ->
- let r = f tok in
- do { Stream.junk strm; Obj.repr r }
- | None -> raise Stream.Failure ] ]
-and parse_top_symb entry symb =
- parser_of_symbol entry 0 (top_symb entry symb)
-;
-
-value symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2;
-
-value rec continue_parser_of_levels entry clevn =
- fun
- [ [] -> fun levn bp a -> parser []
- | [lev :: levs] ->
- let p1 = continue_parser_of_levels entry (succ clevn) levs in
- match lev.lsuffix with
- [ DeadEnd -> p1
- | tree ->
- let alevn =
- match lev.assoc with
- [ LeftA | NonA -> succ clevn
- | RightA -> clevn ]
- in
- let p2 = parser_of_tree entry (succ clevn) alevn tree in
- fun levn bp a strm ->
- if levn > clevn then p1 levn bp a strm
- else
- match strm with parser
- [ [: a = p1 levn bp a :] -> a
- | [: act = p2 :] ep ->
- let a = app act a (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm ] ] ]
-;
-
-value rec start_parser_of_levels entry clevn =
- fun
- [ [] -> fun levn -> parser []
- | [lev :: levs] ->
- let p1 = start_parser_of_levels entry (succ clevn) levs in
- match lev.lprefix with
- [ DeadEnd -> p1
- | tree ->
- let alevn =
- match lev.assoc with
- [ LeftA | NonA -> succ clevn
- | RightA -> clevn ]
- in
- let p2 = parser_of_tree entry (succ clevn) alevn tree in
- match levs with
- [ [] ->
- fun levn strm ->
- match strm with parser bp
- [ [: act = p2 :] ep ->
- let a = app act (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm ]
- | _ ->
- fun levn strm ->
- if levn > clevn then p1 levn strm
- else
- match strm with parser bp
- [ [: act = p2 :] ep ->
- let a = app act (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm
- | [: a = p1 levn :] -> a ] ] ] ]
-;
-
-value continue_parser_of_entry entry =
- match entry.edesc with
- [ Dlevels elev ->
- let p = continue_parser_of_levels entry 0 elev in
- fun levn bp a ->
- parser
- [ [: a = p levn bp a :] -> a
- | [: :] -> a ]
- | Dparser p -> fun levn bp a -> parser [] ]
-;
-
-value empty_entry ename levn strm =
- raise (Stream.Error ("entry [" ^ ename ^ "] is empty"))
-;
-
-value start_parser_of_entry entry =
- match entry.edesc with
- [ Dlevels [] -> empty_entry entry.ename
- | Dlevels elev -> start_parser_of_levels entry 0 elev
- | Dparser p -> fun levn strm -> p strm ]
-;
-
-value parse_parsable entry efun (cs, (ts, fun_loc)) =
- let restore =
- let old_floc = floc.val in
- let old_tc = token_count.val in
- fun () -> do { floc.val := old_floc; token_count.val := old_tc }
- in
- let get_loc () =
- try
- let cnt = Stream.count ts in
- let loc = fun_loc cnt in
- if token_count.val - 1 <= cnt then loc
- else (fst loc, snd (fun_loc (token_count.val - 1)))
- with _ ->
- (Stream.count cs, Stream.count cs + 1)
- in
- do {
- floc.val := fun_loc;
- token_count.val := 0;
- try
- let r = efun ts in
- do { restore (); r }
- with
- [ Stream.Failure ->
- let loc = get_loc () in
- do {
- restore ();
- raise_with_loc loc
- (Stream.Error ("illegal begin of " ^ entry.ename))
- }
- | Stream.Error _ as exc ->
- let loc = get_loc () in
- do { restore (); raise_with_loc loc exc }
- | exc ->
- let loc = (Stream.count cs, Stream.count cs + 1) in
- do { restore (); raise_with_loc loc exc } ]
- }
-;
-
-value wrap_parse entry efun cs =
- let parsable = (cs, entry.egram.glexer.Token.tok_func cs) in
- parse_parsable entry efun parsable
-;
-
-value create_toktab () = Hashtbl.create 301;
-value gcreate glexer = {gtokens = create_toktab (); glexer = glexer};
-
-value tematch tparse tok =
- match tparse tok with
- [ Some p -> fun x -> p [: `x :]
- | None -> Token.default_match tok ]
-;
-value glexer_of_lexer lexer =
- {Token.tok_func = lexer.Token.func; Token.tok_using = lexer.Token.using;
- Token.tok_removing = lexer.Token.removing;
- Token.tok_match = tematch lexer.Token.tparse;
- Token.tok_text = lexer.Token.text; Token.tok_comm = None}
-;
-value create lexer = gcreate (glexer_of_lexer lexer);
-
-(* Extend syntax *)
-
-value extend_entry entry position rules =
- try
- let elev = Gramext.levels_of_rules entry position rules in
- do {
- entry.edesc := Dlevels elev;
- entry.estart :=
- fun lev strm ->
- let f = start_parser_of_entry entry in
- do { entry.estart := f; f lev strm };
- entry.econtinue :=
- fun lev bp a strm ->
- let f = continue_parser_of_entry entry in
- do { entry.econtinue := f; f lev bp a strm }
- }
- with
- [ Token.Error s ->
- do {
- Printf.eprintf "Lexer initialization error:\n- %s\n" s;
- flush stderr;
- failwith "Grammar.extend"
- } ]
-;
-
-value extend entry_rules_list =
- let gram = ref None in
- List.iter
- (fun (entry, position, rules) ->
- do {
- match gram.val with
- [ Some g ->
- if g != entry.egram then do {
- Printf.eprintf "Error: entries with different grammars\n";
- flush stderr;
- failwith "Grammar.extend"
- }
- else ()
- | None -> gram.val := Some entry.egram ];
- extend_entry entry position rules
- })
- entry_rules_list
-;
-
-(* Deleting a rule *)
-
-value delete_rule entry sl =
- match entry.edesc with
- [ Dlevels levs ->
- let levs = Gramext.delete_rule_in_level_list entry sl levs in
- do {
- entry.edesc := Dlevels levs;
- entry.estart :=
- fun lev strm ->
- let f = start_parser_of_entry entry in
- do { entry.estart := f; f lev strm };
- entry.econtinue :=
- fun lev bp a strm ->
- let f = continue_parser_of_entry entry in
- do { entry.econtinue := f; f lev bp a strm }
- }
- | Dparser _ -> () ]
-;
-
-(* Unsafe *)
-
-value clear_entry e =
- do {
- e.estart := fun _ -> parser [];
- e.econtinue := fun _ _ _ -> parser [];
- match e.edesc with
- [ Dlevels _ -> e.edesc := Dlevels []
- | Dparser _ -> () ]
- }
-;
-
-value gram_reinit g glexer =
- do { Hashtbl.clear g.gtokens; g.glexer := glexer }
-;
-
-value reinit_gram g lexer = gram_reinit g (glexer_of_lexer lexer);
-
-module Unsafe =
- struct
- value gram_reinit = gram_reinit;
- value clear_entry = clear_entry;
- value reinit_gram = reinit_gram;
- end
-;
-
-value find_entry e s =
- let rec find_levels =
- fun
- [ [] -> None
- | [lev :: levs] ->
- match find_tree lev.lsuffix with
- [ None ->
- match find_tree lev.lprefix with
- [ None -> find_levels levs
- | x -> x ]
- | x -> x ] ]
- and find_symbol =
- fun
- [ Snterm e -> if e.ename = s then Some e else None
- | Snterml e _ -> if e.ename = s then Some e else None
- | Smeta _ sl _ -> find_symbol_list sl
- | Slist0 s -> find_symbol s
- | Slist0sep s _ -> find_symbol s
- | Slist1 s -> find_symbol s
- | Slist1sep s _ -> find_symbol s
- | Sopt s -> find_symbol s
- | Stree t -> find_tree t
- | Sself | Snext | Stoken _ -> None ]
- and find_symbol_list =
- fun
- [ [s :: sl] ->
- match find_symbol s with
- [ None -> find_symbol_list sl
- | x -> x ]
- | [] -> None ]
- and find_tree =
- fun
- [ Node {node = s; brother = bro; son = son} ->
- match find_symbol s with
- [ None ->
- match find_tree bro with
- [ None -> find_tree son
- | x -> x ]
- | x -> x ]
- | LocAct _ _ | DeadEnd -> None ]
- in
- match e.edesc with
- [ Dlevels levs ->
- match find_levels levs with
- [ Some e -> e
- | None -> raise Not_found ]
- | Dparser _ -> raise Not_found ]
-;
-
-value of_entry e = e.egram;
-
-module Entry =
- struct
- type te = Token.t;
- type e 'a = g_entry te;
- value create g n =
- {egram = g; ename = n; estart = empty_entry n;
- econtinue _ _ _ = parser []; edesc = Dlevels []}
- ;
- value parse (entry : e 'a) cs : 'a =
- Obj.magic (wrap_parse entry (entry.estart 0) cs)
- ;
- value parse_token (entry : e 'a) ts : 'a = Obj.magic (entry.estart 0 ts);
- value name e = e.ename;
- value of_parser g n (p : Stream.t te -> 'a) : e 'a =
- {egram = g; ename = n; estart _ = Obj.magic p;
- econtinue _ _ _ = parser []; edesc = Dparser (Obj.magic p)}
- ;
- external obj : e 'a -> Gramext.g_entry te = "%identity";
- value print e = printf "%a@." print_entry (obj e);
- value find e s = find_entry (obj e) s;
- end
-;
-
-value tokens g con =
- let list = ref [] in
- do {
- Hashtbl.iter
- (fun (p_con, p_prm) c ->
- if p_con = con then list.val := [(p_prm, c.val) :: list.val] else ())
- g.gtokens;
- list.val
- }
-;
-
-value glexer g = g.glexer;
-
-value warning_verbose = Gramext.warning_verbose;
-
-(* Functorial interface *)
-
-module type GLexerType = sig type te = 'x; value lexer : Token.glexer te; end;
-
-module type S =
- sig
- type te = 'x;
- type parsable = 'x;
- value parsable : Stream.t char -> parsable;
- value tokens : string -> list (string * int);
- value glexer : Token.glexer te;
- module Entry :
- sig
- type e 'a = 'x;
- value create : string -> e 'a;
- value parse : e 'a -> parsable -> 'a;
- value parse_token : e 'a -> Stream.t te -> 'a;
- value name : e 'a -> string;
- value of_parser : string -> (Stream.t te -> 'a) -> e 'a;
- value print : e 'a -> unit;
- external obj : e 'a -> Gramext.g_entry te = "%identity";
- end
- ;
- module Unsafe :
- sig
- value gram_reinit : Token.glexer te -> unit;
- value clear_entry : Entry.e 'a -> unit;
- value reinit_gram : Token.lexer -> unit;
- end
- ;
- value extend :
- Entry.e 'a -> option Gramext.position ->
- list
- (option string * option Gramext.g_assoc *
- list (list (Gramext.g_symbol te) * Gramext.g_action)) ->
- unit;
- value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit;
- end
-;
-
-module type ReinitType = sig value reinit_gram : g -> Token.lexer -> unit; end
-;
-
-module GGMake (R : ReinitType) (L : GLexerType) =
- struct
- type te = L.te;
- type parsable = (Stream.t char * (Stream.t te * Token.location_function));
- value gram = gcreate L.lexer;
- value parsable cs = (cs, L.lexer.Token.tok_func cs);
- value tokens = tokens gram;
- value glexer = glexer gram;
- module Entry =
- struct
- type e 'a = g_entry te;
- value create n =
- {egram = gram; ename = n; estart = empty_entry n;
- econtinue _ _ _ = parser []; edesc = Dlevels []}
- ;
- external obj : e 'a -> Gramext.g_entry te = "%identity";
- value parse (e : e 'a) p : 'a =
- Obj.magic (parse_parsable e (e.estart 0) p)
- ;
- value parse_token (e : e 'a) ts : 'a = Obj.magic (e.estart 0 ts);
- value name e = e.ename;
- value of_parser n (p : Stream.t te -> 'a) : e 'a =
- {egram = gram; ename = n; estart _ = Obj.magic p;
- econtinue _ _ _ = parser []; edesc = Dparser (Obj.magic p)}
- ;
- value print e = printf "%a@." print_entry (obj e);
- end
- ;
- module Unsafe =
- struct
- value gram_reinit = gram_reinit gram;
- value clear_entry = Unsafe.clear_entry;
- value reinit_gram = R.reinit_gram (Obj.magic gram);
- end
- ;
- value extend = extend_entry;
- value delete_rule e r = delete_rule (Entry.obj e) r;
- end
-;
-
-module GMake (L : GLexerType) =
- GGMake
- (struct
- value reinit_gram _ _ =
- failwith "call of deprecated reinit_gram in grammar built by GMake"
- ;
- end)
- L
-;
-
-module type LexerType = sig value lexer : Token.lexer; end;
-
-module Make (L : LexerType) =
- GGMake (struct value reinit_gram = reinit_gram; end)
- (struct type te = Token.t; value lexer = glexer_of_lexer L.lexer; end)
-;
diff --git a/camlp4/lib/grammar.mli b/camlp4/lib/grammar.mli
deleted file mode 100644
index fe8345fb36..0000000000
--- a/camlp4/lib/grammar.mli
+++ /dev/null
@@ -1,209 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Extensible grammars.
-
- This module implements the Camlp4 extensible grammars system.
- Grammars entries can be extended using the [EXTEND] statement,
- added by loading the Camlp4 [pa_extend.cmo] file. *)
-
-type g = 'x;
- (** The type for grammars, holding entries. *)
-value gcreate : Token.glexer Token.t -> g;
- (** Create a new grammar, without keywords, using the lexer given
- as parameter. *)
-value tokens : g -> string -> list (string * int);
- (** Given a grammar and a token pattern constructor, returns the list of
- the corresponding values currently used in all entries of this grammar.
- The integer is the number of times this pattern value is used.
-
- Examples:
-- If the associated lexer uses ("", xxx) to represent a keyword
- (what is represented by then simple string xxx in an [EXTEND]
- statement rule), the call [Grammar.token g ""] returns the keywords
- list.
-- The call [Grammar.token g "IDENT"] returns the list of all usages
- of the pattern "IDENT" in the [EXTEND] statements. *)
-value glexer : g -> Token.glexer Token.t;
- (** Return the lexer used by the grammar *)
-
-module Entry :
- sig
- type e 'a = 'x;
- value create : g -> string -> e 'a;
- value parse : e 'a -> Stream.t char -> 'a;
- value parse_token : e 'a -> Stream.t Token.t -> 'a;
- value name : e 'a -> string;
- value of_parser : g -> string -> (Stream.t Token.t -> 'a) -> e 'a;
- value print : e 'a -> unit;
- value find : e 'a -> string -> e Obj.t;
- external obj : e 'a -> Gramext.g_entry Token.t = "%identity";
- end
-;
- (** Module to handle entries.
-- [Entry.e] is the type for entries returning values of type ['a].
-- [Entry.create g n] creates a new entry named [n] in the grammar [g].
-- [Entry.parse e] returns the stream parser of the entry [e].
-- [Entry.parse_token e] returns the token parser of the entry [e].
-- [Entry.name e] returns the name of the entry [e].
-- [Entry.of_parser g n p] makes an entry from a token stream parser.
-- [Entry.print e] displays the entry [e] using [Format].
-- [Entry.find e s] finds the entry named [s] in [e]'s rules.
-- [Entry.obj e] converts an entry into a [Gramext.g_entry] allowing
-- to see what it holds ([Gramext] is visible, but not documented). *)
-
-value of_entry : Entry.e 'a -> g;
- (** Return the grammar associated with an entry. *)
-
-(** {6 Clearing grammars and entries} *)
-
-module Unsafe :
- sig
- value gram_reinit : g -> Token.glexer Token.t -> unit;
- value clear_entry : Entry.e 'a -> unit;
- (**/**)
- (* deprecated since version 3.05; use rather function [gram_reinit] *)
- value reinit_gram : g -> Token.lexer -> unit;
- end
-;
- (** Module for clearing grammars and entries. To be manipulated with
- care, because: 1) reinitializing a grammar destroys all tokens
- and there may have problems with the associated lexer if it has
- a notion of keywords; 2) clearing an entry does not destroy the
- tokens used only by itself.
-- [Unsafe.reinit_gram g lex] removes the tokens of the grammar
-- and sets [lex] as a new lexer for [g]. Warning: the lexer
-- itself is not reinitialized.
-- [Unsafe.clear_entry e] removes all rules of the entry [e]. *)
-
-(** {6 Functorial interface} *)
-
- (** Alternative for grammars use. Grammars are no more Ocaml values:
- there is no type for them. Modules generated preserve the
- rule "an entry cannot call an entry of another grammar" by
- normal OCaml typing. *)
-
-module type GLexerType =
- sig
- type te = 'x;
- value lexer : Token.glexer te;
- end;
- (** The input signature for the functor [Grammar.GMake]: [te] is the
- type of the tokens. *)
-
-module type S =
- sig
- type te = 'x;
- type parsable = 'x;
- value parsable : Stream.t char -> parsable;
- value tokens : string -> list (string * int);
- value glexer : Token.glexer te;
- module Entry :
- sig
- type e 'a = 'y;
- value create : string -> e 'a;
- value parse : e 'a -> parsable -> 'a;
- value parse_token : e 'a -> Stream.t te -> 'a;
- value name : e 'a -> string;
- value of_parser : string -> (Stream.t te -> 'a) -> e 'a;
- value print : e 'a -> unit;
- external obj : e 'a -> Gramext.g_entry te = "%identity";
- end
- ;
- module Unsafe :
- sig
- value gram_reinit : Token.glexer te -> unit;
- value clear_entry : Entry.e 'a -> unit;
- (**/**)
- (* deprecated since version 3.05; use rather [gram_reinit] *)
- (* warning: [reinit_gram] fails if used with GMake *)
- value reinit_gram : Token.lexer -> unit;
- end
- ;
- value extend :
- Entry.e 'a -> option Gramext.position ->
- list
- (option string * option Gramext.g_assoc *
- list (list (Gramext.g_symbol te) * Gramext.g_action)) ->
- unit;
- value delete_rule : Entry.e 'a -> list (Gramext.g_symbol te) -> unit;
- end
-;
- (** Signature type of the functor [Grammar.GMake]. The types and
- functions are almost the same than in generic interface, but:
-- Grammars are not values. Functions holding a grammar as parameter
- do not have this parameter yet.
-- The type [parsable] is used in function [parse] instead of
- the char stream, avoiding the possible loss of tokens.
-- The type of tokens (expressions and patterns) can be any
- type (instead of (string * string)); the module parameter
- must specify a way to show them as (string * string) *)
-
-module GMake (L : GLexerType) : S with type te = L.te;
-
-(** {6 Miscellaneous} *)
-
-value error_verbose : ref bool;
- (** Flag for displaying more information in case of parsing error;
- default = [False] *)
-
-value warning_verbose : ref bool;
- (** Flag for displaying warnings while extension; default = [True] *)
-
-value strict_parsing : ref bool;
- (** Flag to apply strict parsing, without trying to recover errors;
- default = [False] *)
-
-value print_entry : Format.formatter -> Gramext.g_entry 'te -> unit;
- (** General printer for all kinds of entries (obj entries) *)
-
-value iter_entry :
- (Gramext.g_entry 'te -> unit) -> Gramext.g_entry 'te -> unit;
- (** [Grammar.iter_entry f e] applies [f] to the entry [e] and
- transitively all entries called by [e]. The order in which
- the entries are passed to [f] is the order they appear in
- each entry. Each entry is passed only once. *)
-
-value fold_entry :
- (Gramext.g_entry 'te -> 'a -> 'a) -> Gramext.g_entry 'te -> 'a -> 'a;
- (** [Grammar.fold_entry f e init] computes [(f eN .. (f e2 (f e1 init)))],
- where [e1 .. eN] are [e] and transitively all entries called by [e].
- The order in which the entries are passed to [f] is the order they
- appear in each entry. Each entry is passed only once. *)
-
-(**/**)
-
-(*** deprecated since version 3.05; use rather the functor GMake *)
-module type LexerType = sig value lexer : Token.lexer; end;
-module Make (L : LexerType) : S with type te = Token.t;
-(*** deprecated since version 3.05; use rather the function gcreate *)
-value create : Token.lexer -> g;
-
-(*** For system use *)
-
-value loc_of_token_interval : int -> int -> (int * int);
-value extend :
- list
- (Gramext.g_entry 'te * option Gramext.position *
- list
- (option string * option Gramext.g_assoc *
- list (list (Gramext.g_symbol 'te) * Gramext.g_action))) ->
- unit;
-value delete_rule : Entry.e 'a -> list (Gramext.g_symbol Token.t) -> unit;
-
-value parse_top_symb :
- Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Stream.t 'te -> Obj.t;
-value symb_failed_txt :
- Gramext.g_entry 'te -> Gramext.g_symbol 'te -> Gramext.g_symbol 'te ->
- string;
diff --git a/camlp4/lib/plexer.ml b/camlp4/lib/plexer.ml
deleted file mode 100644
index 329380b267..0000000000
--- a/camlp4/lib/plexer.ml
+++ /dev/null
@@ -1,1006 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-open Stdpp;
-open Token;
-
-value no_quotations = ref False;
-
-(* The string buffering machinery *)
-
-value buff = ref (String.create 80);
-value store len x =
- do {
- if len >= String.length buff.val then
- buff.val := buff.val ^ String.create (String.length buff.val)
- else ();
- buff.val.[len] := x;
- succ len
- }
-;
-value mstore len s =
- add_rec len 0 where rec add_rec len i =
- if i == String.length s then len else add_rec (store len s.[i]) (succ i)
-;
-value get_buff len = String.sub buff.val 0 len;
-
-(* The lexer *)
-
-value stream_peek_nth n strm =
- loop n (Stream.npeek n strm) where rec loop n =
- fun
- [ [] -> None
- | [x] -> if n == 1 then Some x else None
- | [_ :: l] -> loop (n - 1) l ]
-;
-
-value rec ident len =
- parser
- [ [: `('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '0'..'9' | '_' | ''' as
- c)
- ;
- s :] ->
- ident (store len c) s
- | [: :] -> len ]
-and ident2 len =
- parser
- [ [: `('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
- '%' | '.' | ':' | '<' | '>' | '|' | '$' as
- c)
- ;
- s :] ->
- ident2 (store len c) s
- | [: :] -> len ]
-and ident3 len =
- parser
- [ [: `('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' |
- '/' | ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | ''' |
- '$' as
- c)
- ;
- s :] ->
- ident3 (store len c) s
- | [: :] -> len ]
-and base_number len =
- parser
- [ [: `'o' | 'O'; s :] -> digits octal (store len 'o') s
- | [: `'x' | 'X'; s :] -> digits hexa (store len 'x') s
- | [: `'b' | 'B'; s :] -> digits binary (store len 'b') s
- | [: a = number len :] -> a ]
-and digits kind len =
- parser
- [ [: d = kind; s :] -> digits_under kind (store len d) s
- | [: :] -> raise (Stream.Error "ill-formed integer constant") ]
-and digits_under kind len =
- parser
- [ [: d = kind; s :] -> digits_under kind (store len d) s
- | [: `'_'; s :] -> digits_under kind len s
- | [: :] -> ("INT", get_buff len) ]
-and octal = parser [ [: `('0'..'7' as d) :] -> d ]
-and hexa = parser [ [: `('0'..'9' | 'a'..'f' | 'A'..'F' as d) :] -> d ]
-and binary = parser [ [: `('0'..'1' as d) :] -> d ]
-and number len =
- parser
- [ [: `('0'..'9' as c); s :] -> number (store len c) s
- | [: `'_'; s :] -> number len s
- | [: `'.'; s :] -> decimal_part (store len '.') s
- | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
- | [: `'l' :] -> ("INT32", get_buff len)
- | [: `'L' :] -> ("INT64", get_buff len)
- | [: `'n' :] -> ("NATIVEINT", get_buff len)
- | [: :] -> ("INT", get_buff len) ]
-and decimal_part len =
- parser
- [ [: `('0'..'9' as c); s :] -> decimal_part (store len c) s
- | [: `'_'; s :] -> decimal_part len s
- | [: `'e' | 'E'; s :] -> exponent_part (store len 'E') s
- | [: :] -> ("FLOAT", get_buff len) ]
-and exponent_part len =
- parser
- [ [: `('+' | '-' as c); s :] -> end_exponent_part (store len c) s
- | [: a = end_exponent_part len :] -> a ]
-and end_exponent_part len =
- parser
- [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s
- | [: :] -> raise (Stream.Error "ill-formed floating-point constant") ]
-and end_exponent_part_under len =
- parser
- [ [: `('0'..'9' as c); s :] -> end_exponent_part_under (store len c) s
- | [: `'_'; s :] -> end_exponent_part_under len s
- | [: :] -> ("FLOAT", get_buff len) ]
-;
-
-value error_on_unknown_keywords = ref False;
-value err loc msg = raise_with_loc loc (Token.Error msg);
-
-(*
-value next_token_fun dfa find_kwd =
- let keyword_or_error loc s =
- try (("", find_kwd s), loc) with
- [ Not_found ->
- if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s)
- else (("", s), loc) ]
- in
- let rec next_token =
- parser bp
- [ [: `' ' | '\010' | '\013' | '\t' | '\026' | '\012'; s :] ->
- next_token s
- | [: `'('; s :] -> left_paren bp s
- | [: `'#'; s :] -> do { spaces_tabs s; linenum bp s }
- | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] ->
- let id = get_buff (ident (store 0 c) s) in
- let loc = (bp, Stream.count s) in
- (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc)
- | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] ->
- let id = get_buff (ident (store 0 c) s) in
- let loc = (bp, Stream.count s) in
- (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc)
- | [: `('1'..'9' as c); s :] ->
- let tok = number (store 0 c) s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'0'; s :] ->
- let tok = base_number (store 0 '0') s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'''; s :] ->
- match Stream.npeek 3 s with
- [ [_; '''; _] | ['\\'; _; _] | ['\x0D'; '\x0A'; '''] ->
- let tok = ("CHAR", get_buff (char bp 0 s)) in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | _ -> keyword_or_error (bp, Stream.count s) "'" ]
- | [: `'"'; s :] ->
- let tok = ("STRING", get_buff (string bp 0 s)) in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'$'; s :] ->
- let tok = dollar bp 0 s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c);
- s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id
- | [: `('~' as c);
- a =
- parser
- [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep ->
- (("TILDEIDENT", get_buff len), (bp, ep))
- | [: s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id ] :] ->
- a
- | [: `('?' as c);
- a =
- parser
- [ [: `('a'..'z' as c); len = ident (store 0 c) :] ep ->
- (("QUESTIONIDENT", get_buff len), (bp, ep))
- | [: s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id ] :] ->
- a
- | [: `'<'; s :] -> less bp s
- | [: `(':' as c1);
- len =
- parser
- [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2
- | [: :] -> store 0 c1 ] :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `('>' | '|' as c1);
- len =
- parser
- [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
- | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `('[' | '{' as c1); s :] ->
- let len =
- match Stream.npeek 2 s with
- [ ['<'; '<' | ':'] -> store 0 c1
- | _ ->
- match s with parser
- [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
- | [: :] -> store 0 c1 ] ]
- in
- let ep = Stream.count s in
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `'.';
- id =
- parser
- [ [: `'.' :] -> ".."
- | [: :] -> if ssd && after_space then " ." else "." ] :] ep ->
- keyword_or_error (bp, ep) id
- | [: `';';
- id =
- parser
- [ [: `';' :] -> ";;"
- | [: :] -> ";" ] :] ep ->
- keyword_or_error (bp, ep) id
- | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep))
- | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c)
- | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ]
- and less bp strm =
- if no_quotations.val then
- match strm with parser
- [ [: len = ident2 (store 0 '<') :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id ]
- else
- match strm with parser
- [ [: `'<'; len = quotation bp 0 :] ep ->
- (("QUOTATION", ":" ^ get_buff len), (bp, ep))
- | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
- `'<' ? "character '<' expected"; len = quotation bp 0 :] ep ->
- (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep))
- | [: len = ident2 (store 0 '<') :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id ]
- and string bp len =
- parser
- [ [: `'"' :] -> len
- | [: `'\\'; `c; s :] -> string bp (store (store len '\\') c) s
- | [: `c; s :] -> string bp (store len c) s
- | [: :] ep -> err (bp, ep) "string not terminated" ]
- and char bp len =
- parser
- [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len
- | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s
- | [: `c; s :] -> char bp (store len c) s
- | [: :] ep -> err (bp, ep) "char not terminated" ]
- and dollar bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s
- | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
- | [: `':'; s :] ->
- let k = get_buff len in
- ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: s :] ->
- if dfa then
- match s with parser
- [ [: `c :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- else ("", get_buff (ident2 (store 0 '$') s)) ]
- and maybe_locate bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
- | [: `':'; s :] ->
- ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and antiquot bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
- antiquot bp (store len c) s
- | [: `':'; s :] ->
- let k = get_buff len in
- ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and locate_or_antiquot_rest bp len =
- parser
- [ [: `'$' :] -> get_buff len
- | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s
- | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and quotation bp len =
- parser
- [ [: `'>'; s :] -> maybe_end_quotation bp len s
- | [: `'<'; s :] ->
- quotation bp (maybe_nested_quotation bp (store len '<') s) s
- | [: `'\\';
- len =
- parser
- [ [: `('>' | '<' | '\\' as c) :] -> store len c
- | [: :] -> store len '\\' ];
- s :] ->
- quotation bp len s
- | [: `c; s :] -> quotation bp (store len c) s
- | [: :] ep -> err (bp, ep) "quotation not terminated" ]
- and maybe_nested_quotation bp len =
- parser
- [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
- | [: `':'; len = ident (store len ':');
- a =
- parser
- [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
- | [: :] -> len ] :] ->
- a
- | [: :] -> len ]
- and maybe_end_quotation bp len =
- parser
- [ [: `'>' :] -> len
- | [: a = quotation bp (store len '>') :] -> a ]
- and left_paren bp =
- parser
- [ [: `'*'; _ = comment bp; a = next_token True :] -> a
- | [: :] ep -> keyword_or_error (bp, ep) "(" ]
- and comment bp =
- parser
- [ [: `'('; s :] -> left_paren_in_comment bp s
- | [: `'*'; s :] -> star_in_comment bp s
- | [: `'"'; _ = string bp 0; s :] -> comment bp s
- | [: `'''; s :] -> quote_in_comment bp s
- | [: `c; s :] -> comment bp s
- | [: :] ep -> err (bp, ep) "comment not terminated" ]
- and quote_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: `'\013'; s :] -> quote_cr_in_comment bp s
- | [: `'\\'; s :] -> quote_antislash_in_comment bp s
- | [: `'('; s :] -> quote_left_paren_in_comment bp s
- | [: `'*'; s :] -> quote_star_in_comment bp s
- | [: `'"'; s :] -> quote_doublequote_in_comment bp s
- | [: `_; s :] -> quote_any_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_any_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: s :] -> comment bp s ]
- and quote_cr_in_comment bp =
- parser
- [ [: `'\010'; s :] -> quote_any_in_comment bp s
- | [: s :] -> quote_any_in_comment bp s ]
- and quote_left_paren_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: s :] -> left_paren_in_comment bp s ]
- and quote_star_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: s :] -> star_in_comment bp s ]
- and quote_doublequote_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: _ = string bp 0; s :] -> comment bp s ]
- and quote_antislash_in_comment bp =
- parser
- [ [: `'''; s :] -> quote_antislash_quote_in_comment bp s
- | [: `('\\' | '"' | 'n' | 't' | 'b' | 'r'); s :] ->
- quote_any_in_comment bp s
- | [: `('0'..'9'); s :] -> quote_antislash_digit_in_comment bp s
- | [: `'x'; s :] -> quote_antislash_x_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_antislash_quote_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: s :] -> quote_in_comment bp s ]
- and quote_antislash_digit_in_comment bp =
- parser
- [ [: `('0'..'9'); s :] -> quote_antislash_digit2_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_antislash_digit2_in_comment bp =
- parser
- [ [: `('0'..'9'); s :] -> quote_any_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_antislash_x_in_comment bp =
- parser
- [ [: _ = hexa; s :] -> quote_antislash_x_digit_in_comment bp s
- | [: s :] -> comment bp s ]
- and quote_antislash_x_digit_in_comment bp =
- parser
- [ [: _ = hexa; s :] -> quote_any_in_comment bp s
- | [: s :] -> comment bp s ]
- and left_paren_in_comment bp =
- parser
- [ [: `'*'; s :] -> do { comment bp s; comment bp s }
- | [: a = comment bp :] -> a ]
- and star_in_comment bp =
- parser
- [ [: `')' :] -> ()
- | [: a = comment bp :] -> a ]
- and linedir n s =
- match stream_peek_nth n s with
- [ Some (' ' | '\t') -> linedir (n + 1) s
- | Some ('0'..'9') -> linedir_digits (n + 1) s
- | _ -> False ]
- and linedir_digits n s =
- match stream_peek_nth n s with
- [ Some ('0'..'9') -> linedir_digits (n + 1) s
- | _ -> linedir_quote n s ]
- and linedir_quote n s =
- match stream_peek_nth n s with
- [ Some (' ' | '\t') -> linedir_quote (n + 1) s
- | Some '"' -> True
- | _ -> False ]
- and any_to_nl =
- parser
- [ [: `'\013' | '\010' :] ep -> bolpos.val := ep
- | [: `_; s :] -> any_to_nl s
- | [: :] -> () ]
- in
- fun cstrm ->
- try
- let glex = glexr.val in
- let comm_bp = Stream.count cstrm in
- let r = next_token False cstrm in
- do {
- match glex.tok_comm with
- [ Some list ->
- if fst (snd r) > comm_bp then
- let comm_loc = (comm_bp, fst (snd r)) in
- glex.tok_comm := Some [comm_loc :: list]
- else ()
- | None -> () ];
- r
- }
- with
- [ Stream.Error str ->
- err (Stream.count cstrm, Stream.count cstrm + 1) str ]
-;
-*)
-
-value next_token_fun dfa ssd find_kwd bolpos glexr =
- let keyword_or_error loc s =
- try (("", find_kwd s), loc) with
- [ Not_found ->
- if error_on_unknown_keywords.val then err loc ("illegal token: " ^ s)
- else (("", s), loc) ] in
- let error_if_keyword ( ((_,id), loc) as a) =
- try do {
- ignore(find_kwd id);
- err loc ("illegal use of a keyword as a label: " ^ id) }
- with [ Not_found -> a ]
- in
- let rec next_token after_space =
- parser bp
- [ [: `'\010' | '\013'; s :] ep ->
- do { bolpos.val := ep; next_token True s }
- | [: `' ' | '\t' | '\026' | '\012'; s :] -> next_token True s
- | [: `'#' when bp = bolpos.val; s :] ->
- if linedir 1 s then do { any_to_nl s; next_token True s }
- else keyword_or_error (bp, bp + 1) "#"
- | [: `'('; s :] -> left_paren bp s
- | [: `('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c); s :] ->
- let id = get_buff (ident (store 0 c) s) in
- let loc = (bp, Stream.count s) in
- (try ("", find_kwd id) with [ Not_found -> ("UIDENT", id) ], loc)
- | [: `('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c); s :] ->
- let id = get_buff (ident (store 0 c) s) in
- let loc = (bp, Stream.count s) in
- (try ("", find_kwd id) with [ Not_found -> ("LIDENT", id) ], loc)
- | [: `('1'..'9' as c); s :] ->
- let tok = number (store 0 c) s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'0'; s :] ->
- let tok = base_number (store 0 '0') s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'''; s :] ->
- match Stream.npeek 2 s with
- [ [_; '''] | ['\\'; _] ->
- let tok = ("CHAR", get_buff (char bp 0 s)) in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | _ -> keyword_or_error (bp, Stream.count s) "'" ]
- | [: `'"'; s :] ->
- let tok = ("STRING", get_buff (string bp 0 s)) in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `'$'; s :] ->
- let tok = dollar bp 0 s in
- let loc = (bp, Stream.count s) in
- (tok, loc)
- | [: `('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c);
- s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id
- | [: `('~' as c);
- a =
- parser
- [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep ->
- let id = get_buff len in
- match s with parser
- [ [: `':' :] eb -> error_if_keyword (("LABEL", id), (bp,ep))
- | [: :] -> error_if_keyword (("TILDEIDENT", id), (bp, ep)) ]
- | [: s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id ] :] ->
- a
-
- | [: `('?' as c);
- a =
- parser
- [ [: `('a'..'z' as c); len = ident (store 0 c); s :] ep ->
- let id = get_buff len in
- match s with parser
- [ [: `':' :] eb -> error_if_keyword (("OPTLABEL", id), (bp,ep))
- | [: :] -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep)) ]
- | [: s :] ->
- let id = get_buff (ident2 (store 0 c) s) in
- keyword_or_error (bp, Stream.count s) id ] :] ->
- a
- | [: `'<'; s :] -> less bp s
- | [: `(':' as c1);
- len =
- parser
- [ [: `(']' | ':' | '=' | '>' as c2) :] -> store (store 0 c1) c2
- | [: :] -> store 0 c1 ] :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `('>' | '|' as c1);
- len =
- parser
- [ [: `(']' | '}' as c2) :] -> store (store 0 c1) c2
- | [: a = ident2 (store 0 c1) :] -> a ] :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `('[' | '{' as c1); s :] ->
- let len =
- match Stream.npeek 2 s with
- [ ['<'; '<' | ':'] -> store 0 c1
- | _ ->
- match s with parser
- [ [: `('|' | '<' | ':' as c2) :] -> store (store 0 c1) c2
- | [: :] -> store 0 c1 ] ]
- in
- let ep = Stream.count s in
- let id = get_buff len in
- keyword_or_error (bp, ep) id
- | [: `'.';
- id =
- parser
- [ [: `'.' :] -> ".."
- | [: :] -> if ssd && after_space then " ." else "." ] :] ep ->
- keyword_or_error (bp, ep) id
- | [: `';';
- id =
- parser
- [ [: `';' :] -> ";;"
- | [: :] -> ";" ] :] ep ->
- keyword_or_error (bp, ep) id
- | [: `'\\'; s :] ep -> (("LIDENT", get_buff (ident3 0 s)), (bp, ep))
- | [: `c :] ep -> keyword_or_error (bp, ep) (String.make 1 c)
- | [: _ = Stream.empty :] -> (("EOI", ""), (bp, succ bp)) ]
- and less bp strm =
- if no_quotations.val then
- match strm with parser
- [ [: len = ident2 (store 0 '<') :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id ]
- else
- match strm with parser
- [ [: `'<'; len = quotation bp 0 :] ep ->
- (("QUOTATION", ":" ^ get_buff len), (bp, ep))
- | [: `':'; i = parser [: len = ident 0 :] -> get_buff len;
- `'<' ? "character '<' expected"; len = quotation bp 0 :] ep ->
- (("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep))
- | [: len = ident2 (store 0 '<') :] ep ->
- let id = get_buff len in
- keyword_or_error (bp, ep) id ]
- and string bp len =
- parser
- [ [: `'"' :] -> len
- | [: `'\\'; `c; s :] ep -> string bp (store (store len '\\') c) s
- | [: `c; s :] -> string bp (store len c) s
- | [: :] ep -> err (bp, ep) "string not terminated" ]
- and char bp len =
- parser
- [ [: `'''; s :] -> if len = 0 then char bp (store len ''') s else len
- | [: `'\\'; `c; s :] -> char bp (store (store len '\\') c) s
- | [: `c; s :] -> char bp (store len c) s
- | [: :] ep -> err (bp, ep) "char not terminated" ]
- and dollar bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('a'..'z' | 'A'..'Z' as c); s :] -> antiquot bp (store len c) s
- | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
- | [: `':'; s :] ->
- let k = get_buff len in
- ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: s :] ->
- if dfa then
- match s with parser
- [ [: `c :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- else ("", get_buff (ident2 (store 0 '$') s)) ]
- and maybe_locate bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('0'..'9' as c); s :] -> maybe_locate bp (store len c) s
- | [: `':'; s :] ->
- ("LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and antiquot bp len =
- parser
- [ [: `'$' :] -> ("ANTIQUOT", ":" ^ get_buff len)
- | [: `('a'..'z' | 'A'..'Z' | '0'..'9' as c); s :] ->
- antiquot bp (store len c) s
- | [: `':'; s :] ->
- let k = get_buff len in
- ("ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 s)
- | [: `'\\'; `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: `c; s :] ->
- ("ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s)
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and locate_or_antiquot_rest bp len =
- parser
- [ [: `'$' :] -> get_buff len
- | [: `'\\'; `c; s :] -> locate_or_antiquot_rest bp (store len c) s
- | [: `c; s :] -> locate_or_antiquot_rest bp (store len c) s
- | [: :] ep -> err (bp, ep) "antiquotation not terminated" ]
- and quotation bp len =
- parser
- [ [: `'>'; s :] -> maybe_end_quotation bp len s
- | [: `'<'; s :] ->
- quotation bp (maybe_nested_quotation bp (store len '<') s) s
- | [: `'\\';
- len =
- parser
- [ [: `('>' | '<' | '\\' as c) :] -> store len c
- | [: :] -> store len '\\' ];
- s :] ->
- quotation bp len s
- | [: `c; s :] -> quotation bp (store len c) s
- | [: :] ep -> err (bp, ep) "quotation not terminated" ]
- and maybe_nested_quotation bp len =
- parser
- [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
- | [: `':'; len = ident (store len ':');
- a =
- parser
- [ [: `'<'; s :] -> mstore (quotation bp (store len '<') s) ">>"
- | [: :] -> len ] :] ->
- a
- | [: :] -> len ]
- and maybe_end_quotation bp len =
- parser
- [ [: `'>' :] -> len
- | [: a = quotation bp (store len '>') :] -> a ]
- and left_paren bp =
- parser
- [ [: `'*'; _ = comment bp; a = next_token True :] -> a
- | [: :] ep -> keyword_or_error (bp, ep) "(" ]
- and comment bp =
- parser
- [ [: `'('; s :] -> left_paren_in_comment bp s
- | [: `'*'; s :] -> star_in_comment bp s
- | [: `'"'; _ = string bp 0; s :] -> comment bp s
- | [: `'''; s :] -> quote_in_comment bp s
- | [: `c; s :] -> comment bp s
- | [: :] ep -> err (bp, ep) "comment not terminated" ]
- and quote_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: `'\\'; s :] -> quote_antislash_in_comment bp 0 s
- | [: s :] ->
- do {
- match Stream.npeek 2 s with
- [ [_; '''] -> do { Stream.junk s; Stream.junk s }
- | _ -> () ];
- comment bp s
- } ]
- and quote_any_in_comment bp =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: a = comment bp :] -> a ]
- and quote_antislash_in_comment bp len =
- parser
- [ [: `'''; s :] -> comment bp s
- | [: `'\\' | '"' | 'n' | 't' | 'b' | 'r'; s :] ->
- quote_any_in_comment bp s
- | [: `'0'..'9'; s :] -> quote_antislash_digit_in_comment bp s
- | [: a = comment bp :] -> a ]
- and quote_antislash_digit_in_comment bp =
- parser
- [ [: `'0'..'9'; s :] -> quote_antislash_digit2_in_comment bp s
- | [: a = comment bp :] -> a ]
- and quote_antislash_digit2_in_comment bp =
- parser
- [ [: `'0'..'9'; s :] -> quote_any_in_comment bp s
- | [: a = comment bp :] -> a ]
- and left_paren_in_comment bp =
- parser
- [ [: `'*'; s :] -> do { comment bp s; comment bp s }
- | [: a = comment bp :] -> a ]
- and star_in_comment bp =
- parser
- [ [: `')' :] -> ()
- | [: a = comment bp :] -> a ]
- and linedir n s =
- match stream_peek_nth n s with
- [ Some (' ' | '\t') -> linedir (n + 1) s
- | Some ('0'..'9') -> linedir_digits (n + 1) s
- | _ -> False ]
- and linedir_digits n s =
- match stream_peek_nth n s with
- [ Some ('0'..'9') -> linedir_digits (n + 1) s
- | _ -> linedir_quote n s ]
- and linedir_quote n s =
- match stream_peek_nth n s with
- [ Some (' ' | '\t') -> linedir_quote (n + 1) s
- | Some '"' -> True
- | _ -> False ]
- and any_to_nl =
- parser
- [ [: `'\013' | '\010' :] ep -> bolpos.val := ep
- | [: `_; s :] -> any_to_nl s
- | [: :] -> () ]
- in
- fun cstrm ->
- try
- let glex = glexr.val in
- let comm_bp = Stream.count cstrm in
- let r = next_token False cstrm in
- do {
- match glex.tok_comm with
- [ Some list ->
- if fst (snd r) > comm_bp then
- let comm_loc = (comm_bp, fst (snd r)) in
- glex.tok_comm := Some [comm_loc :: list]
- else ()
- | None -> () ];
- r
- }
- with
- [ Stream.Error str ->
- err (Stream.count cstrm, Stream.count cstrm + 1) str ]
-;
-
-
-value dollar_for_antiquotation = ref True;
-value specific_space_dot = ref False;
-
-value func kwd_table glexr =
- let bolpos = ref 0 in
- let find = Hashtbl.find kwd_table in
- let dfa = dollar_for_antiquotation.val in
- let ssd = specific_space_dot.val in
- Token.lexer_func_of_parser (next_token_fun dfa ssd find bolpos glexr)
-;
-
-value rec check_keyword_stream =
- parser [: _ = check; _ = Stream.empty :] -> True
-and check =
- parser
- [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' | '\248'..'\255'
- ;
- s :] ->
- check_ident s
- | [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
- '%' | '.'
- ;
- s :] ->
- check_ident2 s
- | [: `'<'; s :] ->
- match Stream.npeek 1 s with
- [ [':' | '<'] -> ()
- | _ -> check_ident2 s ]
- | [: `':';
- _ =
- parser
- [ [: `']' | ':' | '=' | '>' :] -> ()
- | [: :] -> () ] :] ep ->
- ()
- | [: `'>' | '|';
- _ =
- parser
- [ [: `']' | '}' :] -> ()
- | [: a = check_ident2 :] -> a ] :] ->
- ()
- | [: `'[' | '{'; s :] ->
- match Stream.npeek 2 s with
- [ ['<'; '<' | ':'] -> ()
- | _ ->
- match s with parser
- [ [: `'|' | '<' | ':' :] -> ()
- | [: :] -> () ] ]
- | [: `';';
- _ =
- parser
- [ [: `';' :] -> ()
- | [: :] -> () ] :] ->
- ()
- | [: `_ :] -> () ]
-and check_ident =
- parser
- [ [: `'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '0'..'9' | '_' | '''
- ;
- s :] ->
- check_ident s
- | [: :] -> () ]
-and check_ident2 =
- parser
- [ [: `'!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' |
- '%' | '.' | ':' | '<' | '>' | '|'
- ;
- s :] ->
- check_ident2 s
- | [: :] -> () ]
-;
-
-value check_keyword s =
- try check_keyword_stream (Stream.of_string s) with _ -> False
-;
-
-value error_no_respect_rules p_con p_prm =
- raise
- (Token.Error
- ("the token " ^
- (if p_con = "" then "\"" ^ p_prm ^ "\""
- else if p_prm = "" then p_con
- else p_con ^ " \"" ^ p_prm ^ "\"") ^
- " does not respect Plexer rules"))
-;
-
-value error_ident_and_keyword p_con p_prm =
- raise
- (Token.Error
- ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^
- " and as keyword"))
-;
-
-value using_token kwd_table ident_table (p_con, p_prm) =
- match p_con with
- [ "" ->
- if not (Hashtbl.mem kwd_table p_prm) then
- if check_keyword p_prm then
- if Hashtbl.mem ident_table p_prm then
- error_ident_and_keyword (Hashtbl.find ident_table p_prm) p_prm
- else Hashtbl.add kwd_table p_prm p_prm
- else error_no_respect_rules p_con p_prm
- else ()
- | "LIDENT" ->
- if p_prm = "" then ()
- else
- match p_prm.[0] with
- [ 'A'..'Z' -> error_no_respect_rules p_con p_prm
- | _ ->
- if Hashtbl.mem kwd_table p_prm then
- error_ident_and_keyword p_con p_prm
- else Hashtbl.add ident_table p_prm p_con ]
- | "UIDENT" ->
- if p_prm = "" then ()
- else
- match p_prm.[0] with
- [ 'a'..'z' -> error_no_respect_rules p_con p_prm
- | _ ->
- if Hashtbl.mem kwd_table p_prm then
- error_ident_and_keyword p_con p_prm
- else Hashtbl.add ident_table p_prm p_con ]
- | "INT" | "INT32" | "INT64" | "NATIVEINT"
- | "FLOAT" | "CHAR" | "STRING"
- | "TILDEIDENT" | "QUESTIONIDENT" | "LABEL" | "OPTLABEL"
- | "QUOTATION" | "ANTIQUOT" | "LOCATE" | "EOI" ->
- ()
- | _ ->
- raise
- (Token.Error
- ("the constructor \"" ^ p_con ^
- "\" is not recognized by Plexer")) ]
-;
-
-value removing_token kwd_table ident_table (p_con, p_prm) =
- match p_con with
- [ "" -> Hashtbl.remove kwd_table p_prm
- | "LIDENT" | "UIDENT" ->
- if p_prm <> "" then Hashtbl.remove ident_table p_prm else ()
- | _ -> () ]
-;
-
-value text =
- fun
- [ ("", t) -> "'" ^ t ^ "'"
- | ("LIDENT", "") -> "lowercase identifier"
- | ("LIDENT", t) -> "'" ^ t ^ "'"
- | ("UIDENT", "") -> "uppercase identifier"
- | ("UIDENT", t) -> "'" ^ t ^ "'"
- | ("INT", "") -> "integer"
- | ("INT32", "") -> "32 bits integer"
- | ("INT64", "") -> "64 bits integer"
- | ("NATIVEINT", "") -> "native integer"
- | (("INT" | "INT32" | "NATIVEINT"), s) -> "'" ^ s ^ "'"
- | ("FLOAT", "") -> "float"
- | ("STRING", "") -> "string"
- | ("CHAR", "") -> "char"
- | ("QUOTATION", "") -> "quotation"
- | ("ANTIQUOT", k) -> "antiquot \"" ^ k ^ "\""
- | ("LOCATE", "") -> "locate"
- | ("EOI", "") -> "end of input"
- | (con, "") -> con
- | (con, prm) -> con ^ " \"" ^ prm ^ "\"" ]
-;
-
-value eq_before_colon p e =
- loop 0 where rec loop i =
- if i == String.length e then
- failwith "Internal error in Plexer: incorrect ANTIQUOT"
- else if i == String.length p then e.[i] == ':'
- else if p.[i] == e.[i] then loop (i + 1)
- else False
-;
-
-value after_colon e =
- try
- let i = String.index e ':' in
- String.sub e (i + 1) (String.length e - i - 1)
- with
- [ Not_found -> "" ]
-;
-
-value tok_match =
- fun
- [ ("ANTIQUOT", p_prm) ->
- fun
- [ ("ANTIQUOT", prm) when eq_before_colon p_prm prm -> after_colon prm
- | _ -> raise Stream.Failure ]
- | tok -> Token.default_match tok ]
-;
-
-value gmake () =
- let kwd_table = Hashtbl.create 301 in
- let id_table = Hashtbl.create 301 in
- let glexr =
- ref
- {tok_func = fun []; tok_using = fun []; tok_removing = fun [];
- tok_match = fun []; tok_text = fun []; tok_comm = None}
- in
- let glex =
- {tok_func = func kwd_table glexr;
- tok_using = using_token kwd_table id_table;
- tok_removing = removing_token kwd_table id_table; tok_match = tok_match;
- tok_text = text; tok_comm = None}
- in
- do { glexr.val := glex; glex }
-;
-
-value tparse =
- fun
- [ ("ANTIQUOT", p_prm) ->
- let p =
- parser
- [: `("ANTIQUOT", prm) when eq_before_colon p_prm prm :] ->
- after_colon prm
- in
- Some p
- | _ -> None ]
-;
-
-value make () =
- let kwd_table = Hashtbl.create 301 in
- let id_table = Hashtbl.create 301 in
- let glexr =
- ref
- {tok_func = fun []; tok_using = fun []; tok_removing = fun [];
- tok_match = fun []; tok_text = fun []; tok_comm = None}
- in
- {func = func kwd_table glexr; using = using_token kwd_table id_table;
- removing = removing_token kwd_table id_table; tparse = tparse; text = text}
-;
diff --git a/camlp4/lib/plexer.mli b/camlp4/lib/plexer.mli
deleted file mode 100644
index 32d8fe6b8e..0000000000
--- a/camlp4/lib/plexer.mli
+++ /dev/null
@@ -1,72 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** A lexical analyzer. *)
-
-value gmake : unit -> Token.glexer Token.t;
- (** Some lexer provided. See the module [Token]. The tokens returned
- follow the Objective Caml and the Revised syntax lexing rules.
-
- The meaning of the tokens are:
-- * [("", s)] is the keyword [s].
-- * [("LIDENT", s)] is the ident [s] starting with a lowercase letter.
-- * [("UIDENT", s)] is the ident [s] starting with an uppercase letter.
-- * [("INT", s)] (resp. ["INT32"], ["INT64"] and ["NATIVEINT"])
- is an integer constant whose string source is [s].
-- * [("FLOAT", s)] is a float constant whose string source is [s].
-- * [("STRING", s)] is the string constant [s].
-- * [("CHAR", s)] is the character constant [s].
-- * [("QUOTATION", "t:s")] is a quotation [t] holding the string [s].
-- * [("ANTIQUOT", "t:s")] is an antiquotation [t] holding the string [s].
-- * [("LOCATE", "i:s")] is a location directive at pos [i] holding [s].
-- * [("EOI", "")] is the end of input.
-
- The associated token patterns in the EXTEND statement hold the
- same names than the first string (constructor name) of the tokens
- expressions above.
-
- Warning: the string associated with the constructor [STRING] is
- the string found in the source without any interpretation. In
- particular, the backslashes are not interpreted. For example, if
- the input is ["\n"] the string is *not* a string with one
- element containing the character "return", but a string of two
- elements: the backslash and the character ["n"]. To interpret
- a string use the function [Token.eval_string]. Same thing for
- the constructor [CHAR]: to get the character, don't get the
- first character of the string, but use the function
- [Token.eval_char].
-
- The lexer do not use global (mutable) variables: instantiations
- of [Plexer.gmake ()] do not perturb each other. *)
-
-value dollar_for_antiquotation : ref bool;
- (** When True (default), the next call to [Plexer.make ()] returns a
- lexer where the dollar sign is used for antiquotations. If False,
- the dollar sign can be used as token. *)
-
-value specific_space_dot : ref bool;
- (** When False (default), the next call to [Plexer.make ()] returns a
- lexer where the dots can be preceded by spaces. If True, dots
- preceded by spaces return the keyword " ." (space dot), otherwise
- return the keyword "." (dot). *)
-
-value no_quotations : ref bool;
- (** When True, all lexers built by [Plexer.make ()] do not lex the
- quotation syntax any more. Default is False (quotations are
- lexed). *)
-
-(**/**)
-
-(* deprecated since version 3.05; use rather function gmake *)
-value make : unit -> Token.lexer;
diff --git a/camlp4/lib/stdpp.ml b/camlp4/lib/stdpp.ml
deleted file mode 100644
index a89cb15d8e..0000000000
--- a/camlp4/lib/stdpp.ml
+++ /dev/null
@@ -1,79 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-exception Exc_located of (int * int) and exn;
-
-value raise_with_loc loc exc =
- match exc with
- [ Exc_located _ _ -> raise exc
- | _ -> raise (Exc_located loc exc) ]
-;
-
-value line_of_loc fname (bp, ep) =
- try
- let ic = open_in_bin fname in
- let strm = Stream.of_channel ic in
- let rec loop fname lin =
- let rec not_a_line_dir col =
- parser cnt
- [: `c; s :] ->
- if cnt < bp then
- if c = '\n' then loop fname (lin + 1)
- else not_a_line_dir (col + 1) s
- else
- let col = col - (cnt - bp) in
- (fname, lin, col, col + ep - bp)
- in
- let rec a_line_dir str n col =
- parser
- [ [: `'\n' :] -> loop str n
- | [: `_; s :] -> a_line_dir str n (col + 1) s ]
- in
- let rec spaces col =
- parser
- [ [: `' '; s :] -> spaces (col + 1) s
- | [: :] -> col ]
- in
- let rec check_string str n col =
- parser
- [ [: `'"'; col = spaces (col + 1); s :] -> a_line_dir str n col s
- | [: `c when c <> '\n'; s :] ->
- check_string (str ^ String.make 1 c) n (col + 1) s
- | [: a = not_a_line_dir col :] -> a ]
- in
- let check_quote n col =
- parser
- [ [: `'"'; s :] -> check_string "" n (col + 1) s
- | [: a = not_a_line_dir col :] -> a ]
- in
- let rec check_num n col =
- parser
- [ [: `('0'..'9' as c); s :] ->
- check_num (10 * n + Char.code c - Char.code '0') (col + 1) s
- | [: col = spaces col; s :] -> check_quote n col s ]
- in
- let begin_line =
- parser
- [ [: `'#'; col = spaces 1; s :] -> check_num 0 col s
- | [: a = not_a_line_dir 0 :] -> a ]
- in
- begin_line strm
- in
- let r = try loop fname 1 with [ Stream.Failure -> (fname, 1, bp, ep) ] in
- do { close_in ic; r }
- with
- [ Sys_error _ -> (fname, 1, bp, ep) ]
-;
-
-value loc_name = ref "loc";
diff --git a/camlp4/lib/stdpp.mli b/camlp4/lib/stdpp.mli
deleted file mode 100644
index 069e56bee3..0000000000
--- a/camlp4/lib/stdpp.mli
+++ /dev/null
@@ -1,37 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2002 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Standard definitions. *)
-
-exception Exc_located of (int * int) and exn;
- (** [Exc_located loc e] is an encapsulation of the exception [e] with
- the input location [loc]. To be used in quotation expanders
- and in grammars to specify some input location for an error.
- Do not raise this exception directly: rather use the following
- function [raise_with_loc]. *)
-
-value raise_with_loc : (int * int) -> exn -> 'a;
- (** [raise_with_loc loc e], if [e] is already the exception [Exc_located],
- re-raise it, else raise the exception [Exc_located loc e]. *)
-
-value line_of_loc : string -> (int * int) -> (string * int * int * int);
- (** [line_of_loc fname loc] reads the file [fname] up to the
- location [loc] and returns the real input file, the line number
- and the characters location in the line; the real input file
- can be different from [fname] because of possibility of line
- directives typically generated by /lib/cpp. *)
-
-value loc_name : ref string;
- (** Name of the location variable used in grammars and in the predefined
- quotations for OCaml syntax trees. Default: [loc] *)
diff --git a/camlp4/lib/token.ml b/camlp4/lib/token.ml
deleted file mode 100644
index e26798af9c..0000000000
--- a/camlp4/lib/token.ml
+++ /dev/null
@@ -1,229 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-type t = (string * string);
-type pattern = (string * string);
-
-exception Error of string;
-
-type location = (int * int);
-type location_function = int -> (int * int);
-type lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function);
-
-type glexer 'te =
- { tok_func : lexer_func 'te;
- tok_using : pattern -> unit;
- tok_removing : pattern -> unit;
- tok_match : pattern -> 'te -> string;
- tok_text : pattern -> string;
- tok_comm : mutable option (list location) }
-;
-type lexer =
- { func : lexer_func t;
- using : pattern -> unit;
- removing : pattern -> unit;
- tparse : pattern -> option (Stream.t t -> string);
- text : pattern -> string }
-;
-
-value lexer_text (con, prm) =
- if con = "" then "'" ^ prm ^ "'"
- else if prm = "" then con
- else con ^ " '" ^ prm ^ "'"
-;
-
-value locerr () = invalid_arg "Lexer: location function";
-value loct_create () = (ref (Array.create 1024 None), ref False);
-value loct_func (loct, ov) i =
- match
- if i < 0 || i >= Array.length loct.val then
- if ov.val then Some (0, 0) else None
- else Array.unsafe_get loct.val i
- with
- [ Some loc -> loc
- | _ -> locerr () ]
-;
-value loct_add (loct, ov) i loc =
- if i >= Array.length loct.val then
- let new_tmax = Array.length loct.val * 2 in
- if new_tmax < Sys.max_array_length then do {
- let new_loct = Array.create new_tmax None in
- Array.blit loct.val 0 new_loct 0 (Array.length loct.val);
- loct.val := new_loct;
- loct.val.(i) := Some loc
- }
- else ov.val := True
- else loct.val.(i) := Some loc
-;
-
-value make_stream_and_location next_token_loc =
- let loct = loct_create () in
- let ts =
- Stream.from
- (fun i ->
- let (tok, loc) = next_token_loc () in
- do { loct_add loct i loc; Some tok })
- in
- (ts, loct_func loct)
-;
-
-value lexer_func_of_parser next_token_loc cs =
- make_stream_and_location (fun () -> next_token_loc cs)
-;
-
-value lexer_func_of_ocamllex lexfun cs =
- let lb =
- Lexing.from_function
- (fun s n ->
- try do { s.[0] := Stream.next cs; 1 } with [ Stream.Failure -> 0 ])
- in
- let next_token_loc _ =
- let tok = lexfun lb in
- let loc = (Lexing.lexeme_start lb, Lexing.lexeme_end lb) in
- (tok, loc)
- in
- make_stream_and_location next_token_loc
-;
-
-(* Char and string tokens to real chars and string *)
-
-value buff = ref (String.create 80);
-value store len x =
- do {
- if len >= String.length buff.val then
- buff.val := buff.val ^ String.create (String.length buff.val)
- else ();
- buff.val.[len] := x;
- succ len
- }
-;
-value mstore len s =
- add_rec len 0 where rec add_rec len i =
- if i == String.length s then len else add_rec (store len s.[i]) (succ i)
-;
-value get_buff len = String.sub buff.val 0 len;
-
-value valch x = Char.code x - Char.code '0';
-value valch_a x = Char.code x - Char.code 'a' + 10;
-value valch_A x = Char.code x - Char.code 'A' + 10;
-
-value rec backslash s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- [ 'n' -> ('\n', i + 1)
- | 'r' -> ('\r', i + 1)
- | 't' -> ('\t', i + 1)
- | 'b' -> ('\b', i + 1)
- | '\\' -> ('\\', i + 1)
- | '"' -> ('"', i + 1)
- | ''' -> (''', i + 1)
- | '0'..'9' as c -> backslash1 (valch c) s (i + 1)
- | 'x' -> backslash1h s (i + 1)
- | _ -> raise Not_found ]
-and backslash1 cod s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- [ '0'..'9' as c -> backslash2 (10 * cod + valch c) s (i + 1)
- | _ -> raise Not_found ]
-and backslash2 cod s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- [ '0'..'9' as c -> (Char.chr (10 * cod + valch c), i + 1)
- | _ -> raise Not_found ]
-and backslash1h s i =
- if i = String.length s then raise Not_found
- else
- match s.[i] with
- [ '0'..'9' as c -> backslash2h (valch c) s (i + 1)
- | 'a'..'f' as c -> backslash2h (valch_a c) s (i + 1)
- | 'A'..'F' as c -> backslash2h (valch_A c) s (i + 1)
- | _ -> raise Not_found ]
-and backslash2h cod s i =
- if i = String.length s then ('\\', i - 2)
- else
- match s.[i] with
- [ '0'..'9' as c -> (Char.chr (16 * cod + valch c), i + 1)
- | 'a'..'f' as c -> (Char.chr (16 * cod + valch_a c), i + 1)
- | 'A'..'F' as c -> (Char.chr (16 * cod + valch_A c), i + 1)
- | _ -> raise Not_found ]
-;
-
-value rec skip_indent s i =
- if i = String.length s then i
- else
- match s.[i] with
- [ ' ' | '\t' -> skip_indent s (i + 1)
- | _ -> i ]
-;
-
-value skip_opt_linefeed s i =
- if i = String.length s then i else if s.[i] = '\010' then i + 1 else i
-;
-
-value eval_char s =
- if String.length s = 1 then s.[0]
- else if String.length s = 0 then failwith "invalid char token"
- else if s.[0] = '\\' then
- if String.length s = 2 && s.[1] = ''' then '''
- else
- try
- let (c, i) = backslash s 1 in
- if i = String.length s then c else raise Not_found
- with
- [ Not_found -> failwith "invalid char token" ]
- else failwith "invalid char token"
-;
-
-value eval_string (bp, ep) s =
- loop 0 0 where rec loop len i =
- if i = String.length s then get_buff len
- else
- let (len, i) =
- if s.[i] = '\\' then
- let i = i + 1 in
- if i = String.length s then failwith "invalid string token"
- else if s.[i] = '"' then (store len '"', i + 1)
- else
- match s.[i] with
- [ '\010' -> (len, skip_indent s (i + 1))
- | '\013' -> (len, skip_indent s (skip_opt_linefeed s (i + 1)))
- | c ->
- try
- let (c, i) = backslash s i in
- (store len c, i)
- with
- [ Not_found -> do {
- Printf.eprintf
- "Warning: char %d, Invalid backslash escape in string\n%!"
- (bp+i+1);
- (store (store len '\\') c, i + 1) } ] ]
- else (store len s.[i], i + 1)
- in
- loop len i
-;
-
-value default_match =
- fun
- [ ("ANY", "") -> fun (con, prm) -> prm
- | ("ANY", v) ->
- fun (con, prm) -> if v = prm then v else raise Stream.Failure
- | (p_con, "") ->
- fun (con, prm) -> if con = p_con then prm else raise Stream.Failure
- | (p_con, p_prm) ->
- fun (con, prm) ->
- if con = p_con && prm = p_prm then prm else raise Stream.Failure ]
-;
diff --git a/camlp4/lib/token.mli b/camlp4/lib/token.mli
deleted file mode 100644
index fbd1aefd30..0000000000
--- a/camlp4/lib/token.mli
+++ /dev/null
@@ -1,133 +0,0 @@
-(* camlp4r *)
-(***********************************************************************)
-(* *)
-(* Camlp4 *)
-(* *)
-(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
-(* *)
-(* Copyright 2001 Institut National de Recherche en Informatique et *)
-(* Automatique. Distributed only by permission. *)
-(* *)
-(***********************************************************************)
-
-(* $Id$ *)
-
-(** Lexers for Camlp4 grammars.
-
- This module defines the Camlp4 lexer type to be used in extensible
- grammars (see module [Grammar]). It also provides some useful functions
- to create lexers (this module should be renamed [Glexer] one day). *)
-
-type pattern = (string * string);
- (** Token patterns come from the EXTEND statement.
-- The first string is the constructor name (must start with
- an uppercase character). When it is empty, the second string
- is supposed to be a keyword.
-- The second string is the constructor parameter. Empty if it
- has no parameter.
-- The way tokens patterns are interpreted to parse tokens is
- done by the lexer, function [tok_match] below. *)
-
-exception Error of string;
- (** An lexing error exception to be used by lexers. *)
-
-(** {6 Lexer type} *)
-
-type location = (int * int);
-type location_function = int -> location;
- (** The type for a function associating a number of a token in a stream
- (starting from 0) to its source location. *)
-type lexer_func 'te = Stream.t char -> (Stream.t 'te * location_function);
- (** The type for a lexer function. The character stream is the input
- stream to be lexed. The result is a pair of a token stream and
- a location function for this tokens stream. *)
-
-type glexer 'te =
- { tok_func : lexer_func 'te;
- tok_using : pattern -> unit;
- tok_removing : pattern -> unit;
- tok_match : pattern -> 'te -> string;
- tok_text : pattern -> string;
- tok_comm : mutable option (list location) }
-;
- (** The type for a lexer used by Camlp4 grammars.
-- The field [tok_func] is the main lexer function. See [lexer_func]
- type above. This function may be created from a [char stream parser]
- or for an [ocamllex] function using the functions below.
-- The field [tok_using] is a function telling the lexer that the grammar
- uses this token (pattern). The lexer can check that its constructor
- is correct, and interpret some kind of tokens as keywords (to record
- them in its tables). Called by [EXTEND] statements.
-- The field [tok_removing] is a function telling the lexer that the
- grammar does not uses the given token (pattern) any more. If the
- lexer has a notion of "keywords", it can release it from its tables.
- Called by [DELETE_RULE] statements.
-- The field [tok_match] is a function taking a pattern and returning
- a function matching a token against the pattern. Warning: for
- efficency, write it as a function returning functions according
- to the values of the pattern, not a function with two parameters.
-- The field [tok_text] returns the name of some token pattern,
- used in error messages.
-- The field [tok_comm] if not None asks the lexer to record the
- locations of the comments. *)
-
-value lexer_text : pattern -> string;
- (** A simple [tok_text] function for lexers *)
-
-value default_match : pattern -> (string * string) -> string;
- (** A simple [tok_match] function for lexers, appling to token type
- [(string * string)] *)
-
-(** {6 Lexers from char stream parsers or ocamllex function}
-
- The functions below create lexer functions either from a [char stream]
- parser or for an [ocamllex] function. With the returned function [f],
- the simplest [Token.lexer] can be written:
- {[
- { Token.tok_func = f;
- Token.tok_using = (fun _ -> ());
- Token.tok_removing = (fun _ -> ());
- Token.tok_match = Token.default_match;
- Token.tok_text = Token.lexer_text }
- ]}
- Note that a better [tok_using] function should check the used tokens
- and raise [Token.Error] for incorrect ones. The other functions
- [tok_removing], [tok_match] and [tok_text] may have other implementations
- as well. *)
-
-value lexer_func_of_parser :
- (Stream.t char -> ('te * location)) -> lexer_func 'te;
- (** A lexer function from a lexer written as a char stream parser
- returning the next token and its location. *)
-value lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> lexer_func 'te;
- (** A lexer function from a lexer created by [ocamllex] *)
-
-value make_stream_and_location :
- (unit -> ('te * location)) -> (Stream.t 'te * location_function);
- (** General function *)
-
-(** {6 Useful functions} *)
-
-value eval_char : string -> char;
- (** Convert a char token, where the escape sequences (backslashes)
- remain to be interpreted; raise [Failure] if an
- incorrect backslash sequence is found; [Token.eval_char (Char.escaped c)]
- returns [c] *)
-
-value eval_string : location -> string -> string;
- (** Convert a string token, where the escape sequences (backslashes)
- remain to be interpreted; issue a warning if an incorrect
- backslash sequence is found;
- [Token.eval_string loc (String.escaped s)] returns [s] *)
-
-(**/**)
-
-(* deprecated since version 3.05; use rather type glexer *)
-type t = (string * string);
-type lexer =
- { func : lexer_func t;
- using : pattern -> unit;
- removing : pattern -> unit;
- tparse : pattern -> option (Stream.t t -> string);
- text : pattern -> string }
-;
View Lorry Controller Status