blob: afe517c0e5dd01a0df3095a3bb763edc91be7c2e (
plain)
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
|
(* camlp4r *)
(***********************************************************************)
(* *)
(* Camlp4 *)
(* *)
(* Daniel de Rauglaudre, projet Cristal, INRIA Rocquencourt *)
(* *)
(* Copyright 2002 Institut National de Recherche en Informatique et *)
(* Automatique. Distributed only by permission. *)
(* *)
(***********************************************************************)
(* $Id$ *)
value buff = ref (String.create 80);
value store len x =
do {
if len >= String.length buff.val then
buff.val := buff.val ^ String.create (String.length buff.val)
else ();
buff.val.[len] := x;
succ len
}
;
value get_buff len = String.sub buff.val 0 len;
value rec copy_strip_locate cs =
match cs with parser
[ [: `'$' :] -> maybe_locate cs
| [: `c :] -> do { print_char c; copy_strip_locate cs }
| [: :] -> () ]
and maybe_locate cs =
match cs with parser
[ [: `'1'..'9' :] -> locate cs
| [: :] -> do { print_char '$'; copy_strip_locate cs } ]
and locate cs =
match cs with parser
[ [: `'0'..'9' :] -> locate cs
| [: `':' :] -> inside_locate cs
| [: :] -> raise (Stream.Error "colon char expected") ]
and inside_locate cs =
match cs with parser
[ [: `'$' :] -> copy_strip_locate cs
| [: `'\\'; `c :] -> do { print_char c; inside_locate cs }
| [: `c :] -> do { print_char c; inside_locate cs }
| [: :] -> raise (Stream.Error "end of file in locate directive") ]
;
value quot name pos str =
let exp =
try
match Quotation.find name with
[ Quotation.ExStr f -> f
| _ -> raise Not_found ]
with
[ Not_found ->
Stdpp.raise_with_loc (pos, pos + String.length str) Not_found ]
in
let new_str =
try exp True str with
[ Stdpp.Exc_located (p1, p2) exc ->
Stdpp.raise_with_loc (pos + p1, pos + p2) exc
| exc -> Stdpp.raise_with_loc (pos, pos + String.length str) exc ]
in
let cs = Stream.of_string new_str in copy_strip_locate cs
;
value rec ident len =
parser
[ [: `('A'..'Z' | 'a'..'z' | '0'..'9' | '_' | ''' as c); s :] ->
ident (store len c) s
| [: :] -> get_buff len ]
;
value rec copy cs =
match cs with parser
[ [: `'<' :] -> maybe_quot cs
| [: `'"' :] -> do { print_char '"'; inside_string cs }
| [: `c :] -> do { print_char c; copy cs }
| [: :] -> () ]
and maybe_quot cs =
match cs with parser
[ [: `'<' :] ep -> inside_quot "" ep 0 cs
| [: `':'; i = ident 0; `'<' ? "less char expected" :] ep ->
inside_quot i ep 0 cs
| [: :] -> do { print_char '<'; copy cs } ]
and inside_quot name pos len cs =
match cs with parser
[ [: `'>' :] -> maybe_end_quot name pos len cs
| [: `c :] -> inside_quot name pos (store len c) cs
| [: :] -> raise (Stream.Error "end of file in quotation") ]
and maybe_end_quot name pos len cs =
match cs with parser
[ [: `'>' :] -> do { quot name pos (get_buff len); copy cs }
| [: :] -> inside_quot name pos (store len '>') cs ]
and inside_string cs =
match cs with parser
[ [: `'"' :] -> do { print_char '"'; copy cs }
| [: `c :] -> do { print_char c; inside_string cs }
| [: :] -> raise (Stream.Error "end of file in string") ]
;
value copy_quot cs = do { copy cs; flush stdout; };
value loc_fmt =
match Sys.os_type with
[ "MacOS" ->
format_of_string "File \"%s\"; line %d; characters %d to %d\n### "
| _ ->
format_of_string "File \"%s\", line %d, characters %d-%d:\n" ]
;
value print_location loc file =
let (fname, line, c1, c2) = Stdpp.line_of_loc file loc in
do { Printf.eprintf loc_fmt file line c1 c2; flush stderr; }
;
value file = ref "";
Arg.parse [] (fun x -> file.val := x) "ocpp <objects> <file>";
value main () =
try
if file.val <> "" then
copy_quot (Stream.of_channel (open_in_bin file.val))
else ()
with exc ->
do {
print_newline ();
flush stdout;
let exc =
match exc with
[ Stdpp.Exc_located loc exc -> do { print_location loc file.val; exc }
| exc -> exc ]
in
raise exc
}
;
Odyl_main.name.val := "ocpp";
Odyl_main.go.val := main;
|
