1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
|
(***********************************************************************)
(* *)
(* HEVEA *)
(* *)
(* Luc Maranget, projet PARA, INRIA Rocquencourt *)
(* *)
(* Copyright 1999 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
exception Fatal of string
exception NoSupport of string
exception Purposly of string
exception ScanError of string
exception UserError of string
exception EndInput
exception EndDocument
exception Close of string
exception CannotPut
exception EndOfLispComment of int (* QNC *)
let verbose = ref 0
and readverb = ref 0
and displayverb = ref false
let silent = ref false
let column_to_command s = "\\@"^s^"@"
let warning s =
if not !silent || !verbose > 0 then begin
Location.print_pos () ;
prerr_string "Warning: " ;
prerr_endline s
end
let print_verb level s =
if !verbose > level then begin
Location.print_pos () ;
prerr_endline s
end
let message s =
if not !silent || !verbose > 0 then prerr_endline s
let fatal s = raise (Fatal s)
let not_supported s = raise (NoSupport s)
let rec rev_iter f = function
| [] -> ()
| x::rem -> rev_iter f rem ; f x
let copy_hashtbl from_table to_table =
Hashtbl.clear to_table ;
let module OString =
struct
type t = string
let compare = Stdlib.compare
end in
let module Strings = Set.Make (OString) in
let keys = ref Strings.empty in
Hashtbl.iter
(fun key _ -> keys := Strings.add key !keys)
from_table ;
Strings.iter
(fun key ->
let vals = Hashtbl.find_all from_table key in
rev_iter (Hashtbl.add to_table key) vals)
!keys
let copy_int_hashtbl from_table to_table =
Hashtbl.clear to_table ;
let module OInt =
struct
type t = int
let compare x y = x-y
end in
let module Ints = Set.Make (OInt) in
let keys = ref Ints.empty in
Hashtbl.iter
(fun key _ -> keys := Ints.add key !keys)
from_table ;
Ints.iter
(fun key ->
let vals = Hashtbl.find_all from_table key in
rev_iter (Hashtbl.add to_table key) vals)
!keys
let start_env env = "\\"^ env
and end_env env = "\\end"^env
type limits = Limits | NoLimits | IntLimits
let image_opt = ref None
let set_image_opt s = image_opt := Some s
let get_image_opt () = match !image_opt with
| None -> ""
| Some s -> s
let dump_index = ref false
type saved = string option
let checkpoint () = !image_opt
and hot_start so = image_opt := so
let next_of_string s =
let len = String.length s
and k = ref 0 in
(fun () ->
let i = !k in
if i >= len then -1
else begin
incr k ;
Char.code (String.unsafe_get s i)
end)
let hexa c = match c with
| '0'..'9' -> Char.code c - Char.code '0'
| 'a'..'f' -> 10 + Char.code c - Char.code 'a'
| 'A'..'F' -> 10 + Char.code c - Char.code 'A'
| _ -> assert false
let hexa_code c1 c2 = 16 * hexa c1 + hexa c2
(* String utilities *)
let string_map f s =
let len = String.length s in
let out = Buffer.create len in
for k = 0 to len-1 do
Buffer.add_char out (f (String.get s k))
done ;
Buffer.contents out
(* Return first non-space from the end *)
let chop_trailing_spaces s =
let rec spaces_only k =
if k < 0 then k
else match s.[k] with
| ' ' -> spaces_only (k-1)
| _ -> k in
let nl k =
if k < 0 then k
else match s.[k] with
| '\n' -> k+1 (* keep paragraph *)
| ' ' -> spaces_only (k-1)
| _ -> k in
let rec no_nl k =
if k < 0 then k
else match s.[k] with
| '\n' -> nl (k-1)
| ' ' -> no_nl (k-1)
| _ -> k in
let len = String.length s in
let j = no_nl (len-1) in
let len0 = j+1 in
if len=len0 then s else String.sub s 0 len0
(* Useful module signature, output of functors called for initialisation *)
module type Rien = sig val rien : unit end
|
