summaryrefslogtreecommitdiff
path: root/camlp4/ocaml_src/lib
diff options
context:
space:
mode:
Diffstat (limited to 'camlp4/ocaml_src/lib')
-rw-r--r--camlp4/ocaml_src/lib/.depend20
-rw-r--r--camlp4/ocaml_src/lib/Makefile48
-rw-r--r--camlp4/ocaml_src/lib/Makefile.Mac46
-rw-r--r--camlp4/ocaml_src/lib/Makefile.Mac.depend13
-rw-r--r--camlp4/ocaml_src/lib/extfold.ml124
-rw-r--r--camlp4/ocaml_src/lib/extfold.mli24
-rw-r--r--camlp4/ocaml_src/lib/extfun.ml105
-rw-r--r--camlp4/ocaml_src/lib/extfun.mli37
-rw-r--r--camlp4/ocaml_src/lib/fstream.ml84
-rw-r--r--camlp4/ocaml_src/lib/fstream.mli60
-rw-r--r--camlp4/ocaml_src/lib/gramext.ml531
-rw-r--r--camlp4/ocaml_src/lib/gramext.mli79
-rw-r--r--camlp4/ocaml_src/lib/grammar.ml1119
-rw-r--r--camlp4/ocaml_src/lib/grammar.mli200
-rw-r--r--camlp4/ocaml_src/lib/plexer.ml1258
-rw-r--r--camlp4/ocaml_src/lib/plexer.mli72
-rw-r--r--camlp4/ocaml_src/lib/stdpp.ml99
-rw-r--r--camlp4/ocaml_src/lib/stdpp.mli37
-rw-r--r--camlp4/ocaml_src/lib/token.ml223
-rw-r--r--camlp4/ocaml_src/lib/token.mli133
20 files changed, 0 insertions, 4312 deletions
diff --git a/camlp4/ocaml_src/lib/.depend b/camlp4/ocaml_src/lib/.depend
deleted file mode 100644
index 0d5adc691f..0000000000
--- a/camlp4/ocaml_src/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/ocaml_src/lib/Makefile b/camlp4/ocaml_src/lib/Makefile
deleted file mode 100644
index e19e52052b..0000000000
--- a/camlp4/ocaml_src/lib/Makefile
+++ /dev/null
@@ -1,48 +0,0 @@
-# This file has been generated by program: do not edit!
-
-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/ocaml_src/lib/Makefile.Mac b/camlp4/ocaml_src/lib/Makefile.Mac
deleted file mode 100644
index 2fc15c630d..0000000000
--- a/camlp4/ocaml_src/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. #
-# #
-#######################################################################
-
-# This file has been generated by program: do not edit!
-
-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/ocaml_src/lib/Makefile.Mac.depend b/camlp4/ocaml_src/lib/Makefile.Mac.depend
deleted file mode 100644
index 8d12e3e08a..0000000000
--- a/camlp4/ocaml_src/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/ocaml_src/lib/extfold.ml b/camlp4/ocaml_src/lib/extfold.ml
deleted file mode 100644
index 0411497f02..0000000000
--- a/camlp4/ocaml_src/lib/extfold.ml
+++ /dev/null
@@ -1,124 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-
-type ('te, 'a, 'b) t =
- 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) ->
- 'te Stream.t -> 'b
-;;
-
-type ('te, 'a, 'b) tsep =
- 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) ->
- ('te Stream.t -> unit) -> 'te Stream.t -> 'b
-;;
-
-let gen_fold0 final f e entry symbl psymb =
- let rec fold accu (strm__ : _ Stream.t) =
- match
- try Some (psymb strm__) with
- Stream.Failure -> None
- with
- Some a -> fold (f a accu) strm__
- | _ -> accu
- in
- fun (strm__ : _ Stream.t) -> let a = fold e strm__ in final a
-;;
-
-let gen_fold1 final f e entry symbl psymb =
- let rec fold accu (strm__ : _ Stream.t) =
- match
- try Some (psymb strm__) with
- Stream.Failure -> None
- with
- Some a -> fold (f a accu) strm__
- | _ -> accu
- in
- fun (strm__ : _ Stream.t) ->
- let a = psymb strm__ in
- let a =
- try fold (f a e) strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- final a
-;;
-
-let gen_fold0sep final f e entry symbl psymb psep =
- let failed =
- function
- [symb; sep] -> Grammar.symb_failed_txt entry sep symb
- | _ -> "failed"
- in
- let rec kont accu (strm__ : _ Stream.t) =
- match
- try Some (psep strm__) with
- Stream.Failure -> None
- with
- Some v ->
- let a =
- try psymb strm__ with
- Stream.Failure -> raise (Stream.Error (failed symbl))
- in
- kont (f a accu) strm__
- | _ -> accu
- in
- fun (strm__ : _ Stream.t) ->
- match
- try Some (psymb strm__) with
- Stream.Failure -> None
- with
- Some a -> final (kont (f a e) strm__)
- | _ -> e
-;;
-
-let gen_fold1sep final f e entry symbl psymb psep =
- let failed =
- function
- [symb; sep] -> Grammar.symb_failed_txt entry sep symb
- | _ -> "failed"
- in
- let parse_top =
- function
- [symb; _] -> Grammar.parse_top_symb entry symb
- | _ -> raise Stream.Failure
- in
- let rec kont accu (strm__ : _ Stream.t) =
- match
- try Some (psep strm__) with
- Stream.Failure -> None
- with
- Some v ->
- let a =
- try
- try psymb strm__ with
- Stream.Failure ->
- let a =
- try parse_top symbl strm__ with
- Stream.Failure -> raise (Stream.Error (failed symbl))
- in
- Obj.magic a
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- kont (f a accu) strm__
- | _ -> accu
- in
- fun (strm__ : _ Stream.t) ->
- let a = psymb strm__ in final (kont (f a e) strm__)
-;;
-
-let sfold0 f e = gen_fold0 (fun x -> x) f e;;
-let sfold1 f e = gen_fold1 (fun x -> x) f e;;
-let sfold0sep f e = gen_fold0sep (fun x -> x) f e;;
-let sfold1sep f e = gen_fold1sep (fun x -> x) f e;;
-
-let cons x y = x :: y;;
-let nil = [];;
-
-let slist0 entry = gen_fold0 List.rev cons nil entry;;
-let slist1 entry = gen_fold1 List.rev cons nil entry;;
-let slist0sep entry = gen_fold0sep List.rev cons nil entry;;
-let slist1sep entry = gen_fold1sep List.rev cons nil entry;;
-
-let sopt entry symbl psymb (strm__ : _ Stream.t) =
- try Some (psymb strm__) with
- Stream.Failure -> None
-;;
diff --git a/camlp4/ocaml_src/lib/extfold.mli b/camlp4/ocaml_src/lib/extfold.mli
deleted file mode 100644
index cb2824fb1d..0000000000
--- a/camlp4/ocaml_src/lib/extfold.mli
+++ /dev/null
@@ -1,24 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-
-type ('te, 'a, 'b) t =
- 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) ->
- 'te Stream.t -> 'b
-;;
-
-type ('te, 'a, 'b) tsep =
- 'te Gramext.g_entry -> 'te Gramext.g_symbol list -> ('te Stream.t -> 'a) ->
- ('te Stream.t -> unit) -> 'te Stream.t -> 'b
-;;
-
-val sfold0 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) t;;
-val sfold1 : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) t;;
-val sfold0sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) tsep;;
-val sfold1sep : ('a -> 'b -> 'b) -> 'b -> (_, 'a, 'b) tsep;;
-
-val slist0 : (_, 'a, 'a list) t;;
-val slist1 : (_, 'a, 'a list) t;;
-val slist0sep : (_, 'a, 'a list) tsep;;
-val slist1sep : (_, 'a, 'a list) tsep;;
-
-val sopt : (_, 'a, 'a option) t;;
diff --git a/camlp4/ocaml_src/lib/extfun.ml b/camlp4/ocaml_src/lib/extfun.ml
deleted file mode 100644
index f8a6b26ac5..0000000000
--- a/camlp4/ocaml_src/lib/extfun.ml
+++ /dev/null
@@ -1,105 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-(* Copyright 2001 INRIA *)
-
-(* Extensible Functions *)
-
-type ('a, 'b) t = ('a, 'b) matching list
-and ('a, 'b) matching = { patt : patt; has_when : bool; expr : ('a, 'b) expr }
-and patt =
- Eapp of patt list
- | Eacc of patt list
- | Econ of string
- | Estr of string
- | Eint of string
- | Etup of patt list
- | Evar of unit
-and ('a, 'b) expr = 'a -> 'b option
-;;
-
-exception Failure;;
-
-let empty = [];;
-
-(*** Apply ***)
-
-let rec apply_matchings a =
- function
- m :: ml ->
- begin match m.expr a with
- None -> apply_matchings a ml
- | x -> x
- end
- | [] -> None
-;;
-
-let apply ef a =
- match apply_matchings a ef with
- Some x -> x
- | None -> raise Failure
-;;
-
-(*** Trace ***)
-
-let rec list_iter_sep f s =
- function
- [] -> ()
- | [x] -> f x
- | x :: l -> f x; s (); list_iter_sep f s l
-;;
-
-let rec print_patt =
- function
- Eapp pl -> list_iter_sep print_patt2 (fun () -> print_string " ") pl
- | p -> print_patt2 p
-and print_patt2 =
- function
- Eacc pl -> list_iter_sep print_patt1 (fun () -> print_string ".") pl
- | p -> print_patt1 p
-and print_patt1 =
- function
- Econ s -> print_string s
- | Estr s -> print_string "\""; print_string s; print_string "\""
- | Eint s -> print_string s
- | Evar () -> print_string "_"
- | Etup pl ->
- print_string "(";
- list_iter_sep print_patt (fun () -> print_string ", ") pl;
- print_string ")"
- | Eapp _ | Eacc _ as p -> print_string "("; print_patt p; print_string ")"
-;;
-
-let print ef =
- List.iter
- (fun m ->
- print_patt m.patt;
- if m.has_when then print_string " when ...";
- print_newline ())
- ef
-;;
-
-(*** Extension ***)
-
-let insert_matching matchings (patt, has_when, expr) =
- let m1 = {patt = patt; has_when = has_when; expr = expr} in
- let rec loop =
- function
- 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 *)
-
-let extend ef matchings_def =
- List.fold_left insert_matching ef matchings_def
-;;
diff --git a/camlp4/ocaml_src/lib/extfun.mli b/camlp4/ocaml_src/lib/extfun.mli
deleted file mode 100644
index 2d42fe2e84..0000000000
--- a/camlp4/ocaml_src/lib/extfun.mli
+++ /dev/null
@@ -1,37 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-
-(** Extensible functions.
-
- This module implements pattern matching extensible functions.
- To extend, use syntax [pa_extfun.cmo]:
-
- [extfun e with [ pattern_matching ]] *)
-
-type ('a, 'b) t;;
- (** The type of the extensible functions of type ['a -> 'b] *)
-val empty : ('a, 'b) t;;
- (** Empty extensible function *)
-val apply : ('a, 'b) t -> 'a -> 'b;;
- (** Apply an extensible function *)
-exception Failure;;
- (** Match failure while applying an extensible function *)
-val print : ('a, 'b) t -> unit;;
- (** Print patterns in the order they are recorded *)
-
-(**/**)
-
-type ('a, 'b) matching =
- { patt : patt; has_when : bool; expr : ('a, 'b) expr }
-and patt =
- Eapp of patt list
- | Eacc of patt list
- | Econ of string
- | Estr of string
- | Eint of string
- | Etup of patt list
- | Evar of unit
-and ('a, 'b) expr = 'a -> 'b option
-;;
-
-val extend : ('a, 'b) t -> (patt * bool * ('a, 'b) expr) list -> ('a, 'b) t;;
diff --git a/camlp4/ocaml_src/lib/fstream.ml b/camlp4/ocaml_src/lib/fstream.ml
deleted file mode 100644
index 9ffdb71041..0000000000
--- a/camlp4/ocaml_src/lib/fstream.ml
+++ /dev/null
@@ -1,84 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-(* Copyright 2001 INRIA *)
-
-type 'a t = { count : int; data : 'a data Lazy.t }
-and 'a data =
- Nil
- | Cons of 'a * 'a t
- | App of 'a t * 'a t
-;;
-
-let from f =
- let rec loop i =
- {count = 0;
- data =
- lazy
- (match f i with
- Some x -> Cons (x, loop (i + 1))
- | None -> Nil)}
- in
- loop 0
-;;
-
-let 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
-;;
-
-let empty s =
- match next s with
- Some _ -> None
- | None -> Some ((), s)
-;;
-
-let nil = {count = 0; data = lazy Nil};;
-let cons a s = Cons (a, s);;
-let app s1 s2 = App (s1, s2);;
-let flazy f = {count = 0; data = Lazy.lazy_from_fun f};;
-
-let of_list l =
- List.fold_right (fun x s -> flazy (fun () -> cons x s)) l nil
-;;
-
-let of_string s =
- from (fun c -> if c < String.length s then Some s.[c] else None)
-;;
-
-let of_channel ic =
- from
- (fun _ ->
- try Some (input_char ic) with
- End_of_file -> None)
-;;
-
-let iter f =
- let rec do_rec strm =
- match next strm with
- Some (a, strm) -> let _ = f a in do_rec strm
- | None -> ()
- in
- do_rec
-;;
-
-let count s = s.count;;
-
-let count_unfrozen s =
- let 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
- in
- loop 0 s
-;;
diff --git a/camlp4/ocaml_src/lib/fstream.mli b/camlp4/ocaml_src/lib/fstream.mli
deleted file mode 100644
index d0e8f8b49c..0000000000
--- a/camlp4/ocaml_src/lib/fstream.mli
+++ /dev/null
@@ -1,60 +0,0 @@
-(* camlp4r *)
-(* This file has been generated by program: do not edit! *)
-
-(* 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 'a t;;
- (* The type of 'a functional streams *)
-val from : (int -> 'a option) -> 'a t;;
- (* [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. *)
-
-val of_list : 'a list -> 'a t;;
- (* Return the stream holding the elements of the list in the same
- order. *)
-val of_string : string -> char t;;
- (* Return the stream of the characters of the string parameter. *)
-val of_channel : in_channel -> char t;;
- (* Return the stream of the characters read from the input channel. *)
-
-val iter : ('a -> unit) -> 'a t -> unit;;
- (* [Fstream.iter f s] scans the whole stream s, applying function [f]
- in turn to each stream element encountered. *)
-
-val next : 'a t -> ('a * 'a t) option;;
- (* 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. *)
-val empty : 'a t -> (unit * 'a t) option;;
- (* Return [Some ((), s)] if the stream is empty where [s] is itself,
- else [None] *)
-val count : 'a t -> int;;
- (* Return the current count of the stream elements, i.e. the number
- of the stream elements discarded. *)
-val count_unfrozen : 'a t -> int;;
- (* Return the number of unfrozen elements in the beginning of the
- stream; useful to determine the position of a parsing error (longuest
- path). *)
-
-(*--*)
-
-val nil : 'a t;;
-type 'a data;;
-val cons : 'a -> 'a t -> 'a data;;
-val app : 'a t -> 'a t -> 'a data;;
-val flazy : (unit -> 'a data) -> 'a t;;
diff --git a/camlp4/ocaml_src/lib/gramext.ml b/camlp4/ocaml_src/lib/gramext.ml
deleted file mode 100644
index 41fdd76c19..0000000000
--- a/camlp4/ocaml_src/lib/gramext.ml
+++ /dev/null
@@ -1,531 +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. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-open Printf;;
-
-type 'te grammar =
- { gtokens : (Token.pattern, int ref) Hashtbl.t;
- mutable glexer : 'te Token.glexer }
-;;
-
-type 'te g_entry =
- { egram : 'te grammar;
- ename : string;
- mutable estart : int -> 'te Stream.t -> Obj.t;
- mutable econtinue : int -> int -> Obj.t -> 'te Stream.t -> Obj.t;
- mutable edesc : 'te g_desc }
-and 'te g_desc =
- Dlevels of 'te g_level list
- | Dparser of ('te Stream.t -> Obj.t)
-and 'te g_level =
- { assoc : g_assoc;
- lname : string option;
- lsuffix : 'te g_tree;
- lprefix : 'te g_tree }
-and g_assoc =
- NonA
- | RightA
- | LeftA
-and 'te g_symbol =
- Smeta of string * 'te g_symbol list * Obj.t
- | Snterm of 'te g_entry
- | Snterml of 'te g_entry * string
- | Slist0 of 'te g_symbol
- | Slist0sep of 'te g_symbol * 'te g_symbol
- | Slist1 of 'te g_symbol
- | Slist1sep of 'te g_symbol * 'te g_symbol
- | Sopt of 'te g_symbol
- | Sself
- | Snext
- | Stoken of Token.pattern
- | Stree of 'te g_tree
-and g_action = Obj.t
-and 'te g_tree =
- Node of 'te g_node
- | LocAct of g_action * g_action list
- | DeadEnd
-and 'te g_node =
- { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree }
-;;
-
-type position =
- First
- | Last
- | Before of string
- | After of string
- | Level of string
-;;
-
-let warning_verbose = ref true;;
-
-let rec derive_eps =
- function
- 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 =
- function
- LocAct (_, _) -> true
- | Node {node = s; brother = bro; son = son} ->
- derive_eps s && tree_derive_eps son || tree_derive_eps bro
- | DeadEnd -> false
-;;
-
-let 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
-;;
-
-let 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
-;;
-
-let 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) ->
- if !warning_verbose then
- begin
- eprintf "<W> Grammar extension: ";
- if entry_name <> "" then eprintf "in [%s], " entry_name;
- eprintf "some rule has been masked\n";
- flush stderr
- end;
- 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
- begin match try_insert s sl bro with
- Some bro ->
- let t = Node {node = s1; son = son; brother = bro} in Some t
- | None -> None
- end
- | LocAct (_, _) | DeadEnd -> None
- and insert_new =
- function
- s :: sl -> Node {node = s; son = insert_new sl; brother = DeadEnd}
- | [] -> LocAct (action, [])
- in
- insert gsymbols tree
-;;
-
-let 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";;
-
-let is_level_labelled n lev =
- match lev.lname with
- Some n1 -> n = n1
- | None -> false
-;;
-
-let 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}
-;;
-
-let empty_lev lname assoc =
- let assoc =
- match assoc with
- Some a -> a
- | None -> LeftA
- in
- {assoc = assoc; lname = lname; lsuffix = DeadEnd; lprefix = DeadEnd}
-;;
-
-let change_lev lev n lname assoc =
- let a =
- match assoc with
- None -> lev.assoc
- | Some a ->
- if a <> lev.assoc && !warning_verbose then
- begin
- eprintf "<W> Changing associativity of level \"%s\"\n" n;
- flush stderr
- end;
- a
- in
- begin match lname with
- Some n ->
- if lname <> lev.lname && !warning_verbose then
- begin eprintf "<W> Level label \"%s\" ignored\n" n; flush stderr end
- | None -> ()
- end;
- {assoc = a; lname = lev.lname; lsuffix = lev.lsuffix; lprefix = lev.lprefix}
-;;
-
-let get_level entry position levs =
- match position with
- Some First -> [], empty_lev, levs
- | Some Last -> levs, empty_lev, []
- | Some (Level n) ->
- let rec get =
- function
- [] ->
- 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 =
- function
- [] ->
- 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 =
- function
- [] ->
- 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, []
-;;
-
-let rec check_gram entry =
- function
- Snterm e ->
- if e.egram != entry.egram then
- begin
- eprintf "\
-Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
- entry.ename e.ename;
- flush stderr;
- failwith "Grammar.extend error"
- end
- | Snterml (e, _) ->
- if e.egram != entry.egram then
- begin
- eprintf "\
-Error: entries \"%s\" and \"%s\" do not belong to the same grammar.\n"
- entry.ename e.ename;
- flush stderr;
- failwith "Grammar.extend error"
- end
- | Smeta (_, sl, _) -> List.iter (check_gram entry) sl
- | Slist0sep (s, t) -> check_gram entry t; check_gram entry s
- | Slist1sep (s, t) -> 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 =
- function
- Node {node = n; brother = bro; son = son} ->
- check_gram entry n; tree_check_gram entry bro; tree_check_gram entry son
- | LocAct (_, _) | DeadEnd -> ()
-;;
-
-let change_to_self entry =
- function
- Snterm e when e == entry -> Sself
- | x -> x
-;;
-
-let get_initial entry =
- function
- Sself :: symbols -> true, symbols
- | symbols -> false, symbols
-;;
-
-let insert_tokens gram symbols =
- let rec insert =
- function
- Smeta (_, sl, _) -> List.iter insert sl
- | Slist0 s -> insert s
- | Slist1 s -> insert s
- | Slist0sep (s, t) -> insert s; insert t
- | Slist1sep (s, t) -> insert s; insert t
- | Sopt s -> insert s
- | Stree t -> tinsert t
- | Stoken ("ANY", _) -> ()
- | Stoken tok ->
- gram.glexer.Token.tok_using tok;
- let r =
- try Hashtbl.find gram.gtokens tok with
- Not_found -> let r = ref 0 in Hashtbl.add gram.gtokens tok r; r
- in
- incr r
- | Snterm _ | Snterml (_, _) | Snext | Sself -> ()
- and tinsert =
- function
- Node {node = s; brother = bro; son = son} ->
- insert s; tinsert bro; tinsert son
- | LocAct (_, _) | DeadEnd -> ()
- in
- List.iter insert symbols
-;;
-
-let levels_of_rules entry position rules =
- let elev =
- match entry.edesc with
- Dlevels elev -> elev
- | Dparser _ ->
- 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
- 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
-;;
-
-let 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 *)
-
-let 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
- begin match delete_in_tree symbols n.brother with
- Some (dsl, t) ->
- Some (dsl, Node {node = n.node; son = n.son; brother = t})
- | None -> None
- end
- | s :: sl, _ -> None
- | [], Node n ->
- begin match delete_in_tree [] n.brother with
- Some (dsl, t) ->
- Some (dsl, Node {node = n.node; son = n.son; brother = t})
- | None -> None
- end
- | [], 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
-;;
-
-let rec decr_keyw_use gram =
- function
- Stoken tok ->
- let r = Hashtbl.find gram.gtokens tok in
- decr r;
- if !r == 0 then
- begin
- Hashtbl.remove gram.gtokens tok; gram.glexer.Token.tok_removing tok
- end
- | 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) -> decr_keyw_use gram s1; decr_keyw_use gram s2
- | Slist1sep (s1, s2) -> 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 =
- function
- DeadEnd | LocAct (_, _) -> ()
- | Node n ->
- decr_keyw_use gram n.node;
- decr_keyw_use_in_tree gram n.son;
- decr_keyw_use_in_tree gram n.brother
-;;
-
-let rec delete_rule_in_suffix entry symbols =
- function
- lev :: levs ->
- begin match delete_rule_in_tree entry symbols lev.lsuffix with
- Some (dsl, t) ->
- begin match dsl with
- Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
- | None -> ()
- end;
- begin 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
- end
- | None ->
- let levs = delete_rule_in_suffix entry symbols levs in lev :: levs
- end
- | [] -> raise Not_found
-;;
-
-let rec delete_rule_in_prefix entry symbols =
- function
- lev :: levs ->
- begin match delete_rule_in_tree entry symbols lev.lprefix with
- Some (dsl, t) ->
- begin match dsl with
- Some dsl -> List.iter (decr_keyw_use entry.egram) dsl
- | None -> ()
- end;
- begin 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
- end
- | None ->
- let levs = delete_rule_in_prefix entry symbols levs in lev :: levs
- end
- | [] -> raise Not_found
-;;
-
-let 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/ocaml_src/lib/gramext.mli b/camlp4/ocaml_src/lib/gramext.mli
deleted file mode 100644
index bd275ae8ee..0000000000
--- a/camlp4/ocaml_src/lib/gramext.mli
+++ /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. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-type 'te grammar =
- { gtokens : (Token.pattern, int ref) Hashtbl.t;
- mutable glexer : 'te Token.glexer }
-;;
-
-type 'te g_entry =
- { egram : 'te grammar;
- ename : string;
- mutable estart : int -> 'te Stream.t -> Obj.t;
- mutable econtinue : int -> int -> Obj.t -> 'te Stream.t -> Obj.t;
- mutable edesc : 'te g_desc }
-and 'te g_desc =
- Dlevels of 'te g_level list
- | Dparser of ('te Stream.t -> Obj.t)
-and 'te g_level =
- { assoc : g_assoc;
- lname : string option;
- lsuffix : 'te g_tree;
- lprefix : 'te g_tree }
-and g_assoc =
- NonA
- | RightA
- | LeftA
-and 'te g_symbol =
- Smeta of string * 'te g_symbol list * Obj.t
- | Snterm of 'te g_entry
- | Snterml of 'te g_entry * string
- | Slist0 of 'te g_symbol
- | Slist0sep of 'te g_symbol * 'te g_symbol
- | Slist1 of 'te g_symbol
- | Slist1sep of 'te g_symbol * 'te g_symbol
- | Sopt of 'te g_symbol
- | Sself
- | Snext
- | Stoken of Token.pattern
- | Stree of 'te g_tree
-and g_action = Obj.t
-and 'te g_tree =
- Node of 'te g_node
- | LocAct of g_action * g_action list
- | DeadEnd
-and 'te g_node =
- { node : 'te g_symbol; son : 'te g_tree; brother : 'te g_tree }
-;;
-
-type position =
- First
- | Last
- | Before of string
- | After of string
- | Level of string
-;;
-
-val levels_of_rules :
- 'te g_entry -> position option ->
- (string option * g_assoc option * ('te g_symbol list * g_action) list)
- list ->
- 'te g_level list;;
-val srules : ('te g_symbol list * g_action) list -> 'te g_symbol;;
-external action : 'a -> g_action = "%identity";;
-
-val delete_rule_in_level_list :
- 'te g_entry -> 'te g_symbol list -> 'te g_level list -> 'te g_level list;;
-
-val warning_verbose : bool ref;;
diff --git a/camlp4/ocaml_src/lib/grammar.ml b/camlp4/ocaml_src/lib/grammar.ml
deleted file mode 100644
index 196a6b954a..0000000000
--- a/camlp4/ocaml_src/lib/grammar.ml
+++ /dev/null
@@ -1,1119 +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. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-open Stdpp;;
-open Gramext;;
-open Format;;
-
-let rec flatten_tree =
- function
- DeadEnd -> []
- | LocAct (_, _) -> [[]]
- | Node {node = n; brother = b; son = s} ->
- List.map (fun l -> n :: l) (flatten_tree s) @ flatten_tree b
-;;
-
-let print_str ppf s = fprintf ppf "\"%s\"" (String.escaped s);;
-
-let rec print_symbol ppf =
- function
- 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 =
- let rec loop i =
- function
- [] -> ()
- | s :: sl ->
- let j =
- try String.index_from n i ' ' with
- Not_found -> String.length n
- in
- fprintf ppf "%s %a" (String.sub n i (j - i)) print_symbol1 s;
- if sl = [] then ()
- else
- begin fprintf ppf " "; loop (min (j + 1) (String.length n)) sl end
- in
- loop 0 sl
-and print_symbol1 ppf =
- function
- 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 =
- fprintf ppf "@[<hov 0>";
- let _ =
- List.fold_left
- (fun sep symbol ->
- 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 =
- fprintf ppf "@[<hov 0>[ ";
- let _ =
- List.fold_left
- (fun sep rule ->
- fprintf ppf "%t%a" sep print_rule rule;
- fun ppf -> fprintf ppf "%a| " pp_print_space ())
- (fun ppf -> ()) rules
- in
- fprintf ppf " ]@]"
-;;
-
-let 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
- fprintf ppf "%t@[<hov 2>" sep;
- begin match lev.lname with
- Some n -> fprintf ppf "%a@;<1 2>" print_str n
- | None -> ()
- end;
- begin match lev.assoc with
- LeftA -> fprintf ppf "LEFTA"
- | RightA -> fprintf ppf "RIGHTA"
- | NonA -> fprintf ppf "NONA"
- end;
- fprintf ppf "@]@;<1 2>";
- print_level ppf pp_force_newline rules;
- fun ppf -> fprintf ppf "@,| ")
- (fun ppf -> ()) elev
- in
- ()
-;;
-
-let print_entry ppf e =
- fprintf ppf "@[<v 0>[ ";
- begin match e.edesc with
- Dlevels elev -> print_levels ppf elev
- | Dparser _ -> fprintf ppf "<parser>"
- end;
- fprintf ppf " ]@]"
-;;
-
-let iter_entry f e =
- let treated = ref [] in
- let rec do_entry e =
- if List.memq e !treated then ()
- else
- begin
- treated := e :: !treated;
- f e;
- match e.edesc with
- Dlevels ll -> List.iter do_level ll
- | Dparser _ -> ()
- end
- and do_level lev = do_tree lev.lsuffix; do_tree lev.lprefix
- and do_tree =
- function
- Node n -> do_node n
- | LocAct (_, _) | DeadEnd -> ()
- and do_node n = do_symbol n.node; do_tree n.son; do_tree n.brother
- and do_symbol =
- function
- 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_symbol s1; do_symbol s2
- | Stree t -> do_tree t
- | Sself | Snext | Stoken _ -> ()
- in
- do_entry e
-;;
-
-let fold_entry f e init =
- let treated = ref [] in
- let rec do_entry accu e =
- if List.memq e !treated then accu
- else
- begin
- treated := e :: !treated;
- let accu = f e accu in
- match e.edesc with
- Dlevels ll -> List.fold_left do_level accu ll
- | Dparser _ -> accu
- end
- and do_level accu lev =
- let accu = do_tree accu lev.lsuffix in do_tree accu lev.lprefix
- and do_tree accu =
- function
- 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 =
- function
- 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 = Token.t Gramext.grammar;;
-
-external grammar_obj : g -> Token.t grammar = "%identity";;
-
-let floc = ref (fun _ -> failwith "internal error when computing location");;
-let loc_of_token_interval bp ep =
- if bp == ep then
- if bp == 0 then 0, 1 else let a = snd (!floc (bp - 1)) in a, a + 1
- else
- let (bp1, bp2) = !floc bp in
- let (ep1, ep2) = !floc (pred ep) in
- (if bp1 < ep1 then bp1 else ep1), (if bp2 > ep2 then bp2 else ep2)
-;;
-
-let rec name_of_symbol entry =
- function
- Snterm e -> "[" ^ e.ename ^ "]"
- | Snterml (e, l) -> "[" ^ e.ename ^ " level " ^ l ^ "]"
- | Sself | Snext -> "[" ^ entry.ename ^ "]"
- | Stoken tok -> entry.egram.glexer.Token.tok_text tok
- | _ -> "???"
-;;
-
-let 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)
-;;
-
-let rec name_of_symbol_failed entry =
- function
- 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 =
- function
- Node {node = s; brother = bro; son = son} ->
- let tokl =
- match s with
- Stoken tok -> get_token_list entry [] tok son
- | _ -> None
- in
- begin 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
- end
- | DeadEnd | LocAct (_, _) -> "???"
-;;
-
-let search_tree_in_entry prev_symb tree =
- function
- Dlevels levels ->
- let rec search_levels =
- function
- [] -> 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 ->
- begin 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
- end
- | 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 ->
- begin match search_symbol symb with
- Some symb -> Some (Slist0 symb)
- | None -> None
- end
- | Slist0sep (symb, sep) ->
- begin 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
- end
- | Slist1 symb ->
- begin match search_symbol symb with
- Some symb -> Some (Slist1 symb)
- | None -> None
- end
- | Slist1sep (symb, sep) ->
- begin 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
- end
- | Sopt symb ->
- begin match search_symbol symb with
- Some symb -> Some (Sopt symb)
- | None -> None
- end
- | Stree t ->
- begin match search_tree t with
- Some t -> Some (Stree t)
- | None -> None
- end
- | _ -> None
- in
- search_levels levels
- | Dparser _ -> tree
-;;
-
-let error_verbose = ref false;;
-
-let 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) ->
- begin 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"
- end
- | Slist1sep (s, sep) ->
- begin 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"
- end
- | Sopt _ | Stree _ -> txt ^ " expected"
- | _ -> txt ^ " expected after " ^ name_of_symbol entry prev_symb
- in
- if !error_verbose then
- begin
- 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 "@]@."
- end;
- txt ^ " (in [" ^ entry.ename ^ "])"
-;;
-
-let 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";;
-
-let is_level_labelled n lev =
- match lev.lname with
- Some n1 -> n = n1
- | None -> false
-;;
-
-let level_number entry lab =
- let rec lookup levn =
- function
- [] -> 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
-;;
-
-let rec top_symb entry =
- function
- Sself | Snext -> Snterm entry
- | Snterml (e, _) -> Snterm e
- | Slist1sep (s, sep) -> Slist1sep (top_symb entry s, sep)
- | _ -> raise Stream.Failure
-;;
-
-let entry_of_symb entry =
- function
- Sself | Snext -> entry
- | Snterm e -> e
- | Snterml (e, _) -> e
- | _ -> raise Stream.Failure
-;;
-
-let top_tree entry =
- function
- Node {node = s; brother = bro; son = son} ->
- Node {node = top_symb entry s; brother = bro; son = son}
- | LocAct (_, _) | DeadEnd -> raise Stream.Failure
-;;
-
-let skip_if_empty bp p strm =
- if Stream.count strm == bp then Gramext.action (fun a -> p strm)
- else raise Stream.Failure
-;;
-
-let continue entry bp a s son p1 (strm__ : _ Stream.t) =
- let a = (entry_of_symb entry s).econtinue 0 bp a strm__ in
- let act =
- try p1 strm__ with
- Stream.Failure -> raise (Stream.Error (tree_failed entry a s son))
- in
- Gramext.action (fun _ -> app act a)
-;;
-
-let do_recover
- parser_of_tree entry nlevn alevn bp a s son (strm__ : _ Stream.t) =
- try parser_of_tree entry nlevn alevn (top_tree entry son) strm__ with
- Stream.Failure ->
- try
- skip_if_empty bp (fun (strm__ : _ Stream.t) -> raise Stream.Failure)
- strm__
- with
- Stream.Failure ->
- continue entry bp a s son (parser_of_tree entry nlevn alevn son)
- strm__
-;;
-
-let strict_parsing = ref false;;
-
-let recover parser_of_tree entry nlevn alevn bp a s son strm =
- if !strict_parsing then raise (Stream.Error (tree_failed entry a s son))
- else do_recover parser_of_tree entry nlevn alevn bp a s son strm
-;;
-
-let token_count = ref 0;;
-
-let peek_nth n strm =
- let list = Stream.npeek n strm in
- token_count := 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
-;;
-
-let rec parser_of_tree entry nlevn alevn =
- function
- DeadEnd -> (fun (strm__ : _ Stream.t) -> raise Stream.Failure)
- | LocAct (act, _) -> (fun (strm__ : _ Stream.t) -> act)
- | Node {node = Sself; son = LocAct (act, _); brother = DeadEnd} ->
- (fun (strm__ : _ Stream.t) ->
- let a = entry.estart alevn strm__ in app act a)
- | Node {node = Sself; son = LocAct (act, _); brother = bro} ->
- let p2 = parser_of_tree entry nlevn alevn bro in
- (fun (strm__ : _ Stream.t) ->
- match
- try Some (entry.estart alevn strm__) with
- Stream.Failure -> None
- with
- Some a -> app act a
- | _ -> p2 strm__)
- | Node {node = s; son = son; brother = DeadEnd} ->
- let tokl =
- match s with
- Stoken tok -> get_token_list entry [] tok son
- | _ -> None
- in
- begin 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
- (fun (strm__ : _ Stream.t) ->
- let bp = Stream.count strm__ in
- let a = ps strm__ in
- let act =
- try p1 bp a strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- 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
- end
- | 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
- (fun (strm__ : _ Stream.t) ->
- let bp = Stream.count strm__ in
- match
- try Some (ps strm__) with
- Stream.Failure -> None
- with
- Some a ->
- let act =
- try p1 bp a strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- app act a
- | _ -> p2 strm__)
- | 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
- fun (strm__ : _ Stream.t) ->
- try p1 strm__ with
- Stream.Failure -> p2 strm__
-and parser_cont p1 entry nlevn alevn s son bp a (strm__ : _ Stream.t) =
- try p1 strm__ with
- Stream.Failure ->
- try recover parser_of_tree entry nlevn alevn bp a s son strm__ with
- Stream.Failure -> raise (Stream.Error (tree_failed entry a s son))
-and parser_of_token_list gram p1 tokl =
- let rec loop n =
- function
- tok :: tokl ->
- let tematch = gram.glexer.Token.tok_match tok in
- begin match tokl with
- [] ->
- let ps strm =
- match peek_nth n strm with
- Some tok ->
- let r = tematch tok in
- for i = 1 to n do Stream.junk strm done; Obj.repr r
- | None -> raise Stream.Failure
- in
- (fun (strm__ : _ Stream.t) ->
- let bp = Stream.count strm__ in
- let a = ps strm__ in
- let act =
- try p1 bp a strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- 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
- fun (strm__ : _ Stream.t) ->
- let a = ps strm__ in let act = p1 strm__ in app act a
- end
- | [] -> invalid_arg "parser_of_token_list"
- in
- loop 1 tokl
-and parser_of_symbol entry nlevn =
- function
- 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 (strm__ : _ Stream.t) =
- match
- try Some (ps strm__) with
- Stream.Failure -> None
- with
- Some a -> loop (a :: al) strm__
- | _ -> al
- in
- (fun (strm__ : _ Stream.t) ->
- let a = loop [] strm__ in 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 (strm__ : _ Stream.t) =
- match
- try Some (pt strm__) with
- Stream.Failure -> None
- with
- Some v ->
- let a =
- try ps strm__ with
- Stream.Failure ->
- raise (Stream.Error (symb_failed entry v sep symb))
- in
- kont (a :: al) strm__
- | _ -> al
- in
- (fun (strm__ : _ Stream.t) ->
- match
- try Some (ps strm__) with
- Stream.Failure -> None
- with
- Some a -> Obj.repr (List.rev (kont [a] strm__))
- | _ -> Obj.repr [])
- | Slist1 s ->
- let ps = parser_of_symbol entry nlevn s in
- let rec loop al (strm__ : _ Stream.t) =
- match
- try Some (ps strm__) with
- Stream.Failure -> None
- with
- Some a -> loop (a :: al) strm__
- | _ -> al
- in
- (fun (strm__ : _ Stream.t) ->
- let a = ps strm__ in Obj.repr (List.rev (loop [a] strm__)))
- | 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 (strm__ : _ Stream.t) =
- match
- try Some (pt strm__) with
- Stream.Failure -> None
- with
- Some v ->
- let a =
- try ps strm__ with
- Stream.Failure ->
- try parse_top_symb entry symb strm__ with
- Stream.Failure ->
- raise (Stream.Error (symb_failed entry v sep symb))
- in
- kont (a :: al) strm__
- | _ -> al
- in
- (fun (strm__ : _ Stream.t) ->
- let a = ps strm__ in Obj.repr (List.rev (kont [a] strm__)))
- | Sopt s ->
- let ps = parser_of_symbol entry nlevn s in
- (fun (strm__ : _ Stream.t) ->
- match
- try Some (ps strm__) with
- Stream.Failure -> None
- with
- Some a -> Obj.repr (Some a)
- | _ -> Obj.repr None)
- | Stree t ->
- let pt = parser_of_tree entry 1 0 t in
- (fun (strm__ : _ Stream.t) ->
- let bp = Stream.count strm__ in
- let a = pt strm__ in
- let ep = Stream.count strm__ in
- let loc = loc_of_token_interval bp ep in app a loc)
- | Snterm e -> (fun (strm__ : _ Stream.t) -> e.estart 0 strm__)
- | Snterml (e, l) ->
- (fun (strm__ : _ Stream.t) -> e.estart (level_number e l) strm__)
- | Sself -> (fun (strm__ : _ Stream.t) -> entry.estart 0 strm__)
- | Snext -> (fun (strm__ : _ Stream.t) -> entry.estart nlevn strm__)
- | 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 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)
-;;
-
-let symb_failed_txt e s1 s2 = symb_failed e 0 s1 s2;;
-
-let rec continue_parser_of_levels entry clevn =
- function
- [] -> (fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure)
- | 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
- let (strm__ : _ Stream.t) = strm in
- try p1 levn bp a strm__ with
- Stream.Failure ->
- let act = p2 strm__ in
- let ep = Stream.count strm__ in
- let a = app act a (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm
-;;
-
-let rec start_parser_of_levels entry clevn =
- function
- [] -> (fun levn (strm__ : _ Stream.t) -> raise Stream.Failure)
- | 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 ->
- let (strm__ : _ Stream.t) = strm in
- let bp = Stream.count strm__ in
- let act = p2 strm__ in
- let ep = Stream.count strm__ in
- 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
- let (strm__ : _ Stream.t) = strm in
- let bp = Stream.count strm__ in
- match
- try Some (p2 strm__) with
- Stream.Failure -> None
- with
- Some act ->
- let ep = Stream.count strm__ in
- let a = app act (loc_of_token_interval bp ep) in
- entry.econtinue levn bp a strm
- | _ -> p1 levn strm__
-;;
-
-let 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 (strm__ : _ Stream.t) ->
- try p levn bp a strm__ with
- Stream.Failure -> a)
- | Dparser p -> fun levn bp a (strm__ : _ Stream.t) -> raise Stream.Failure
-;;
-
-let empty_entry ename levn strm =
- raise (Stream.Error ("entry [" ^ ename ^ "] is empty"))
-;;
-
-let 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
-;;
-
-let parse_parsable entry efun (cs, (ts, fun_loc)) =
- let restore =
- let old_floc = !floc in
- let old_tc = !token_count in
- fun () -> floc := old_floc; token_count := old_tc
- in
- let get_loc () =
- try
- let cnt = Stream.count ts in
- let loc = fun_loc cnt in
- if !token_count - 1 <= cnt then loc
- else fst loc, snd (fun_loc (!token_count - 1))
- with
- _ -> Stream.count cs, Stream.count cs + 1
- in
- floc := fun_loc;
- token_count := 0;
- try let r = efun ts in restore (); r with
- Stream.Failure ->
- let loc = get_loc () in
- restore ();
- raise_with_loc loc (Stream.Error ("illegal begin of " ^ entry.ename))
- | Stream.Error _ as exc ->
- let loc = get_loc () in restore (); raise_with_loc loc exc
- | exc ->
- let loc = Stream.count cs, Stream.count cs + 1 in
- restore (); raise_with_loc loc exc
-;;
-
-let wrap_parse entry efun cs =
- let parsable = cs, entry.egram.glexer.Token.tok_func cs in
- parse_parsable entry efun parsable
-;;
-
-let create_toktab () = Hashtbl.create 301;;
-let gcreate glexer = {gtokens = create_toktab (); glexer = glexer};;
-
-let tematch tparse tok =
- match tparse tok with
- Some p -> (fun x -> p (Stream.ising x))
- | None -> Token.default_match tok
-;;
-let 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}
-;;
-let create lexer = gcreate (glexer_of_lexer lexer);;
-
-(* Extend syntax *)
-
-let extend_entry entry position rules =
- try
- let elev = Gramext.levels_of_rules entry position rules in
- entry.edesc <- Dlevels elev;
- entry.estart <-
- (fun lev strm ->
- let f = start_parser_of_entry entry in
- entry.estart <- f; f lev strm);
- entry.econtinue <-
- fun lev bp a strm ->
- let f = continue_parser_of_entry entry in
- entry.econtinue <- f; f lev bp a strm
- with
- Token.Error s ->
- Printf.eprintf "Lexer initialization error:\n- %s\n" s;
- flush stderr;
- failwith "Grammar.extend"
-;;
-
-let extend entry_rules_list =
- let gram = ref None in
- List.iter
- (fun (entry, position, rules) ->
- begin match !gram with
- Some g ->
- if g != entry.egram then
- begin
- Printf.eprintf "Error: entries with different grammars\n";
- flush stderr;
- failwith "Grammar.extend"
- end
- | None -> gram := Some entry.egram
- end;
- extend_entry entry position rules)
- entry_rules_list
-;;
-
-(* Deleting a rule *)
-
-let delete_rule entry sl =
- match entry.edesc with
- Dlevels levs ->
- let levs = Gramext.delete_rule_in_level_list entry sl levs in
- entry.edesc <- Dlevels levs;
- entry.estart <-
- (fun lev strm ->
- let f = start_parser_of_entry entry in
- entry.estart <- f; f lev strm);
- entry.econtinue <-
- (fun lev bp a strm ->
- let f = continue_parser_of_entry entry in
- entry.econtinue <- f; f lev bp a strm)
- | Dparser _ -> ()
-;;
-
-(* Unsafe *)
-
-let clear_entry e =
- e.estart <- (fun _ (strm__ : _ Stream.t) -> raise Stream.Failure);
- e.econtinue <- (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
- match e.edesc with
- Dlevels _ -> e.edesc <- Dlevels []
- | Dparser _ -> ()
-;;
-
-let gram_reinit g glexer = Hashtbl.clear g.gtokens; g.glexer <- glexer;;
-
-let reinit_gram g lexer = gram_reinit g (glexer_of_lexer lexer);;
-
-module Unsafe =
- struct
- let gram_reinit = gram_reinit;;
- let clear_entry = clear_entry;;
- let reinit_gram = reinit_gram;;
- end
-;;
-
-let find_entry e s =
- let rec find_levels =
- function
- [] -> None
- | lev :: levs ->
- match find_tree lev.lsuffix with
- None ->
- begin match find_tree lev.lprefix with
- None -> find_levels levs
- | x -> x
- end
- | x -> x
- and find_symbol =
- function
- 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 =
- function
- s :: sl ->
- begin match find_symbol s with
- None -> find_symbol_list sl
- | x -> x
- end
- | [] -> None
- and find_tree =
- function
- Node {node = s; brother = bro; son = son} ->
- begin match find_symbol s with
- None ->
- begin match find_tree bro with
- None -> find_tree son
- | x -> x
- end
- | x -> x
- end
- | LocAct (_, _) | DeadEnd -> None
- in
- match e.edesc with
- Dlevels levs ->
- begin match find_levels levs with
- Some e -> e
- | None -> raise Not_found
- end
- | Dparser _ -> raise Not_found
-;;
-
-let of_entry e = e.egram;;
-
-module Entry =
- struct
- type te = Token.t;;
- type 'a e = te g_entry;;
- let create g n =
- {egram = g; ename = n; estart = empty_entry n;
- econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
- edesc = Dlevels []}
- ;;
- let parse (entry : 'a e) cs : 'a =
- Obj.magic (wrap_parse entry (entry.estart 0) cs)
- ;;
- let parse_token (entry : 'a e) ts : 'a = Obj.magic (entry.estart 0 ts);;
- let name e = e.ename;;
- let of_parser g n (p : te Stream.t -> 'a) : 'a e =
- {egram = g; ename = n; estart = (fun _ -> Obj.magic p);
- econtinue = (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
- edesc = Dparser (Obj.magic p)}
- ;;
- external obj : 'a e -> te Gramext.g_entry = "%identity";;
- let print e = printf "%a@." print_entry (obj e);;
- let find e s = find_entry (obj e) s;;
- end
-;;
-
-let tokens g con =
- let list = ref [] in
- Hashtbl.iter
- (fun (p_con, p_prm) c -> if p_con = con then list := (p_prm, !c) :: !list)
- g.gtokens;
- !list
-;;
-
-let glexer g = g.glexer;;
-
-let warning_verbose = Gramext.warning_verbose;;
-
-(* Functorial interface *)
-
-module type GLexerType = sig type te;; val lexer : te Token.glexer;; end;;
-
-module type S =
- sig
- type te;;
- type parsable;;
- val parsable : char Stream.t -> parsable;;
- val tokens : string -> (string * int) list;;
- val glexer : te Token.glexer;;
- module Entry :
- sig
- type 'a e;;
- val create : string -> 'a e;;
- val parse : 'a e -> parsable -> 'a;;
- val parse_token : 'a e -> te Stream.t -> 'a;;
- val name : 'a e -> string;;
- val of_parser : string -> (te Stream.t -> 'a) -> 'a e;;
- val print : 'a e -> unit;;
- external obj : 'a e -> te Gramext.g_entry = "%identity";;
- end
- ;;
- module Unsafe :
- sig
- val gram_reinit : te Token.glexer -> unit;;
- val clear_entry : 'a Entry.e -> unit;;
- val reinit_gram : Token.lexer -> unit;;
- end
- ;;
- val extend :
- 'a Entry.e -> Gramext.position option ->
- (string option * Gramext.g_assoc option *
- (te Gramext.g_symbol list * Gramext.g_action) list)
- list ->
- unit;;
- val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> unit;;
- end
-;;
-
-module type ReinitType = sig val reinit_gram : g -> Token.lexer -> unit;; end
-;;
-
-module GGMake (R : ReinitType) (L : GLexerType) =
- struct
- type te = L.te;;
- type parsable = char Stream.t * (te Stream.t * Token.location_function);;
- let gram = gcreate L.lexer;;
- let parsable cs = cs, L.lexer.Token.tok_func cs;;
- let tokens = tokens gram;;
- let glexer = glexer gram;;
- module Entry =
- struct
- type 'a e = te g_entry;;
- let create n =
- {egram = gram; ename = n; estart = empty_entry n;
- econtinue =
- (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
- edesc = Dlevels []}
- ;;
- external obj : 'a e -> te Gramext.g_entry = "%identity";;
- let parse (e : 'a e) p : 'a =
- Obj.magic (parse_parsable e (e.estart 0) p)
- ;;
- let parse_token (e : 'a e) ts : 'a = Obj.magic (e.estart 0 ts);;
- let name e = e.ename;;
- let of_parser n (p : te Stream.t -> 'a) : 'a e =
- {egram = gram; ename = n; estart = (fun _ -> Obj.magic p);
- econtinue =
- (fun _ _ _ (strm__ : _ Stream.t) -> raise Stream.Failure);
- edesc = Dparser (Obj.magic p)}
- ;;
- let print e = printf "%a@." print_entry (obj e);;
- end
- ;;
- module Unsafe =
- struct
- let gram_reinit = gram_reinit gram;;
- let clear_entry = Unsafe.clear_entry;;
- let reinit_gram = R.reinit_gram (Obj.magic gram);;
- end
- ;;
- let extend = extend_entry;;
- let delete_rule e r = delete_rule (Entry.obj e) r;;
- end
-;;
-
-module GMake (L : GLexerType) =
- GGMake
- (struct
- let reinit_gram _ _ =
- failwith "call of deprecated reinit_gram in grammar built by GMake"
- ;;
- end)
- (L)
-;;
-
-module type LexerType = sig val lexer : Token.lexer;; end;;
-
-module Make (L : LexerType) =
- GGMake (struct let reinit_gram = reinit_gram;; end)
- (struct type te = Token.t;; let lexer = glexer_of_lexer L.lexer;; end)
-;;
diff --git a/camlp4/ocaml_src/lib/grammar.mli b/camlp4/ocaml_src/lib/grammar.mli
deleted file mode 100644
index d38b449f95..0000000000
--- a/camlp4/ocaml_src/lib/grammar.mli
+++ /dev/null
@@ -1,200 +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. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-(** 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;;
- (** The type for grammars, holding entries. *)
-val gcreate : Token.t Token.glexer -> g;;
- (** Create a new grammar, without keywords, using the lexer given
- as parameter. *)
-val tokens : g -> string -> (string * int) list;;
- (** 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. *)
-val glexer : g -> Token.t Token.glexer;;
- (** Return the lexer used by the grammar *)
-
-module Entry :
- sig
- type 'a e;;
- val create : g -> string -> 'a e;;
- val parse : 'a e -> char Stream.t -> 'a;;
- val parse_token : 'a e -> Token.t Stream.t -> 'a;;
- val name : 'a e -> string;;
- val of_parser : g -> string -> (Token.t Stream.t -> 'a) -> 'a e;;
- val print : 'a e -> unit;;
- val find : 'a e -> string -> Obj.t e;;
- external obj : 'a e -> Token.t Gramext.g_entry = "%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). *)
-
-val of_entry : 'a Entry.e -> g;;
- (** Return the grammar associated with an entry. *)
-
-(** {6 Clearing grammars and entries} *)
-
-module Unsafe :
- sig
- val gram_reinit : g -> Token.t Token.glexer -> unit;;
- val clear_entry : 'a Entry.e -> unit;;
- val 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;; val lexer : te Token.glexer;; end;;
- (** The input signature for the functor [Grammar.GMake]: [te] is the
- type of the tokens. *)
-
-module type S =
- sig
- type te;;
- type parsable;;
- val parsable : char Stream.t -> parsable;;
- val tokens : string -> (string * int) list;;
- val glexer : te Token.glexer;;
- module Entry :
- sig
- type 'a e;;
- val create : string -> 'a e;;
- val parse : 'a e -> parsable -> 'a;;
- val parse_token : 'a e -> te Stream.t -> 'a;;
- val name : 'a e -> string;;
- val of_parser : string -> (te Stream.t -> 'a) -> 'a e;;
- val print : 'a e -> unit;;
- external obj : 'a e -> te Gramext.g_entry = "%identity";;
- end
- ;;
- module Unsafe :
- sig
- val gram_reinit : te Token.glexer -> unit;;
- val clear_entry : 'a Entry.e -> unit;;
- val reinit_gram : Token.lexer -> unit;;
- end
- ;;
- val extend :
- 'a Entry.e -> Gramext.position option ->
- (string option * Gramext.g_assoc option *
- (te Gramext.g_symbol list * Gramext.g_action) list)
- list ->
- unit;;
- val delete_rule : 'a Entry.e -> te Gramext.g_symbol list -> 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} *)
-
-val error_verbose : bool ref;;
- (** Flag for displaying more information in case of parsing error;
- default = [False] *)
-
-val warning_verbose : bool ref;;
- (** Flag for displaying warnings while extension; default = [True] *)
-
-val strict_parsing : bool ref;;
- (** Flag to apply strict parsing, without trying to recover errors;
- default = [False] *)
-
-val print_entry : Format.formatter -> 'te Gramext.g_entry -> unit;;
- (** General printer for all kinds of entries (obj entries) *)
-
-val iter_entry :
- ('te Gramext.g_entry -> unit) -> 'te Gramext.g_entry -> 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. *)
-
-val fold_entry :
- ('te Gramext.g_entry -> 'a -> 'a) -> 'te Gramext.g_entry -> '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 val lexer : Token.lexer;; end;;
-module Make (L : LexerType) : S with type te = Token.t;;
-(*** deprecated since version 3.05; use rather the function gcreate *)
-val create : Token.lexer -> g;;
-
-(*** For system use *)
-
-val loc_of_token_interval : int -> int -> int * int;;
-val extend :
- ('te Gramext.g_entry * Gramext.position option *
- (string option * Gramext.g_assoc option *
- ('te Gramext.g_symbol list * Gramext.g_action) list)
- list)
- list ->
- unit;;
-val delete_rule : 'a Entry.e -> Token.t Gramext.g_symbol list -> unit;;
-
-val parse_top_symb :
- 'te Gramext.g_entry -> 'te Gramext.g_symbol -> 'te Stream.t -> Obj.t;;
-val symb_failed_txt :
- 'te Gramext.g_entry -> 'te Gramext.g_symbol -> 'te Gramext.g_symbol ->
- string;;
diff --git a/camlp4/ocaml_src/lib/plexer.ml b/camlp4/ocaml_src/lib/plexer.ml
deleted file mode 100644
index 4b5dcca151..0000000000
--- a/camlp4/ocaml_src/lib/plexer.ml
+++ /dev/null
@@ -1,1258 +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. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-open Stdpp;;
-open Token;;
-
-let no_quotations = ref false;;
-
-(* The string buffering machinery *)
-
-let buff = ref (String.create 80);;
-let store len x =
- if len >= String.length !buff then
- buff := !buff ^ String.create (String.length !buff);
- !buff.[len] <- x;
- succ len
-;;
-let mstore len s =
- let rec add_rec len i =
- if i == String.length s then len else add_rec (store len s.[i]) (succ i)
- in
- add_rec len 0
-;;
-let get_buff len = String.sub !buff 0 len;;
-
-(* The lexer *)
-
-let stream_peek_nth n strm =
- let rec loop n =
- function
- [] -> None
- | [x] -> if n == 1 then Some x else None
- | _ :: l -> loop (n - 1) l
- in
- loop n (Stream.npeek n strm)
-;;
-
-let rec ident len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some
- ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '0'..'9' | '_' | '\'' as c) ->
- Stream.junk strm__; ident (store len c) strm__
- | _ -> len
-and ident2 len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some
- ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
- '.' | ':' | '<' | '>' | '|' | '$' as c) ->
- Stream.junk strm__; ident2 (store len c) strm__
- | _ -> len
-and ident3 len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some
- ('0'..'9' | 'A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '_' | '!' | '%' | '&' | '*' | '+' | '-' | '.' | '/' |
- ':' | '<' | '=' | '>' | '?' | '@' | '^' | '|' | '~' | '\'' | '$' as c
- ) ->
- Stream.junk strm__; ident3 (store len c) strm__
- | _ -> len
-and base_number len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('o' | 'O') ->
- Stream.junk strm__; digits octal (store len 'o') strm__
- | Some ('x' | 'X') -> Stream.junk strm__; digits hexa (store len 'x') strm__
- | Some ('b' | 'B') ->
- Stream.junk strm__; digits binary (store len 'b') strm__
- | _ -> number len strm__
-and digits kind len (strm__ : _ Stream.t) =
- let d =
- try kind strm__ with
- Stream.Failure -> raise (Stream.Error "ill-formed integer constant")
- in
- digits_under kind (store len d) strm__
-and digits_under kind len (strm__ : _ Stream.t) =
- match
- try Some (kind strm__) with
- Stream.Failure -> None
- with
- Some d -> digits_under kind (store len d) strm__
- | _ ->
- match Stream.peek strm__ with
- Some '_' -> Stream.junk strm__; digits_under kind len strm__
- | _ -> "INT", get_buff len
-and octal (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'7' as d) -> Stream.junk strm__; d
- | _ -> raise Stream.Failure
-and hexa (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9' | 'a'..'f' | 'A'..'F' as d) -> Stream.junk strm__; d
- | _ -> raise Stream.Failure
-and binary (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'1' as d) -> Stream.junk strm__; d
- | _ -> raise Stream.Failure
-and number len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9' as c) -> Stream.junk strm__; number (store len c) strm__
- | Some '_' -> Stream.junk strm__; number len strm__
- | Some '.' -> Stream.junk strm__; decimal_part (store len '.') strm__
- | Some ('e' | 'E') ->
- Stream.junk strm__; exponent_part (store len 'E') strm__
- | Some 'l' -> Stream.junk strm__; "INT32", get_buff len
- | Some 'L' -> Stream.junk strm__; "INT64", get_buff len
- | Some 'n' -> Stream.junk strm__; "NATIVEINT", get_buff len
- | _ -> "INT", get_buff len
-and decimal_part len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9' as c) ->
- Stream.junk strm__; decimal_part (store len c) strm__
- | Some '_' -> Stream.junk strm__; decimal_part len strm__
- | Some ('e' | 'E') ->
- Stream.junk strm__; exponent_part (store len 'E') strm__
- | _ -> "FLOAT", get_buff len
-and exponent_part len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('+' | '-' as c) ->
- Stream.junk strm__; end_exponent_part (store len c) strm__
- | _ -> end_exponent_part len strm__
-and end_exponent_part len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9' as c) ->
- Stream.junk strm__; end_exponent_part_under (store len c) strm__
- | _ -> raise (Stream.Error "ill-formed floating-point constant")
-and end_exponent_part_under len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9' as c) ->
- Stream.junk strm__; end_exponent_part_under (store len c) strm__
- | Some '_' -> Stream.junk strm__; end_exponent_part_under len strm__
- | _ -> "FLOAT", get_buff len
-;;
-
-let error_on_unknown_keywords = ref false;;
-let 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 ]
-;
-*)
-
-let 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 then err loc ("illegal token: " ^ s)
- else ("", s), loc
- in
- let error_if_keyword ((_, id), loc as a) =
- try
- 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 (strm__ : _ Stream.t) =
- let bp = Stream.count strm__ in
- match Stream.peek strm__ with
- Some ('\010' | '\013') ->
- Stream.junk strm__;
- let s = strm__ in
- let ep = Stream.count strm__ in bolpos := ep; next_token true s
- | Some (' ' | '\t' | '\026' | '\012') ->
- Stream.junk strm__; next_token true strm__
- | Some '#' when bp = !bolpos ->
- Stream.junk strm__;
- let s = strm__ in
- if linedir 1 s then begin any_to_nl s; next_token true s end
- else keyword_or_error (bp, bp + 1) "#"
- | Some '(' -> Stream.junk strm__; left_paren bp strm__
- | Some ('A'..'Z' | '\192'..'\214' | '\216'..'\222' as c) ->
- Stream.junk strm__;
- let s = strm__ in
- 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
- | Some ('a'..'z' | '\223'..'\246' | '\248'..'\255' | '_' as c) ->
- Stream.junk strm__;
- let s = strm__ in
- 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
- | Some ('1'..'9' as c) ->
- Stream.junk strm__;
- let tok = number (store 0 c) strm__ in
- let loc = bp, Stream.count strm__ in tok, loc
- | Some '0' ->
- Stream.junk strm__;
- let tok = base_number (store 0 '0') strm__ in
- let loc = bp, Stream.count strm__ in tok, loc
- | Some '\'' ->
- Stream.junk strm__;
- let s = strm__ in
- begin 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) "'"
- end
- | Some '\"' ->
- Stream.junk strm__;
- let tok = "STRING", get_buff (string bp 0 strm__) in
- let loc = bp, Stream.count strm__ in tok, loc
- | Some '$' ->
- Stream.junk strm__;
- let tok = dollar bp 0 strm__ in
- let loc = bp, Stream.count strm__ in tok, loc
- | Some ('!' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' as c) ->
- Stream.junk strm__;
- let id = get_buff (ident2 (store 0 c) strm__) in
- keyword_or_error (bp, Stream.count strm__) id
- | Some ('~' as c) ->
- Stream.junk strm__;
- begin try
- match Stream.peek strm__ with
- Some ('a'..'z' as c) ->
- Stream.junk strm__;
- let len =
- try ident (store 0 c) strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- let s = strm__ in
- let ep = Stream.count strm__ in
- let id = get_buff len in
- let (strm__ : _ Stream.t) = s in
- begin match Stream.peek strm__ with
- Some ':' ->
- Stream.junk strm__;
- let eb = Stream.count strm__ in
- error_if_keyword (("LABEL", id), (bp, ep))
- | _ -> error_if_keyword (("TILDEIDENT", id), (bp, ep))
- end
- | _ ->
- let id = get_buff (ident2 (store 0 c) strm__) in
- keyword_or_error (bp, Stream.count strm__) id
- with
- Stream.Failure -> raise (Stream.Error "")
- end
- | Some ('?' as c) ->
- Stream.junk strm__;
- begin try
- match Stream.peek strm__ with
- Some ('a'..'z' as c) ->
- Stream.junk strm__;
- let len =
- try ident (store 0 c) strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- let s = strm__ in
- let ep = Stream.count strm__ in
- let id = get_buff len in
- let (strm__ : _ Stream.t) = s in
- begin match Stream.peek strm__ with
- Some ':' ->
- Stream.junk strm__;
- let eb = Stream.count strm__ in
- error_if_keyword (("OPTLABEL", id), (bp, ep))
- | _ -> error_if_keyword (("QUESTIONIDENT", id), (bp, ep))
- end
- | _ ->
- let id = get_buff (ident2 (store 0 c) strm__) in
- keyword_or_error (bp, Stream.count strm__) id
- with
- Stream.Failure -> raise (Stream.Error "")
- end
- | Some '<' -> Stream.junk strm__; less bp strm__
- | Some (':' as c1) ->
- Stream.junk strm__;
- let len =
- try
- match Stream.peek strm__ with
- Some (']' | ':' | '=' | '>' as c2) ->
- Stream.junk strm__; store (store 0 c1) c2
- | _ -> store 0 c1
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in
- let id = get_buff len in keyword_or_error (bp, ep) id
- | Some ('>' | '|' as c1) ->
- Stream.junk strm__;
- let len =
- try
- match Stream.peek strm__ with
- Some (']' | '}' as c2) ->
- Stream.junk strm__; store (store 0 c1) c2
- | _ -> ident2 (store 0 c1) strm__
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in
- let id = get_buff len in keyword_or_error (bp, ep) id
- | Some ('[' | '{' as c1) ->
- Stream.junk strm__;
- let s = strm__ in
- let len =
- match Stream.npeek 2 s with
- ['<'; '<' | ':'] -> store 0 c1
- | _ ->
- let (strm__ : _ Stream.t) = s in
- match Stream.peek strm__ with
- Some ('|' | '<' | ':' as c2) ->
- Stream.junk strm__; 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
- | Some '.' ->
- Stream.junk strm__;
- let id =
- try
- match Stream.peek strm__ with
- Some '.' -> Stream.junk strm__; ".."
- | _ -> if ssd && after_space then " ." else "."
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in keyword_or_error (bp, ep) id
- | Some ';' ->
- Stream.junk strm__;
- let id =
- try
- match Stream.peek strm__ with
- Some ';' -> Stream.junk strm__; ";;"
- | _ -> ";"
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in keyword_or_error (bp, ep) id
- | Some '\\' ->
- Stream.junk strm__;
- let ep = Stream.count strm__ in
- ("LIDENT", get_buff (ident3 0 strm__)), (bp, ep)
- | Some c ->
- Stream.junk strm__;
- let ep = Stream.count strm__ in
- keyword_or_error (bp, ep) (String.make 1 c)
- | _ -> let _ = Stream.empty strm__ in ("EOI", ""), (bp, succ bp)
- and less bp strm =
- if !no_quotations then
- let (strm__ : _ Stream.t) = strm in
- let len = ident2 (store 0 '<') strm__ in
- let ep = Stream.count strm__ in
- let id = get_buff len in keyword_or_error (bp, ep) id
- else
- let (strm__ : _ Stream.t) = strm in
- match Stream.peek strm__ with
- Some '<' ->
- Stream.junk strm__;
- let len =
- try quotation bp 0 strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in
- ("QUOTATION", ":" ^ get_buff len), (bp, ep)
- | Some ':' ->
- Stream.junk strm__;
- let i =
- try let len = ident 0 strm__ in get_buff len with
- Stream.Failure -> raise (Stream.Error "")
- in
- begin match Stream.peek strm__ with
- Some '<' ->
- Stream.junk strm__;
- let len =
- try quotation bp 0 strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in
- ("QUOTATION", i ^ ":" ^ get_buff len), (bp, ep)
- | _ -> raise (Stream.Error "character '<' expected")
- end
- | _ ->
- let len = ident2 (store 0 '<') strm__ in
- let ep = Stream.count strm__ in
- let id = get_buff len in keyword_or_error (bp, ep) id
- and string bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\"' -> Stream.junk strm__; len
- | Some '\\' ->
- Stream.junk strm__;
- begin match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- let ep = Stream.count strm__ in
- string bp (store (store len '\\') c) strm__
- | _ -> raise (Stream.Error "")
- end
- | Some c -> Stream.junk strm__; string bp (store len c) strm__
- | _ ->
- let ep = Stream.count strm__ in err (bp, ep) "string not terminated"
- and char bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\'' ->
- Stream.junk strm__;
- let s = strm__ in if len = 0 then char bp (store len '\'') s else len
- | Some '\\' ->
- Stream.junk strm__;
- begin match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__; char bp (store (store len '\\') c) strm__
- | _ -> raise (Stream.Error "")
- end
- | Some c -> Stream.junk strm__; char bp (store len c) strm__
- | _ -> let ep = Stream.count strm__ in err (bp, ep) "char not terminated"
- and dollar bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len
- | Some ('a'..'z' | 'A'..'Z' as c) ->
- Stream.junk strm__; antiquot bp (store len c) strm__
- | Some ('0'..'9' as c) ->
- Stream.junk strm__; maybe_locate bp (store len c) strm__
- | Some ':' ->
- Stream.junk strm__;
- let k = get_buff len in
- "ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 strm__
- | Some '\\' ->
- Stream.junk strm__;
- begin match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__
- | _ -> raise (Stream.Error "")
- end
- | _ ->
- let s = strm__ in
- if dfa then
- let (strm__ : _ Stream.t) = s in
- match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) s
- | _ ->
- let ep = Stream.count strm__ in
- err (bp, ep) "antiquotation not terminated"
- else "", get_buff (ident2 (store 0 '$') s)
- and maybe_locate bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len
- | Some ('0'..'9' as c) ->
- Stream.junk strm__; maybe_locate bp (store len c) strm__
- | Some ':' ->
- Stream.junk strm__;
- "LOCATE", get_buff len ^ ":" ^ locate_or_antiquot_rest bp 0 strm__
- | Some '\\' ->
- Stream.junk strm__;
- begin match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__
- | _ -> raise (Stream.Error "")
- end
- | Some c ->
- Stream.junk strm__;
- "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__
- | _ ->
- let ep = Stream.count strm__ in
- err (bp, ep) "antiquotation not terminated"
- and antiquot bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '$' -> Stream.junk strm__; "ANTIQUOT", ":" ^ get_buff len
- | Some ('a'..'z' | 'A'..'Z' | '0'..'9' as c) ->
- Stream.junk strm__; antiquot bp (store len c) strm__
- | Some ':' ->
- Stream.junk strm__;
- let k = get_buff len in
- "ANTIQUOT", k ^ ":" ^ locate_or_antiquot_rest bp 0 strm__
- | Some '\\' ->
- Stream.junk strm__;
- begin match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__
- | _ -> raise (Stream.Error "")
- end
- | Some c ->
- Stream.junk strm__;
- "ANTIQUOT", ":" ^ locate_or_antiquot_rest bp (store len c) strm__
- | _ ->
- let ep = Stream.count strm__ in
- err (bp, ep) "antiquotation not terminated"
- and locate_or_antiquot_rest bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '$' -> Stream.junk strm__; get_buff len
- | Some '\\' ->
- Stream.junk strm__;
- begin match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- locate_or_antiquot_rest bp (store len c) strm__
- | _ -> raise (Stream.Error "")
- end
- | Some c ->
- Stream.junk strm__; locate_or_antiquot_rest bp (store len c) strm__
- | _ ->
- let ep = Stream.count strm__ in
- err (bp, ep) "antiquotation not terminated"
- and quotation bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '>' -> Stream.junk strm__; maybe_end_quotation bp len strm__
- | Some '<' ->
- Stream.junk strm__;
- quotation bp (maybe_nested_quotation bp (store len '<') strm__) strm__
- | Some '\\' ->
- Stream.junk strm__;
- let len =
- try
- match Stream.peek strm__ with
- Some ('>' | '<' | '\\' as c) -> Stream.junk strm__; store len c
- | _ -> store len '\\'
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- quotation bp len strm__
- | Some c -> Stream.junk strm__; quotation bp (store len c) strm__
- | _ ->
- let ep = Stream.count strm__ in
- err (bp, ep) "quotation not terminated"
- and maybe_nested_quotation bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '<' ->
- Stream.junk strm__; mstore (quotation bp (store len '<') strm__) ">>"
- | Some ':' ->
- Stream.junk strm__;
- let len =
- try ident (store len ':') strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- begin try
- match Stream.peek strm__ with
- Some '<' ->
- Stream.junk strm__;
- mstore (quotation bp (store len '<') strm__) ">>"
- | _ -> len
- with
- Stream.Failure -> raise (Stream.Error "")
- end
- | _ -> len
- and maybe_end_quotation bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '>' -> Stream.junk strm__; len
- | _ -> quotation bp (store len '>') strm__
- and left_paren bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '*' ->
- Stream.junk strm__;
- let _ =
- try comment bp strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- begin try next_token true strm__ with
- Stream.Failure -> raise (Stream.Error "")
- end
- | _ -> let ep = Stream.count strm__ in keyword_or_error (bp, ep) "("
- and comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '(' -> Stream.junk strm__; left_paren_in_comment bp strm__
- | Some '*' -> Stream.junk strm__; star_in_comment bp strm__
- | Some '\"' ->
- Stream.junk strm__;
- let _ =
- try string bp 0 strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- comment bp strm__
- | Some '\'' -> Stream.junk strm__; quote_in_comment bp strm__
- | Some c -> Stream.junk strm__; comment bp strm__
- | _ ->
- let ep = Stream.count strm__ in err (bp, ep) "comment not terminated"
- and quote_in_comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\'' -> Stream.junk strm__; comment bp strm__
- | Some '\\' -> Stream.junk strm__; quote_antislash_in_comment bp 0 strm__
- | _ ->
- let s = strm__ in
- begin match Stream.npeek 2 s with
- [_; '\''] -> Stream.junk s; Stream.junk s
- | _ -> ()
- end;
- comment bp s
- and quote_any_in_comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\'' -> Stream.junk strm__; comment bp strm__
- | _ -> comment bp strm__
- and quote_antislash_in_comment bp len (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\'' -> Stream.junk strm__; comment bp strm__
- | Some ('\\' | '\"' | 'n' | 't' | 'b' | 'r') ->
- Stream.junk strm__; quote_any_in_comment bp strm__
- | Some ('0'..'9') ->
- Stream.junk strm__; quote_antislash_digit_in_comment bp strm__
- | _ -> comment bp strm__
- and quote_antislash_digit_in_comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9') ->
- Stream.junk strm__; quote_antislash_digit2_in_comment bp strm__
- | _ -> comment bp strm__
- and quote_antislash_digit2_in_comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9') -> Stream.junk strm__; quote_any_in_comment bp strm__
- | _ -> comment bp strm__
- and left_paren_in_comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '*' ->
- Stream.junk strm__; let s = strm__ in comment bp s; comment bp s
- | _ -> comment bp strm__
- and star_in_comment bp (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ')' -> Stream.junk strm__; ()
- | _ -> comment bp strm__
- 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 (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('\013' | '\010') ->
- Stream.junk strm__; let ep = Stream.count strm__ in bolpos := ep
- | Some _ -> Stream.junk strm__; any_to_nl strm__
- | _ -> ()
- in
- fun cstrm ->
- try
- let glex = !glexr in
- let comm_bp = Stream.count cstrm in
- let r = next_token false cstrm in
- begin 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)
- | None -> ()
- end;
- r
- with
- Stream.Error str -> err (Stream.count cstrm, Stream.count cstrm + 1) str
-;;
-
-
-let dollar_for_antiquotation = ref true;;
-let specific_space_dot = ref false;;
-
-let func kwd_table glexr =
- let bolpos = ref 0 in
- let find = Hashtbl.find kwd_table in
- let dfa = !dollar_for_antiquotation in
- let ssd = !specific_space_dot in
- Token.lexer_func_of_parser (next_token_fun dfa ssd find bolpos glexr)
-;;
-
-let rec check_keyword_stream (strm__ : _ Stream.t) =
- let _ = check strm__ in
- let _ =
- try Stream.empty strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- true
-and check (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some
- ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255') ->
- Stream.junk strm__; check_ident strm__
- | Some
- ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
- '.') ->
- Stream.junk strm__; check_ident2 strm__
- | Some '<' ->
- Stream.junk strm__;
- let s = strm__ in
- begin match Stream.npeek 1 s with
- [':' | '<'] -> ()
- | _ -> check_ident2 s
- end
- | Some ':' ->
- Stream.junk strm__;
- let _ =
- try
- match Stream.peek strm__ with
- Some (']' | ':' | '=' | '>') -> Stream.junk strm__; ()
- | _ -> ()
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- let ep = Stream.count strm__ in ()
- | Some ('>' | '|') ->
- Stream.junk strm__;
- let _ =
- try
- match Stream.peek strm__ with
- Some (']' | '}') -> Stream.junk strm__; ()
- | _ -> check_ident2 strm__
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- ()
- | Some ('[' | '{') ->
- Stream.junk strm__;
- let s = strm__ in
- begin match Stream.npeek 2 s with
- ['<'; '<' | ':'] -> ()
- | _ ->
- let (strm__ : _ Stream.t) = s in
- match Stream.peek strm__ with
- Some ('|' | '<' | ':') -> Stream.junk strm__; ()
- | _ -> ()
- end
- | Some ';' ->
- Stream.junk strm__;
- let _ =
- try
- match Stream.peek strm__ with
- Some ';' -> Stream.junk strm__; ()
- | _ -> ()
- with
- Stream.Failure -> raise (Stream.Error "")
- in
- ()
- | Some _ -> Stream.junk strm__; ()
- | _ -> raise Stream.Failure
-and check_ident (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some
- ('A'..'Z' | 'a'..'z' | '\192'..'\214' | '\216'..'\246' |
- '\248'..'\255' | '0'..'9' | '_' | '\'') ->
- Stream.junk strm__; check_ident strm__
- | _ -> ()
-and check_ident2 (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some
- ('!' | '?' | '~' | '=' | '@' | '^' | '&' | '+' | '-' | '*' | '/' | '%' |
- '.' | ':' | '<' | '>' | '|') ->
- Stream.junk strm__; check_ident2 strm__
- | _ -> ()
-;;
-
-let check_keyword s =
- try check_keyword_stream (Stream.of_string s) with
- _ -> false
-;;
-
-let 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"))
-;;
-
-let error_ident_and_keyword p_con p_prm =
- raise
- (Token.Error
- ("the token \"" ^ p_prm ^ "\" is used as " ^ p_con ^
- " and as keyword"))
-;;
-
-let 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
- | "LIDENT" ->
- if p_prm = "" then ()
- else
- begin 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
- end
- | "UIDENT" ->
- if p_prm = "" then ()
- else
- begin 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
- end
- | "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"))
-;;
-
-let 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
- | _ -> ()
-;;
-
-let text =
- function
- "", 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 ^ "\""
-;;
-
-let eq_before_colon p e =
- let 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
- in
- loop 0
-;;
-
-let after_colon e =
- try
- let i = String.index e ':' in
- String.sub e (i + 1) (String.length e - i - 1)
- with
- Not_found -> ""
-;;
-
-let tok_match =
- function
- "ANTIQUOT", p_prm ->
- begin function
- "ANTIQUOT", prm when eq_before_colon p_prm prm -> after_colon prm
- | _ -> raise Stream.Failure
- end
- | tok -> Token.default_match tok
-;;
-
-let gmake () =
- let kwd_table = Hashtbl.create 301 in
- let id_table = Hashtbl.create 301 in
- let glexr =
- ref
- {tok_func = (fun _ -> raise (Match_failure ("plexer.ml", 972, 17)));
- tok_using = (fun _ -> raise (Match_failure ("plexer.ml", 972, 37)));
- tok_removing = (fun _ -> raise (Match_failure ("plexer.ml", 972, 60)));
- tok_match = (fun _ -> raise (Match_failure ("plexer.ml", 973, 18)));
- tok_text = (fun _ -> raise (Match_failure ("plexer.ml", 973, 37)));
- 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
- glexr := glex; glex
-;;
-
-let tparse =
- function
- "ANTIQUOT", p_prm ->
- let p (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ("ANTIQUOT", prm) when eq_before_colon p_prm prm ->
- Stream.junk strm__; after_colon prm
- | _ -> raise Stream.Failure
- in
- Some p
- | _ -> None
-;;
-
-let make () =
- let kwd_table = Hashtbl.create 301 in
- let id_table = Hashtbl.create 301 in
- let glexr =
- ref
- {tok_func = (fun _ -> raise (Match_failure ("plexer.ml", 1001, 17)));
- tok_using = (fun _ -> raise (Match_failure ("plexer.ml", 1001, 37)));
- tok_removing =
- (fun _ -> raise (Match_failure ("plexer.ml", 1001, 60)));
- tok_match = (fun _ -> raise (Match_failure ("plexer.ml", 1002, 18)));
- tok_text = (fun _ -> raise (Match_failure ("plexer.ml", 1002, 37)));
- 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/ocaml_src/lib/plexer.mli b/camlp4/ocaml_src/lib/plexer.mli
deleted file mode 100644
index 601c175331..0000000000
--- a/camlp4/ocaml_src/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. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-(** A lexical analyzer. *)
-
-val gmake : unit -> Token.t Token.glexer;;
- (** 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. *)
-
-val dollar_for_antiquotation : bool ref;;
- (** 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. *)
-
-val specific_space_dot : bool ref;;
- (** 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). *)
-
-val no_quotations : bool ref;;
- (** 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 *)
-val make : unit -> Token.lexer;;
diff --git a/camlp4/ocaml_src/lib/stdpp.ml b/camlp4/ocaml_src/lib/stdpp.ml
deleted file mode 100644
index d91ee78c07..0000000000
--- a/camlp4/ocaml_src/lib/stdpp.ml
+++ /dev/null
@@ -1,99 +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. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-exception Exc_located of (int * int) * exn;;
-
-let raise_with_loc loc exc =
- match exc with
- Exc_located (_, _) -> raise exc
- | _ -> raise (Exc_located (loc, exc))
-;;
-
-let 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 (strm__ : _ Stream.t) =
- let cnt = Stream.count strm__ in
- match Stream.peek strm__ with
- Some c ->
- Stream.junk strm__;
- let s = strm__ in
- 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
- | _ -> raise Stream.Failure
- in
- let rec a_line_dir str n col (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\n' -> Stream.junk strm__; loop str n
- | Some _ -> Stream.junk strm__; a_line_dir str n (col + 1) strm__
- | _ -> raise Stream.Failure
- in
- let rec spaces col (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ' ' -> Stream.junk strm__; spaces (col + 1) strm__
- | _ -> col
- in
- let rec check_string str n col (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\"' ->
- Stream.junk strm__;
- let col =
- try spaces (col + 1) strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- a_line_dir str n col strm__
- | Some c when c <> '\n' ->
- Stream.junk strm__;
- check_string (str ^ String.make 1 c) n (col + 1) strm__
- | _ -> not_a_line_dir col strm__
- in
- let check_quote n col (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '\"' -> Stream.junk strm__; check_string "" n (col + 1) strm__
- | _ -> not_a_line_dir col strm__
- in
- let rec check_num n col (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some ('0'..'9' as c) ->
- Stream.junk strm__;
- check_num (10 * n + Char.code c - Char.code '0') (col + 1) strm__
- | _ -> let col = spaces col strm__ in check_quote n col strm__
- in
- let begin_line (strm__ : _ Stream.t) =
- match Stream.peek strm__ with
- Some '#' ->
- Stream.junk strm__;
- let col =
- try spaces 1 strm__ with
- Stream.Failure -> raise (Stream.Error "")
- in
- check_num 0 col strm__
- | _ -> not_a_line_dir 0 strm__
- in
- begin_line strm
- in
- let r =
- try loop fname 1 with
- Stream.Failure -> fname, 1, bp, ep
- in
- close_in ic; r
- with
- Sys_error _ -> fname, 1, bp, ep
-;;
-
-let loc_name = ref "loc";;
diff --git a/camlp4/ocaml_src/lib/stdpp.mli b/camlp4/ocaml_src/lib/stdpp.mli
deleted file mode 100644
index 68c0cb6ada..0000000000
--- a/camlp4/ocaml_src/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. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-(** Standard definitions. *)
-
-exception Exc_located of (int * int) * 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]. *)
-
-val 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]. *)
-
-val 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. *)
-
-val loc_name : string ref;;
- (** Name of the location variable used in grammars and in the predefined
- quotations for OCaml syntax trees. Default: [loc] *)
diff --git a/camlp4/ocaml_src/lib/token.ml b/camlp4/ocaml_src/lib/token.ml
deleted file mode 100644
index bc8faeac3e..0000000000
--- a/camlp4/ocaml_src/lib/token.ml
+++ /dev/null
@@ -1,223 +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. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-type t = string * string;;
-type pattern = string * string;;
-
-exception Error of string;;
-
-type location = int * int;;
-type location_function = int -> int * int;;
-type 'te lexer_func = char Stream.t -> 'te Stream.t * location_function;;
-
-type 'te glexer =
- { tok_func : 'te lexer_func;
- tok_using : pattern -> unit;
- tok_removing : pattern -> unit;
- tok_match : pattern -> 'te -> string;
- tok_text : pattern -> string;
- mutable tok_comm : location list option }
-;;
-type lexer =
- { func : t lexer_func;
- using : pattern -> unit;
- removing : pattern -> unit;
- tparse : pattern -> (t Stream.t -> string) option;
- text : pattern -> string }
-;;
-
-let lexer_text (con, prm) =
- if con = "" then "'" ^ prm ^ "'"
- else if prm = "" then con
- else con ^ " '" ^ prm ^ "'"
-;;
-
-let locerr () = invalid_arg "Lexer: location function";;
-let loct_create () = ref (Array.create 1024 None), ref false;;
-let loct_func (loct, ov) i =
- match
- if i < 0 || i >= Array.length !loct then if !ov then Some (0, 0) else None
- else Array.unsafe_get !loct i
- with
- Some loc -> loc
- | _ -> locerr ()
-;;
-let loct_add (loct, ov) i loc =
- if i >= Array.length !loct then
- let new_tmax = Array.length !loct * 2 in
- if new_tmax < Sys.max_array_length then
- let new_loct = Array.create new_tmax None in
- Array.blit !loct 0 new_loct 0 (Array.length !loct);
- loct := new_loct;
- !loct.(i) <- Some loc
- else ov := true
- else !loct.(i) <- Some loc
-;;
-
-let 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 loct_add loct i loc; Some tok)
- in
- ts, loct_func loct
-;;
-
-let lexer_func_of_parser next_token_loc cs =
- make_stream_and_location (fun () -> next_token_loc cs)
-;;
-
-let lexer_func_of_ocamllex lexfun cs =
- let lb =
- Lexing.from_function
- (fun s n ->
- try 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 *)
-
-let buff = ref (String.create 80);;
-let store len x =
- if len >= String.length !buff then
- buff := !buff ^ String.create (String.length !buff);
- !buff.[len] <- x;
- succ len
-;;
-let mstore len s =
- let rec add_rec len i =
- if i == String.length s then len else add_rec (store len s.[i]) (succ i)
- in
- add_rec len 0
-;;
-let get_buff len = String.sub !buff 0 len;;
-
-let valch x = Char.code x - Char.code '0';;
-let valch_a x = Char.code x - Char.code 'a' + 10;;
-let valch_A x = Char.code x - Char.code 'A' + 10;;
-
-let 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
-;;
-
-let rec skip_indent s i =
- if i = String.length s then i
- else
- match s.[i] with
- ' ' | '\t' -> skip_indent s (i + 1)
- | _ -> i
-;;
-
-let skip_opt_linefeed s i =
- if i = String.length s then i else if s.[i] = '\010' then i + 1 else i
-;;
-
-let 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"
-;;
-
-let eval_string (bp, ep) s =
- let 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 ->
- 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
- in
- loop 0 0
-;;
-
-let default_match =
- function
- "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/ocaml_src/lib/token.mli b/camlp4/ocaml_src/lib/token.mli
deleted file mode 100644
index 9ddb41069b..0000000000
--- a/camlp4/ocaml_src/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. *)
-(* *)
-(***********************************************************************)
-
-(* This file has been generated by program: do not edit! *)
-
-(** 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 'te lexer_func = char Stream.t -> 'te Stream.t * 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 'te glexer =
- { tok_func : 'te lexer_func;
- tok_using : pattern -> unit;
- tok_removing : pattern -> unit;
- tok_match : pattern -> 'te -> string;
- tok_text : pattern -> string;
- mutable tok_comm : location list option }
-;;
- (** 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. *)
-
-val lexer_text : pattern -> string;;
- (** A simple [tok_text] function for lexers *)
-
-val 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. *)
-
-val lexer_func_of_parser :
- (char Stream.t -> 'te * location) -> 'te lexer_func;;
- (** A lexer function from a lexer written as a char stream parser
- returning the next token and its location. *)
-val lexer_func_of_ocamllex : (Lexing.lexbuf -> 'te) -> 'te lexer_func;;
- (** A lexer function from a lexer created by [ocamllex] *)
-
-val make_stream_and_location :
- (unit -> 'te * location) -> 'te Stream.t * location_function;;
- (** General function *)
-
-(** {6 Useful functions} *)
-
-val 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] *)
-
-val 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 : t lexer_func;
- using : pattern -> unit;
- removing : pattern -> unit;
- tparse : pattern -> (t Stream.t -> string) option;
- text : pattern -> string }
-;;
View Lorry Controller Status