« back to all changes in this revision
Viewing changes to lib/pre_sexp.ml
- browse files at revision 12
- compare with another revision
- download diff
- download tarball
- view history from revision 12
- Committer: Package Import Robot
- Author(s): Stéphane Glondu
- Date: 2013-12-03 21:36:45 UTC
- mfrom: (11.1.1 experimental)
- Revision ID: package-import@ubuntu.com-20131203213645-h1if1c6hxual8p11
Tags: 109.20.00-2
* Team upload
* Upload to unstable
* Upload to unstable
- files added:
- .gitignore
- lib_test_ounit
- vim
- vim/syntax
- files removed:
- .hg_archival.txt
- doc
- files modified:
- Makefile
added
removed
lib/pre_sexp.ml
1
(******************************************************************************
2
* Sexplib *
3
* *
4
* Copyright (C) 2005- Jane Street Holding, LLC *
5
* Contact: opensource@janestreet.com *
6
* WWW: http://www.janestreet.com/ocaml *
7
* Author: Markus Mottl *
8
* *
9
* This library is free software; you can redistribute it and/or *
10
* modify it under the terms of the GNU Lesser General Public *
11
* License as published by the Free Software Foundation; either *
12
* version 2 of the License, or (at your option) any later version. *
13
* *
14
* This library is distributed in the hope that it will be useful, *
15
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
16
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU *
17
* Lesser General Public License for more details. *
18
* *
19
* You should have received a copy of the GNU Lesser General Public *
20
* License along with this library; if not, write to the Free Software *
21
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA *
22
* *
23
******************************************************************************)
24
25
1
(* Sexp: Module for handling S-expressions (I/O, etc.) *)
26
2
27
3
open Format
41
17
42
18
(* Escaping of strings used as atoms in S-expressions *)
43
19
44
let is_special_char c =
45
c <= ' ' || c = '"' || c = '(' || c = ')' || c = ';' || c = '\\'
46
47
20
let must_escape str =
48
21
let len = String.length str in
49
22
len = 0 ||
50
let rec loop ix = is_special_char str.[ix] || ix > 0 && loop (ix - 1) in
23
let rec loop ix =
24
match str.[ix] with
25
| '"' | '(' | ')' | ';' | '\\' -> true
26
| '|' -> ix > 0 && let next = ix - 1 in str.[next] = '#' || loop next
27
| '#' -> ix > 0 && let next = ix - 1 in str.[next] = '|' || loop next
28
| c -> c <= ' ' || ix > 0 && loop (ix - 1)
29
in
51
30
loop (len - 1)
52
31
53
32
let maybe_esc_str str =
147
126
148
127
let to_buffer = to_buffer_mach
149
128
129
let to_buffer_gen ~buf ~add_char ~add_string sexp =
130
let rec loop may_need_space = function
131
| Atom str ->
132
let str' = maybe_esc_str str in
133
let new_may_need_space = str' == str in
134
if may_need_space && new_may_need_space then add_char buf ' ';
135
add_string buf str';
136
new_may_need_space
137
| List (h :: t) ->
138
add_char buf '(';
139
let may_need_space = loop false h in
140
loop_rest may_need_space t;
141
false
142
| List [] -> add_string buf "()"; false
143
and loop_rest may_need_space = function
144
| h :: t ->
145
let may_need_space = loop may_need_space h in
146
loop_rest may_need_space t
147
| [] -> add_char buf ')' in
148
ignore (loop false sexp)
149
150
150
151
151
(* Output of S-expressions to I/O-channels *)
152
152
153
let buffer () = Buffer.create 4096
153
(* The maximum size of a thing on the minor heap is 256 words.
154
Previously, this size of the returned buffer here was 4096 bytes, which
155
caused the Buffer to be allocated on the *major* heap every time.
156
157
According to a simple benchmark by Ron, we can improve performance for
158
small s-expressions by a factor of ~4 if we only allocate 1024 bytes
159
(128 words + some small overhead) worth of buffer initially. And one
160
can argue that if it's free to allocate strings smaller than 256 words,
161
large s-expressions requiring larger expensive buffers won't notice
162
the extra two doublings from 1024 bytes to 2048 and 4096. And especially
163
performance-sensitive applications to always pass in a larger buffer to
164
use. *)
165
let buffer () = Buffer.create 1024
154
166
155
167
let with_new_buffer oc f =
156
168
let buf = buffer () in
171
183
172
184
(* Output of S-expressions to file *)
173
185
186
(* The temp file functions in the OCaml Filename module do not support
187
permissions. But opening a file with given permissions is different
188
from opening it and chmoding it to these permissions, because the umask
189
is taken in account. Under Unix there's no easy way to get the umask in
190
a thread-safe way. *)
191
module Tmp_file = struct
192
let prng = ref None
193
194
let temp_file_name prefix suffix =
195
let rand_state = match !prng with
196
| Some v -> v
197
| None ->
198
let ret = Random.State.make_self_init () in
199
prng := Some ret;
200
ret
201
in
202
let rnd = (Random.State.bits rand_state) land 0xFFFFFF in
203
Printf.sprintf "%s%06x%s" prefix rnd suffix
204
205
(* Keep the permissions loose. Sexps are usually shared and rarely private*)
206
let open_temp_file ?(perm = 0o666) prefix suffix =
207
let rec try_name counter =
208
let name = temp_file_name prefix suffix in
209
try
210
let oc =
211
open_out_gen [Open_wronly; Open_creat; Open_excl; Open_text] perm name
212
in
213
name, oc
214
with Sys_error _ as e ->
215
if counter >= 1000 then raise e else try_name (counter + 1)
216
in
217
try_name 0
218
end
219
174
220
let save_of_output ?perm output_function file sexp =
175
let tmp_name, oc =
176
let temp_dir =
177
if Filename.is_relative file then "."
178
else Filename.dir_sep
179
in
180
Filename.open_temp_file ~temp_dir file "tmp"
181
in
182
try
183
output_function oc sexp;
184
close_out oc;
185
let perm =
186
match perm with
187
| Some perm -> perm
188
| None ->
189
let umask = Unix.umask 0 in
190
ignore (Unix.umask umask);
191
umask lxor 0o666
192
in
193
if perm <> 0o600 then Unix.chmod tmp_name perm;
194
Sys.rename tmp_name file
195
with
196
e ->
221
let tmp_name, oc = Tmp_file.open_temp_file ?perm file "tmp" in
222
begin
223
try
224
output_function oc sexp;
225
close_out oc;
226
with e ->
197
227
close_out_noerr oc;
228
begin try Sys.remove tmp_name with _ -> () end;
198
229
raise e
230
end;
231
Sys.rename tmp_name file
199
232
200
233
let output_sexp_nl do_output oc sexp =
201
234
do_output oc sexp;
241
274
(* Scan functions *)
242
275
243
276
let scan_sexp ?buf lexbuf = Parser.sexp (Lexer.main ?buf) lexbuf
277
let scan_sexp_opt ?buf lexbuf = Parser.sexp_opt (Lexer.main ?buf) lexbuf
244
278
let scan_sexps ?buf lexbuf = Parser.sexps (Lexer.main ?buf) lexbuf
279
let scan_rev_sexps ?buf lexbuf = Parser.rev_sexps (Lexer.main ?buf) lexbuf
245
280
246
281
let get_main_buf buf =
247
282
let buf =
248
283
match buf with
249
| None -> Buffer.create 64
284
| None -> Buffer.create 128
250
285
| Some buf -> buf in
251
286
Lexer.main ~buf
252
287
321
356
let with_buf_pos t buf_pos = { t with buf_pos }
322
357
end
323
358
359
module Cont_state = struct
360
type t =
361
| Parsing_whitespace
362
| Parsing_atom
363
| Parsing_list
364
| Parsing_sexp_comment
365
| Parsing_block_comment
366
367
let to_string = function
368
| Parsing_whitespace -> "Parsing_whitespace"
369
| Parsing_atom -> "Parsing_atom"
370
| Parsing_list -> "Parsing_list"
371
| Parsing_sexp_comment -> "Parsing_sexp_comment"
372
| Parsing_block_comment -> "Parsing_block_comment"
373
end
374
324
375
type ('a, 't) parse_result =
325
376
| Done of 't * Parse_pos.t
326
| Cont of bool * ('a, 't) parse_fun
377
| Cont of Cont_state.t * ('a, 't) parse_fun
327
378
328
379
and ('a, 't) parse_fun = pos : int -> len : int -> 'a -> ('a, 't) parse_result
329
380
347
398
348
399
exception Parse_error of parse_error
349
400
350
let bump_text_line { parse_pos } =
401
let bump_text_line { parse_pos; _ } =
351
402
parse_pos.Parse_pos.text_line <- parse_pos.Parse_pos.text_line + 1;
352
403
parse_pos.Parse_pos.text_char <- 0
353
404
354
let bump_text_pos { parse_pos } =
405
let bump_text_pos { parse_pos; _ } =
355
406
parse_pos.Parse_pos.text_char <- parse_pos.Parse_pos.text_char + 1
356
407
357
408
let bump_pos_cont state str ~max_pos ~pos cont =
378
429
parse_pos.Parse_pos.buf_pos <- buf_pos;
379
430
parse_pos.Parse_pos.global_offset <- parse_pos.Parse_pos.global_offset + len
380
431
381
let mk_parse_pos { parse_pos } buf_pos =
432
let mk_parse_pos { parse_pos; _ } buf_pos =
382
433
set_parse_pos parse_pos buf_pos;
383
434
parse_pos
384
435
385
436
let raise_parse_error parse_state location buf_pos err_msg =
386
begin
387
match parse_state with
388
| `Sexp { parse_pos } | `Annot { parse_pos } ->
389
set_parse_pos parse_pos buf_pos;
390
parse_pos.Parse_pos.text_char <- parse_pos.Parse_pos.text_char + 1;
391
end;
392
let parse_error = { location; err_msg; parse_state } in
393
raise (Parse_error parse_error)
437
match parse_state with
438
| `Sexp { parse_pos; _ } | `Annot { parse_pos; _ } ->
439
set_parse_pos parse_pos buf_pos;
440
let parse_error = { location; err_msg; parse_state } in
441
raise (Parse_error parse_error)
394
442
395
443
let raise_unexpected_char parse_state location buf_pos c =
396
444
let err_msg = sprintf "unexpected character: '%c'" c in
397
445
raise_parse_error parse_state location buf_pos err_msg
398
446
399
(* The code below is derived from lexer.mll in the OCaml distribution,
400
which also uses ASCII codes instead of escape sequences to denote
401
special characters. *)
447
let mk_cont_parser cont_parse = (); fun _state str ~max_pos ~pos ->
448
let len = max_pos - pos + 1 in
449
cont_parse ~pos ~len str
402
450
403
451
(* Macro for generating parsers *)
404
452
#define MK_PARSER( \
427
475
if pos_len > str_len then invalid_arg (loc ^ ": pos + len > str_len"); \
428
476
pos_len - 1 \
429
477
\
430
let mk_cont name cont state = \
431
let ws_only = GET_PSTACK = [] && Buffer.length state.pbuf = 0 in \
478
let mk_cont_state name cont state ~cont_state = \
432
479
let parse_fun = \
433
480
let used_ref = ref false in \
434
481
fun ~pos ~len str -> \
440
487
cont state str ~max_pos ~pos \
441
488
end \
442
489
in \
443
Cont (ws_only, parse_fun) \
490
Cont (cont_state, parse_fun) \
491
\
492
let mk_cont name cont state = \
493
let cont_state = \
494
match GET_PSTACK = [], Buffer.length state.pbuf = 0 with \
495
| true, true -> Cont_state.Parsing_whitespace \
496
| false, true -> Cont_state.Parsing_list \
497
| _, false -> Cont_state.Parsing_atom \
498
in \
499
mk_cont_state name cont state ~cont_state \
444
500
\
445
501
let rec PARSE state str ~max_pos ~pos = \
446
502
if pos > max_pos then mk_cont "parse" PARSE state \
467
523
bump_pos_cont state str ~max_pos ~pos PARSE) \
468
524
| ' ' | '\009' | '\012' -> bump_pos_cont state str ~max_pos ~pos PARSE \
469
525
| '\010' -> bump_line_cont state str ~max_pos ~pos PARSE \
470
| '\013' -> bump_line_cont state str ~max_pos ~pos parse_nl \
526
| '\013' -> bump_pos_cont state str ~max_pos ~pos parse_nl \
471
527
| ';' -> bump_pos_cont state str ~max_pos ~pos parse_comment \
472
528
| '"' -> \
473
529
REGISTER_POS1 \
474
530
bump_pos_cont state str ~max_pos ~pos parse_quoted \
475
531
| c -> \
476
532
REGISTER_POS \
477
add_bump_pos state str ~max_pos ~pos c parse_atom \
533
let parse = \
534
match c with \
535
| '#' -> maybe_parse_comment \
536
| '|' -> maybe_parse_close_comment \
537
| _ -> parse_atom \
538
in \
539
add_bump_pos state str ~max_pos ~pos c parse \
478
540
\
479
541
and parse_nl state str ~max_pos ~pos = \
480
542
if pos > max_pos then mk_cont "parse_nl" parse_nl state \
481
543
else \
482
let pos = if GET_CHAR = '\010' then pos + 1 else pos in \
483
PARSE state str ~max_pos ~pos \
544
let c = GET_CHAR in \
545
if c = '\010' then bump_line_cont state str ~max_pos ~pos PARSE \
546
else raise_unexpected_char (MK_PARSE_STATE state) "parse_nl" pos c \
484
547
\
485
548
and parse_comment state str ~max_pos ~pos = \
486
549
if pos > max_pos then mk_cont "parse_comment" parse_comment state \
487
550
else \
488
551
match GET_CHAR with \
489
552
| '\010' -> bump_line_cont state str ~max_pos ~pos PARSE \
490
| '\013' -> bump_line_cont state str ~max_pos ~pos parse_nl \
553
| '\013' -> bump_pos_cont state str ~max_pos ~pos parse_nl \
491
554
| _ -> bump_pos_cont state str ~max_pos ~pos parse_comment \
492
555
\
556
and maybe_parse_comment state str ~max_pos ~pos = \
557
if pos > max_pos then \
558
mk_cont "maybe_parse_comment" maybe_parse_comment state \
559
else \
560
match GET_CHAR with \
561
| ';' -> bump_pos_cont state str ~max_pos ~pos parse_sexp_comment \
562
| '|' -> bump_pos_cont state str ~max_pos ~pos parse_block_comment \
563
| _ -> parse_atom state str ~max_pos ~pos \
564
\
565
and maybe_parse_close_comment state str ~max_pos ~pos = \
566
if pos > max_pos then \
567
mk_cont "maybe_parse_close_comment" maybe_parse_close_comment state \
568
else \
569
if GET_CHAR <> '#' then parse_atom state str ~max_pos ~pos \
570
else \
571
let err_msg = "end of block comment without start" in \
572
raise_parse_error (MK_PARSE_STATE state) \
573
"maybe_parse_close_comment" pos err_msg \
574
\
575
and parse_sexp_comment state str ~max_pos ~pos = \
576
let pbuf_str = "" in \
577
ignore (MK_ATOM); \
578
Buffer.clear state.pbuf; \
579
let old_pstack = GET_PSTACK in \
580
let pstack = [] in \
581
SET_PSTACK; \
582
let rec loop parse state str ~max_pos ~pos = \
583
match parse state str ~max_pos ~pos with \
584
| Done (_sexp, { Parse_pos.buf_pos = pos; _ }) -> \
585
Buffer.clear state.pbuf; \
586
let pstack = old_pstack in \
587
SET_PSTACK; \
588
PARSE state str ~max_pos ~pos \
589
| Cont (_, cont_parse) -> \
590
Buffer.clear state.pbuf; \
591
let parse = mk_cont_parser cont_parse in \
592
mk_cont_state "parse_sexp_comment" (loop parse) state \
593
~cont_state:Cont_state.Parsing_sexp_comment \
594
in \
595
loop PARSE state str ~max_pos ~pos \
596
\
597
and parse_block_comment state str ~max_pos ~pos = \
598
let pbuf_str = "" in \
599
ignore (MK_ATOM); \
600
Buffer.clear state.pbuf; \
601
let old_pstack = GET_PSTACK in \
602
let pstack = [] in \
603
SET_PSTACK; \
604
let rec loop depth state str ~max_pos ~pos = \
605
let rec parse_block_depth state str ~max_pos ~pos = \
606
if pos > max_pos then \
607
mk_cont "parse_block_depth" parse_block_depth state \
608
else \
609
match GET_CHAR with \
610
| '\010' -> bump_line_cont state str ~max_pos ~pos parse_block_depth \
611
| '"' -> \
612
REGISTER_POS1 \
613
let rec parse_block_quote parse state str ~max_pos ~pos = \
614
match parse state str ~max_pos ~pos with \
615
| Done (_sexp, { Parse_pos.buf_pos = pos; _ }) -> \
616
Buffer.clear state.pbuf; \
617
parse_block_depth state str ~max_pos ~pos \
618
| Cont (_, cont_parse) -> \
619
Buffer.clear state.pbuf; \
620
let parse = mk_cont_parser cont_parse in \
621
mk_cont_state "parse_block_quote" \
622
(parse_block_quote parse) state \
623
~cont_state:Cont_state.Parsing_block_comment \
624
in \
625
bump_pos_cont state str ~max_pos ~pos \
626
(parse_block_quote parse_quoted) \
627
| '#' -> bump_pos_cont state str ~max_pos ~pos parse_open_block \
628
| '|' -> bump_pos_cont state str ~max_pos ~pos parse_close_block \
629
| _ -> bump_pos_cont state str ~max_pos ~pos parse_block_depth \
630
and parse_open_block state str ~max_pos ~pos = \
631
if pos > max_pos then \
632
mk_cont "parse_open_block" parse_open_block state \
633
else \
634
if GET_CHAR = '|' then \
635
bump_pos_cont state str ~max_pos ~pos (loop (depth + 1)) \
636
else parse_block_depth state str ~max_pos ~pos \
637
and parse_close_block state str ~max_pos ~pos = \
638
if pos > max_pos then \
639
mk_cont "parse_close_block" parse_close_block state \
640
else if GET_CHAR = '#' then \
641
let parse = \
642
if depth = 1 then \
643
let () = Buffer.clear state.pbuf in \
644
let pstack = old_pstack in \
645
SET_PSTACK; \
646
PARSE \
647
else loop (depth - 1) \
648
in \
649
bump_pos_cont state str ~max_pos ~pos parse \
650
else parse_block_depth state str ~max_pos ~pos \
651
in \
652
parse_block_depth state str ~max_pos ~pos \
653
in \
654
loop 1 state str ~max_pos ~pos \
655
\
493
656
and parse_atom state str ~max_pos ~pos = \
494
657
if pos > max_pos then mk_cont "parse_atom" parse_atom state \
495
658
else \
496
659
match GET_CHAR with \
497
660
| ' ' | '\009' | '\012' -> \
498
661
bump_found_atom bump_text_pos state str ~max_pos ~pos PARSE \
662
| '#' as c -> \
663
add_bump_pos state str ~max_pos ~pos c maybe_parse_bad_atom_hash \
664
| '|' as c -> \
665
add_bump_pos state str ~max_pos ~pos c maybe_parse_bad_atom_pipe \
499
666
| '(' -> \
500
667
let pbuf = state.pbuf in \
501
668
let pbuf_str = Buffer.contents pbuf in \
528
695
bump_pos_cont state str ~max_pos ~pos PARSE) \
529
696
| '\010' -> bump_found_atom bump_text_line state str ~max_pos ~pos PARSE \
530
697
| '\013' -> \
531
bump_found_atom bump_text_line state str ~max_pos ~pos parse_nl \
698
bump_found_atom bump_text_pos state str ~max_pos ~pos parse_nl \
532
699
| ';' -> \
533
700
bump_found_atom bump_text_pos state str ~max_pos ~pos parse_comment \
534
701
| '"' -> \
536
703
bump_text_pos state str ~max_pos ~pos reg_parse_quoted \
537
704
| c -> add_bump_pos state str ~max_pos ~pos c parse_atom \
538
705
\
706
and maybe_parse_bad_atom_pipe state str ~max_pos ~pos = \
707
if pos > max_pos then \
708
mk_cont "maybe_parse_bad_atom_pipe" maybe_parse_bad_atom_pipe state \
709
else \
710
match GET_CHAR with \
711
| '#' -> \
712
let err_msg = "illegal end of block comment in unquoted atom" in \
713
raise_parse_error (MK_PARSE_STATE state) "maybe_parse_bad_atom_pipe" \
714
pos err_msg \
715
| _ -> parse_atom state str ~max_pos ~pos \
716
\
717
and maybe_parse_bad_atom_hash state str ~max_pos ~pos = \
718
if pos > max_pos then \
719
mk_cont "maybe_parse_bad_atom_hash" maybe_parse_bad_atom_hash state \
720
else \
721
match GET_CHAR with \
722
| '|' -> \
723
let err_msg = "illegal start of block comment in unquoted atom" in \
724
raise_parse_error (MK_PARSE_STATE state) "maybe_parse_bad_atom_hash" \
725
pos err_msg \
726
| _ -> parse_atom state str ~max_pos ~pos \
727
\
539
728
and reg_parse_quoted state str ~max_pos ~pos = \
540
729
REGISTER_POS \
541
730
parse_quoted state str ~max_pos ~pos \
731
\
542
732
and parse_quoted state str ~max_pos ~pos = \
543
733
if pos > max_pos then mk_cont "parse_quoted" parse_quoted state \
544
734
else \
556
746
bump_pos_cont state str ~max_pos ~pos PARSE) \
557
747
| '\\' -> bump_pos_cont state str ~max_pos ~pos parse_escaped \
558
748
| '\010' as c -> add_bump_line state str ~max_pos ~pos c parse_quoted \
559
| '\013' as c -> add_bump_line state str ~max_pos ~pos c parse_quoted_nl \
560
749
| c -> add_bump_pos state str ~max_pos ~pos c parse_quoted \
561
750
\
562
and parse_quoted_nl state str ~max_pos ~pos = \
563
if pos > max_pos then mk_cont "parse_quoted_nl" parse_quoted_nl state \
564
else \
565
let pos = \
566
let c = '\010' in \
567
if GET_CHAR = c then ( \
568
Buffer.add_char state.pbuf c; \
569
pos + 1 \
570
) \
571
else pos \
572
in \
573
parse_quoted state str ~max_pos ~pos \
574
\
575
751
and parse_escaped state str ~max_pos ~pos = \
576
752
if pos > max_pos then mk_cont "parse_escaped" parse_escaped state \
577
753
else \
578
754
match GET_CHAR with \
579
755
| '\010' -> bump_line_cont state str ~max_pos ~pos parse_skip_ws \
580
| '\013' -> bump_line_cont state str ~max_pos ~pos parse_skip_ws_nl \
756
| '\013' -> bump_pos_cont state str ~max_pos ~pos parse_skip_ws_nl \
581
757
| '0' .. '9' as c -> \
582
758
bump_text_pos state; \
583
759
let d = Char.code c - 48 in \
605
781
and parse_skip_ws_nl state str ~max_pos ~pos = \
606
782
if pos > max_pos then mk_cont "parse_skip_ws_nl" parse_skip_ws_nl state \
607
783
else \
608
let pos = if GET_CHAR = '\010' then pos + 1 else pos in \
609
parse_skip_ws state str ~max_pos ~pos \
784
if GET_CHAR = '\010' then \
785
bump_line_cont state str ~max_pos ~pos parse_skip_ws \
786
else begin \
787
Buffer.add_char state.pbuf '\013'; \
788
parse_quoted state str ~max_pos ~pos \
789
end \
610
790
\
611
791
and parse_dec state str ~max_pos ~pos ~count ~d = \
612
792
if pos > max_pos then mk_cont "parse_dec" (parse_dec ~count ~d) state \
680
860
parse_pos.Parse_pos.global_offset + pos - parse_pos.Parse_pos.buf_pos
681
861
682
862
let mk_annot_pos
683
({ Parse_pos.text_line = line; text_char = col } as parse_pos) pos =
863
({ Parse_pos.text_line = line; text_char = col; _ } as parse_pos) pos =
684
864
{ Annot.line; col; offset = get_glob_ofs parse_pos pos }
685
865
686
866
let mk_annot_pos1
687
({ Parse_pos.text_line = line; text_char = col } as parse_pos) pos =
867
({ Parse_pos.text_line = line; text_char = col; _ } as parse_pos) pos =
688
868
{ Annot.line; col = col + 1; offset = get_glob_ofs parse_pos pos }
689
869
690
let add_annot_pos { parse_pos; pstack } pos =
870
let add_annot_pos { parse_pos; pstack; pbuf = _ } pos =
691
871
pstack.Annot.positions <- mk_annot_pos parse_pos pos :: pstack.Annot.positions
692
872
693
let add_annot_pos1 { parse_pos; pstack } pos =
873
let add_annot_pos1 { parse_pos; pstack; pbuf = _ } pos =
694
874
pstack.Annot.positions <-
695
875
mk_annot_pos1 parse_pos pos :: pstack.Annot.positions
696
876
697
let get_annot_range { parse_pos; pstack } pos =
877
let get_annot_range { parse_pos; pstack; pbuf = _ } pos =
698
878
let start_pos =
699
879
match pstack.Annot.positions with
700
880
| [] -> assert false (* impossible *)
777
957
let gen_input_rev_sexps my_parse ?parse_pos ?(buf = String.create 8192) ic =
778
958
let rev_sexps_ref = ref [] in
779
959
let buf_len = String.length buf in
780
let rec loop this_parse ~pos ~len ~is_incomplete =
960
let rec loop this_parse ~pos ~len ~cont_state =
781
961
if len > 0 then
782
962
match this_parse ~pos ~len buf with
783
| Done (sexp, ({ Parse_pos.buf_pos } as parse_pos)) ->
963
| Done (sexp, ({ Parse_pos.buf_pos; _ } as parse_pos)) ->
784
964
rev_sexps_ref := sexp :: !rev_sexps_ref;
785
965
let n_parsed = buf_pos - pos in
786
966
let this_parse = mk_this_parse ~parse_pos my_parse in
967
let cont_state = Cont_state.Parsing_whitespace in
787
968
if n_parsed = len then
788
969
let new_len = input ic buf 0 buf_len in
789
loop this_parse ~pos:0 ~len:new_len ~is_incomplete:false
790
else
791
loop this_parse
792
~pos:buf_pos ~len:(len - n_parsed) ~is_incomplete:false
793
| Cont (ws_only, this_parse) ->
794
loop this_parse
795
~pos:0 ~len:(input ic buf 0 buf_len) ~is_incomplete:(not ws_only)
796
else if is_incomplete then
797
failwith
798
"Sexplib.Sexp.input_rev_sexps: reached EOF with incomplete S-expression"
799
else !rev_sexps_ref
970
loop this_parse ~pos:0 ~len:new_len ~cont_state
971
else loop this_parse ~pos:buf_pos ~len:(len - n_parsed) ~cont_state
972
| Cont (cont_state, this_parse) ->
973
loop this_parse ~pos:0 ~len:(input ic buf 0 buf_len) ~cont_state
974
else
975
if cont_state = Cont_state.Parsing_whitespace then !rev_sexps_ref
976
else
977
failwith (
978
"Sexplib.Sexp.input_rev_sexps: reached EOF while in state "
979
^ Cont_state.to_string cont_state)
800
980
in
801
981
let len = input ic buf 0 buf_len in
802
982
let this_parse = mk_this_parse ?parse_pos my_parse in
803
loop this_parse ~pos:0 ~len ~is_incomplete:false
983
loop this_parse ~pos:0 ~len ~cont_state:Cont_state.Parsing_whitespace
804
984
805
985
let input_rev_sexps ?parse_pos ?buf ic =
806
986
gen_input_rev_sexps parse ?parse_pos ?buf ic
813
993
814
994
let of_string_bigstring loc this_parse ws_buf get_len get_sub str =
815
995
match this_parse str with
816
| Done (_, { Parse_pos.buf_pos }) when buf_pos <> get_len str ->
996
| Done (_, { Parse_pos.buf_pos; _ }) when buf_pos <> get_len str ->
817
997
let prefix_len = min (get_len str - buf_pos) 20 in
818
998
let prefix = get_sub str buf_pos prefix_len in
819
999
let msg =
823
1003
in
824
1004
failwith msg
825
1005
| Done (sexp, _) -> sexp
826
| Cont (ws_only, this_parse) ->
827
if ws_only then failwith (sprintf "Sexplib.Sexp.%s: whitespace only" loc);
1006
| Cont (_, this_parse) ->
828
1007
(* When parsing atoms, the incremental parser cannot tell whether
829
it is at the end until it hits whitespace. We therefore feed
830
it one space to determine whether it is finished. *)
1008
it is at the end until it hits whitespace. We therefore feed it
1009
one space to determine whether it is finished. *)
831
1010
match this_parse ~pos:0 ~len:1 ws_buf with
832
1011
| Done (sexp, _) -> sexp
833
| Cont _ ->
1012
| Cont (cont_state, _) ->
1013
let cont_state_str = Cont_state.to_string cont_state in
834
1014
failwith (
835
sprintf "Sexplib.Sexp.%s: got incomplete S-expression: %s"
836
loc (get_sub str 0 (get_len str)))
1015
sprintf
1016
"Sexplib.Sexp.%s: incomplete S-expression while in state %s: %s"
1017
loc cont_state_str (get_sub str 0 (get_len str)))
837
1018
838
1019
let of_string str =
839
1020
of_string_bigstring "of_string" parse " " String.length String.sub str
865
1046
866
1047
let load_sexps ?buf file = List.rev (load_rev_sexps ?buf file)
867
1048
1049
let gen_load_sexp_loc = "Sexplib.Sexp.gen_load_sexp"
1050
868
1051
let gen_load_sexp my_parse ?(strict = true) ?(buf = String.create 8192) file =
869
1052
let buf_len = String.length buf in
870
1053
let ic = open_in file in
871
let rec loop this_parse =
1054
let rec loop this_parse ~cont_state =
872
1055
let len = input ic buf 0 buf_len in
873
1056
if len = 0 then
874
failwith (sprintf "Sexplib.Sexp.gen_load_sexp: end of file: %s" file)
1057
failwith (
1058
sprintf "%s: EOF in %s while in state %s"
1059
gen_load_sexp_loc file (Cont_state.to_string cont_state))
875
1060
else
876
1061
match this_parse ~pos:0 ~len buf with
877
| Done (sexp, ({ Parse_pos.buf_pos } as parse_pos))
878
when strict ->
1062
| Done (sexp, ({ Parse_pos.buf_pos; _ } as parse_pos)) when strict ->
879
1063
let rec strict_loop this_parse ~pos ~len =
880
1064
match this_parse ~pos ~len buf with
881
| Done _ | Cont (false, _) ->
1065
| Done _ ->
882
1066
failwith (
883
sprintf
884
"Sexplib.Sexp.gen_load_sexp: more than one S-expression: %s"
885
file)
886
| Cont (true, this_parse) ->
1067
sprintf "%s: more than one S-expression in file %s"
1068
gen_load_sexp_loc file)
1069
| Cont (cont_state, this_parse) ->
887
1070
let len = input ic buf 0 buf_len in
888
if len = 0 then sexp
889
else strict_loop this_parse ~pos:0 ~len
1071
if len > 0 then strict_loop this_parse ~pos:0 ~len
1072
else if cont_state = Cont_state.Parsing_whitespace then sexp
1073
else
1074
failwith (
1075
sprintf "%s: %s in state %s loading file %s"
1076
gen_load_sexp_loc "additional incomplete data"
1077
(Cont_state.to_string cont_state) file)
890
1078
in
891
1079
let this_parse = mk_this_parse ~parse_pos my_parse in
892
1080
strict_loop this_parse ~pos:buf_pos ~len:(len - buf_pos)
893
1081
| Done (sexp, _) -> sexp
894
| Cont (_, this_parse) -> loop this_parse
1082
| Cont (cont_state, this_parse) -> loop this_parse ~cont_state
895
1083
in
896
1084
try
897
let sexp = loop (mk_this_parse my_parse) in
1085
let sexp =
1086
loop (mk_this_parse my_parse) ~cont_state:Cont_state.Parsing_whitespace
1087
in
898
1088
close_in ic;
899
1089
sexp
900
1090
with exc -> close_in_noerr ic; raise exc
938
1128
939
1129
let get_conv_exn ~file ~exc annot_sexp =
940
1130
let range = get_range annot_sexp in
941
let { start_pos = { line; col } } = range in
1131
let { start_pos = { line; col; offset = _ }; end_pos = _ } = range in
942
1132
let loc = sprintf "%s:%d:%d" file line col in
943
1133
Of_sexp_error (Annot.Conv_exn (loc, exc), get_sexp annot_sexp)
944
1134
end
1043
1233
| `Pos (pos, found) ->
1044
1234
match sexp with
1045
1235
| Atom _ ->
1046
failwith
1047
"Sexplib.Sexp.subst_search_result: atom when position requested"
1236
failwith "Sexplib.Sexp.subst_found: atom when position requested"
1048
1237
| List lst ->
1049
1238
let rec loop acc pos = function
1050
1239
| [] ->
1051
1240
failwith
1052
"Sexplib.Sexp.subst_search_result: \
1053
short list when position requested"
1241
"Sexplib.Sexp.subst_found: short list when position requested"
1054
1242
| h :: t when pos <> 0 -> loop (h :: acc) (pos - 1) t
1055
1243
| h :: t ->
1056
1244
List (List.rev_append acc (subst_found h ~subst found :: t))
1057
1245
in
1058
1246
loop [] pos lst
1247
Loggerhead is a web-based interface for Breezy
Version: 2.0.1