package ecaml

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file value.ml

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
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
open! Core_kernel
open! Import
open! Async_kernel
open Value_intf
include Value0

module type Funcall = Funcall with type value := t
module type Make_subtype_arg = Make_subtype_arg with type value := t

module Emacs_value = struct
  type nonrec t = t
end

type value = t [@@deriving sexp_of]

(* [Funcall_exit.t] values are only constructed by [ecaml_non_local_exit_get_and_clear]
   in [ecaml_stubs.c]. *)
module Funcall_exit = struct
  type t =
    | Return
    | Signal of Emacs_value.t * Emacs_value.t
    | Throw of Emacs_value.t * Emacs_value.t
  [@@deriving variants]

  let initialize_module =
    assert (Variants.return.rank = 0);
    assert (Variants.signal.rank = 1);
    assert (Variants.throw.rank = 2)
  ;;
end

let initialize_module = Funcall_exit.initialize_module

external have_active_env : unit -> bool = "ecaml_have_active_env"

external non_local_exit_get_and_clear
  :  unit
  -> Funcall_exit.t
  = "ecaml_non_local_exit_get_and_clear"

exception
  Elisp_signal of
    { symbol : t
    ; data : t
    }

exception
  Elisp_throw of
    { tag : t
    ; value : t
    }

let raise_if_emacs_signaled () =
  match non_local_exit_get_and_clear () with
  | Return -> ()
  | Signal (symbol, data) -> raise (Elisp_signal { symbol; data })
  | Throw (tag, value) -> raise (Elisp_throw { tag; value })
;;

let wrap_raise1 f a =
  let r = f a in
  raise_if_emacs_signaled ();
  r
;;

let wrap_raise2 f a1 a2 =
  let r = f a1 a2 in
  raise_if_emacs_signaled ();
  r
;;

let wrap_raise3 f a1 a2 a3 =
  let r = f a1 a2 a3 in
  raise_if_emacs_signaled ();
  r
;;

external intern : string -> t = "ecaml_intern"

let intern = wrap_raise1 intern
let interned_symbols = String.Hash_set.create ()

let all_interned_symbols () =
  List.sort (Hash_set.to_list interned_symbols) ~compare:[%compare: string]
;;

let intern string =
  if am_running_test then Hash_set.add interned_symbols string;
  intern string
;;

module Q = struct
  let append = "append" |> intern
  and arrayp = "arrayp" |> intern
  and backtrace = "backtrace" |> intern
  and bufferp = "bufferp" |> intern
  and car = "car" |> intern
  and cadr = "cadr" |> intern
  and cdr = "cdr" |> intern
  and commandp = "commandp" |> intern
  and cons = "cons" |> intern
  and consp = "consp" |> intern
  and debug_on_error = "debug-on-error" |> intern
  and equal = "equal" |> intern
  and equal_including_properties = "equal-including-properties" |> intern
  and error = "error" |> intern
  and eventp = "eventp" |> intern
  and floatp = "floatp" |> intern
  and fontp = "fontp" |> intern
  and framep = "framep" |> intern
  and functionp = "functionp" |> intern
  and hash_table_p = "hash-table-p" |> intern
  and keymapp = "keymapp" |> intern
  and length = "length" |> intern
  and list = "list" |> intern
  and markerp = "markerp" |> intern
  and message = "message" |> intern
  and nil = "nil" |> intern
  and prin1_to_string = "prin1-to-string" |> intern
  and print_length = "print-length" |> intern
  and print_level = "print-level" |> intern
  and processp = "processp" |> intern
  and set = "set" |> intern
  and stringp = "stringp" |> intern
  and substring_no_properties = "substring-no-properties" |> intern
  and symbol_value = "symbol-value" |> intern
  and symbolp = "symbolp" |> intern
  and syntax_table_p = "syntax-table-p" |> intern
  and t = "t" |> intern
  and timerp = "timerp" |> intern
  and vector = "vector" |> intern
  and vectorp = "vectorp" |> intern
  and window_configuration_p = "window-configuration-p" |> intern
  and windowp = "windowp" |> intern
end

module Block_on_async = struct
  type t =
    { f :
        'a. Source_code_position.t -> ?context:Sexp.t Lazy.t -> (unit -> 'a Deferred.t)
        -> 'a
    }

  let set_once : t Set_once.t = Set_once.create ()
end

module Enqueue_foreground_block_on_async = struct
  type t =
    { f :
        Source_code_position.t
        -> ?context:Sexp.t Lazy.t
        -> ?raise_exceptions_to_monitor:Monitor.t
        -> (unit -> unit Deferred.t)
        -> unit
    }

  let set_once : t Set_once.t = Set_once.create ()
end

module Run_outside_async = struct
  type t =
    { f :
        'a. Source_code_position.t -> ?allowed_in_background:bool -> (unit -> 'a)
        -> 'a Deferred.t
    }

  let set_once : t Set_once.t = Set_once.create ()
end

let maybe_profile ~should_profile context f =
  if Option.value should_profile ~default:true then profile Sync context f else f ()
;;

external funcall_array : t -> t array -> bool -> t = "ecaml_funcall_array"

let funcall_array ?should_profile t ts ~should_return_result =
  maybe_profile
    ~should_profile
    (lazy [%sexp (t :: (ts |> Array.to_list) : t list)])
    (fun () -> funcall_array t ts should_return_result)
;;

let funcallN_array ?should_profile t ts =
  let r = funcall_array ?should_profile t ts ~should_return_result:true in
  raise_if_emacs_signaled ();
  r
;;

let funcallN_array_i ?should_profile t ts =
  ignore (funcall_array ?should_profile t ts ~should_return_result:false : t);
  raise_if_emacs_signaled ()
;;

let funcallN ?should_profile t ts = funcallN_array ?should_profile t (ts |> Array.of_list)

let funcallN_i ?should_profile t ts =
  funcallN_array_i ?should_profile t (ts |> Array.of_list)
;;

external funcall0 : t -> bool -> t = "ecaml_funcall0"
external funcall1 : t -> t -> bool -> t = "ecaml_funcall1"
external funcall2 : t -> t -> t -> bool -> t = "ecaml_funcall2"
external funcall3 : t -> t -> t -> t -> bool -> t = "ecaml_funcall3"

external funcall4
  :  t
  -> t
  -> t
  -> t
  -> t
  -> bool
  -> t
  = "ecaml_funcall4_byte" "ecaml_funcall4"

external funcall5
  :  t
  -> t
  -> t
  -> t
  -> t
  -> t
  -> bool
  -> t
  = "ecaml_funcall5_byte" "ecaml_funcall5"

let external_funcall1 = funcall1

let funcall0 f ~should_profile ~should_return_result =
  maybe_profile
    ~should_profile
    (lazy [%sexp ([ f ] : t list)])
    (fun () -> funcall0 f should_return_result)
;;

let funcall1 f a1 ~should_profile ~should_return_result =
  maybe_profile
    ~should_profile
    (lazy [%sexp ([ f; a1 ] : t list)])
    (fun () -> funcall1 f a1 should_return_result)
;;

let funcall2 f a1 a2 ~should_profile ~should_return_result =
  maybe_profile
    ~should_profile
    (lazy [%sexp ([ f; a1; a2 ] : t list)])
    (fun () -> funcall2 f a1 a2 should_return_result)
;;

let funcall3 f a1 a2 a3 ~should_profile ~should_return_result =
  maybe_profile
    ~should_profile
    (lazy [%sexp ([ f; a1; a2; a3 ] : t list)])
    (fun () -> funcall3 f a1 a2 a3 should_return_result)
;;

let funcall4 f a1 a2 a3 a4 ~should_profile ~should_return_result =
  maybe_profile
    ~should_profile
    (lazy [%sexp ([ f; a1; a2; a3; a4 ] : t list)])
    (fun () -> funcall4 f a1 a2 a3 a4 should_return_result)
;;

let funcall5 f a1 a2 a3 a4 a5 ~should_profile ~should_return_result =
  maybe_profile
    ~should_profile
    (lazy [%sexp ([ f; a1; a2; a3; a4; a5 ] : t list)])
    (fun () -> funcall5 f a1 a2 a3 a4 a5 should_return_result)
;;

let funcall0_i ?should_profile f =
  ignore (funcall0 f ~should_profile ~should_return_result:false : t);
  raise_if_emacs_signaled ()
;;

let funcall0 ?should_profile f =
  let r = funcall0 f ~should_profile ~should_return_result:true in
  raise_if_emacs_signaled ();
  r
;;

let funcall1_i ?should_profile f a =
  ignore (funcall1 f a ~should_profile ~should_return_result:false : t);
  raise_if_emacs_signaled ()
;;

let funcall1 ?should_profile f a =
  let r = funcall1 f a ~should_profile ~should_return_result:true in
  raise_if_emacs_signaled ();
  r
;;

let funcall2_i ?should_profile f a1 a2 =
  ignore (funcall2 f a1 a2 ~should_profile ~should_return_result:false : t);
  raise_if_emacs_signaled ()
;;

let funcall2 ?should_profile f a1 a2 =
  let r = funcall2 f a1 a2 ~should_profile ~should_return_result:true in
  raise_if_emacs_signaled ();
  r
;;

let funcall3_i ?should_profile f a1 a2 a3 =
  ignore (funcall3 f a1 a2 a3 ~should_profile ~should_return_result:false : t);
  raise_if_emacs_signaled ()
;;

let funcall3 ?should_profile f a1 a2 a3 =
  let r = funcall3 f a1 a2 a3 ~should_profile ~should_return_result:true in
  raise_if_emacs_signaled ();
  r
;;

let funcall4_i ?should_profile f a1 a2 a3 a4 =
  ignore (funcall4 f a1 a2 a3 a4 ~should_profile ~should_return_result:false : t);
  raise_if_emacs_signaled ()
;;

let funcall4 ?should_profile f a1 a2 a3 a4 =
  let r = funcall4 f a1 a2 a3 a4 ~should_profile ~should_return_result:true in
  raise_if_emacs_signaled ();
  r
;;

let funcall5_i ?should_profile f a1 a2 a3 a4 a5 =
  ignore (funcall5 f a1 a2 a3 a4 a5 ~should_profile ~should_return_result:false : t);
  raise_if_emacs_signaled ()
;;

let funcall5 ?should_profile f a1 a2 a3 a4 a5 =
  let r = funcall5 f a1 a2 a3 a4 a5 ~should_profile ~should_return_result:true in
  raise_if_emacs_signaled ();
  r
;;

external funcall_int_int_value_unit
  :  t
  -> int
  -> int
  -> t
  -> unit
  = "ecaml_funcall_int_int_value_unit"

let funcall_int_int_value_unit ?should_profile f a1 a2 a3 =
  maybe_profile
    ~should_profile
    (lazy [%sexp (f : t), (a1 : int), (a2 : int), (a3 : t)])
    (fun () -> funcall_int_int_value_unit f a1 a2 a3);
  raise_if_emacs_signaled ()
;;

external funcall_int_int_value_value_unit
  :  t
  -> int
  -> int
  -> t
  -> t
  -> unit
  = "ecaml_funcall_int_int_value_value_unit"

let funcall_int_int_value_value_unit ?should_profile f a1 a2 a3 a4 =
  maybe_profile
    ~should_profile
    (lazy [%sexp (f : t), (a1 : int), (a2 : int), (a3 : t), (a4 : t)])
    (fun () -> funcall_int_int_value_value_unit f a1 a2 a3 a4);
  raise_if_emacs_signaled ()
;;

external type_of : t -> t = "ecaml_type_of"

let type_of = wrap_raise1 type_of

external is_not_nil : t -> bool = "ecaml_is_not_nil"

let is_not_nil = wrap_raise1 is_not_nil

external eq : t -> t -> bool = "ecaml_eq"

let eq = wrap_raise2 eq
let[@inline always] is_integer (t : t) = Obj.is_int (Obj.repr t)

let[@inline always] to_int_exn (t : t) =
  if not (is_integer t)
  then raise_s [%sexp "wrong-type-argument", ("integerp", (t : t))]
  else (Obj.magic t : int)
;;

let get_var symbol = funcall1 Q.symbol_value symbol
let set_var symbol value = funcall2_i Q.set symbol value
let get_int_var string = get_var (string |> intern) |> to_int_exn
let debug_on_error () = is_not_nil (funcall1 Q.symbol_value Q.debug_on_error)
let emacs_min_int = get_int_var "most-negative-fixnum"
let emacs_max_int = get_int_var "most-positive-fixnum"

let of_int_exn : int -> t =
  let check_bounds =
    Int.validate_bound ~min:(Incl emacs_min_int) ~max:(Incl emacs_max_int)
  in
  fun n ->
    Validate.maybe_raise (Validate.name "overflow-error" (check_bounds n));
    (Obj.magic n : t)
;;

external of_float : float -> t = "ecaml_of_float"

let of_float = wrap_raise1 of_float

external to_float_exn : t -> float = "ecaml_to_float"

let to_float_exn = wrap_raise1 to_float_exn

external of_utf8_bytes : string -> t = "ecaml_of_string"

let of_utf8_bytes = wrap_raise1 of_utf8_bytes
let of_utf8_bytes_cache = Hashtbl.create (module String)

let of_utf8_bytes_cached string =
  Hashtbl.find_or_add of_utf8_bytes_cache string ~default:(fun () ->
    of_utf8_bytes string)
;;

external to_utf8_bytes_exn : t -> string = "ecaml_to_string"

let to_utf8_bytes_exn = wrap_raise1 to_utf8_bytes_exn

external vec_get : t -> int -> t = "ecaml_vec_get"

let vec_get = wrap_raise2 vec_get

external vec_set : t -> int -> t -> unit = "ecaml_vec_set"

let vec_set = wrap_raise3 vec_set

external vec_size : t -> int = "ecaml_vec_size"

let vec_size = wrap_raise1 vec_size
let percent_s = of_utf8_bytes "%s"
let message s = funcall2_i Q.message percent_s (of_utf8_bytes s)

let message_zero_alloc t =
  ignore (external_funcall1 Q.message t false : t);
  raise_if_emacs_signaled ()
;;

let message_t t = funcall2_i Q.message percent_s t
let messagef fmt = ksprintf message fmt

let message_s : Sexp.t -> unit = function
  | Atom string -> message string
  | sexp -> messagef "%s" (sexp |> Sexp.to_string_hum)
;;

let nil = Q.nil
let t = Q.t
let to_bool = is_not_nil
let of_bool b = if b then t else nil
let list ts = funcallN Q.list ts
let is_nil t = eq t nil
let is_array t = funcall1 Q.arrayp t |> to_bool
let is_buffer t = funcall1 Q.bufferp t |> to_bool
let is_command t = funcall1 Q.commandp t |> to_bool
let is_event t = funcall1 Q.eventp t |> to_bool
let is_float t = funcall1 Q.floatp t |> to_bool
let is_font t = funcall1 Q.fontp t |> to_bool
let is_frame t = funcall1 Q.framep t |> to_bool
let is_function t = funcall1 Q.functionp t |> to_bool
let is_hash_table t = funcall1 Q.hash_table_p t |> to_bool
let is_keymap t = funcall1 Q.keymapp t |> to_bool
let is_marker t = funcall1 Q.markerp t |> to_bool
let is_process t = funcall1 Q.processp t |> to_bool
let is_string t = funcall1 Q.stringp t |> to_bool
let is_symbol t = funcall1 Q.symbolp t |> to_bool
let is_syntax_table t = funcall1 Q.syntax_table_p t |> to_bool
let is_timer t = funcall1 Q.timerp t |> to_bool
let is_vector t = funcall1 Q.vectorp t |> to_bool
let is_window t = funcall1 Q.windowp t |> to_bool
let is_window_configuration t = funcall1 Q.window_configuration_p t |> to_bool
let equal t1 t2 = funcall2 Q.equal t1 t2 |> to_bool
let cons t1 t2 = funcall2 Q.cons t1 t2
let car_exn t = funcall1 Q.car t
let cdr_exn t = funcall1 Q.cdr t
let cadr_exn t = funcall1 Q.cadr t

let is_cons ?car ?cdr t =
  funcall1 Q.consp t |> to_bool
  && (match car with
    | None -> true
    | Some is_car -> is_car (car_exn t))
  &&
  match cdr with
  | None -> true
  | Some is_cdr -> is_cdr (cdr_exn t)
;;

let to_list_exn (t : t) ~f =
  let rec loop t ac =
    if is_nil t
    then List.rev ac
    else if is_cons t
    then loop (cdr_exn t) (f (car_exn t) :: ac)
    else raise_s [%message "[Value.to_list] got strange value" ~_:(t : t)]
  in
  loop t []
;;

let list_to_array_exn t ~f =
  let length = funcall1 Q.length t |> to_int_exn in
  if length = 0
  then Array.of_list []
  else (
    let elt0 = f (car_exn t) in
    let array = Array.create ~len:length elt0 in
    let rec fill_array_loop t i =
      if is_nil t
      then ()
      else (
        array.(i) <- f (car_exn t);
        fill_array_loop (cdr_exn t) (i + 1))
    in
    fill_array_loop (cdr_exn t) 1;
    array)
;;

let to_array_exn (t : t) ~f =
  let length = vec_size t in
  Array.init length ~f:(fun i -> f (vec_get t i))
;;

let vector arr = funcallN_array Q.vector arr

let non_local_exit_signal exn =
  let module M = struct
    (** [non_local_exit_signal] sets a [pending_error] flag in the Emacs environment that
        causes it to, after our C code returns to it, signal instead of returning a
        value. *)
    external non_local_exit_signal : t -> t -> unit = "ecaml_non_local_exit_signal"

    (** [non_local_exit_throw] works like [non_local_exit_signal], except that it throws
        instead of signaling when our code returns to emacs. *)
    external non_local_exit_throw : t -> t -> unit = "ecaml_non_local_exit_throw"
  end
  in
  let debug_on_error = debug_on_error () in
  match exn with
  | Elisp_throw { tag; value } -> M.non_local_exit_throw tag value
  | Elisp_signal { symbol; data } ->
    (* This case preserves an Elisp signal as it crosses an OCaml boundary. *)
    let data =
      match debug_on_error with
      | false -> data
      | true ->
        funcall2
          Q.append
          data
          (list
             [ list
                 [ Q.backtrace
                 ; Backtrace.Exn.most_recent () |> Backtrace.to_string |> of_utf8_bytes
                 ]
             ])
    in
    M.non_local_exit_signal symbol data
  | _ ->
    let backtrace =
      if debug_on_error then Some (Backtrace.Exn.most_recent ()) else None
    in
    let message =
      [%message.omit_nil "" ~_:(exn : exn) (backtrace : Backtrace.t option)]
    in
    let message =
      match message with
      | Atom string -> string
      | List _ as sexp -> Sexp.to_string_hum sexp
    in
    (* For the [error] symbol, the error data should be a list whose car is a string.
       See [(Info-goto-node "(elisp)Signaling Errors")]. *)
    M.non_local_exit_signal Q.error (list [ message |> of_utf8_bytes ])
;;

let prin1_to_string t = funcall1 Q.prin1_to_string t |> to_utf8_bytes_exn

let text_has_properties t =
  is_nil (funcall2 Q.equal_including_properties t (funcall1 Q.substring_no_properties t))
;;

let might_be_a_sexp string =
  let string = string |> String.strip in
  let n = String.length string in
  n >= 2 && Char.equal string.[0] '(' && Char.equal string.[n - 1] ')'
;;

let with_print_config ~print_length ~print_level ~f =
  let old_print_length = get_var Q.print_length in
  let old_print_level = get_var Q.print_level in
  set_var Q.print_length (print_length |> of_int_exn);
  set_var Q.print_level (print_level |> of_int_exn);
  protect ~f ~finally:(fun () ->
    set_var Q.print_length old_print_length;
    set_var Q.print_level old_print_level)
;;

let rec sexp_of_t_internal t ~print_length ~print_level : Sexp.t =
  if print_length <= 0 || print_level <= 0
  then [%message "..."]
  else if is_string t && not (text_has_properties t)
  then (
    let string = t |> to_utf8_bytes_exn in
    if not (might_be_a_sexp string)
    then Atom string
    else (
      match string |> Sexp.of_string with
      | x -> x
      | exception _ -> Atom string))
  else if is_cons t
  then (
    let car =
      sexp_of_t_internal (car_exn t) ~print_length ~print_level:(print_level - 1)
    in
    let cdr =
      sexp_of_t_internal (cdr_exn t) ~print_length:(print_length - 1) ~print_level
    in
    match cdr with
    | Atom "nil" -> List [ car ]
    | Atom _ -> List [ car; Atom "."; cdr ]
    | List sexps -> List (car :: sexps))
  else (
    let sexp_string =
      with_print_config ~print_length ~print_level ~f:(fun () -> prin1_to_string t)
    in
    let sexp_string =
      (* Emacs prefixes some values (like buffers, markers, etc) with [#], which then
         makes the sexp unparseable.  So in this case we strip the [#]. *)
      if String.is_prefix sexp_string ~prefix:"#("
      then String.chop_prefix_exn sexp_string ~prefix:"#"
      else sexp_string
    in
    match Sexp.of_string sexp_string with
    | sexp -> sexp
    | exception _ -> Atom sexp_string)
;;

let ecaml_profile_print_length = ref None
let ecaml_profile_print_level = ref None

let sexp_of_t t =
  let print_length, print_level =
    if Profile.am_forcing_message ()
    then !ecaml_profile_print_length, !ecaml_profile_print_level
    else (
      let int_or_nil symbol =
        let value = get_var symbol in
        if is_nil value then None else Some (value |> to_int_exn)
      in
      int_or_nil Q.print_length, int_or_nil Q.print_level)
  in
  let print_length = Option.value print_length ~default:emacs_max_int in
  let print_level = Option.value print_level ~default:emacs_max_int in
  sexp_of_t_internal t ~print_length ~print_level
;;

let initialize_module =
  initialize_module;
  Sexplib.Conv.Exn_converter.add [%extension_constructor Elisp_signal] (function
    | Elisp_signal { symbol; data } ->
      if eq symbol Q.error
      then [%sexp (data : t)]
      else if is_nil data
      then [%sexp (symbol : t)]
      else [%message "" ~_:(symbol : t) ~_:(data : t)]
    | _ ->
      (* Reaching this branch indicates a bug in sexplib. *)
      assert false);
  sexp_of_t_ref := sexp_of_t
;;

module Type = struct
  type async [@@deriving sexp_of]
  type sync [@@deriving sexp_of]

  type ('a, 'm) t_ =
    { id : 'a Type_equal.Id.t
    ; of_value_exn : value -> 'a
    ; to_value : 'a -> value
    }
  [@@deriving fields, sexp_of]

  type 'a t = ('a, sync) t_ [@@deriving sexp_of]

  module type S = Type with type value := value with type 'a t := 'a t

  let name t = Sexp.of_string (Type_equal.Id.name t.id)
  let to_sexp t = Type_equal.Id.to_sexp t.id
  let sexp_of_t _ t = name t

  let create name sexp_of_t of_value_exn to_value =
    { id = Type_equal.Id.create ~name:(Sexp.to_string name) sexp_of_t
    ; of_value_exn =
        (fun value ->
           try of_value_exn value with
           | exn ->
             raise_s
               [%message
                 "unable to convert Elisp value to OCaml value"
                   ~type_:(name : Sexp.t)
                   (value : value)
                   (exn : exn)])
    ; to_value
    }
  ;;

  let with_of_value_exn t of_value_exn = { t with of_value_exn }

  module type Enum = Enum

  let enum (type a) name (module M : Enum with type t = a) to_value =
    let valid_values = List.map M.all ~f:(fun m -> to_value m, m) in
    let of_value_exn value =
      match List.Assoc.find valid_values value ~equal with
      | None -> raise_s [%message (valid_values : (value * M.t) list)]
      | Some m -> m
    in
    create name [%sexp_of: M.t] of_value_exn to_value
  ;;

  let bool = create [%message "bool"] [%sexp_of: bool] to_bool of_bool
  let float = create [%message "float"] [%sexp_of: float] to_float_exn of_float
  let ignored = create [%message "ignored"] [%sexp_of: unit] ignore (const nil)
  let int = create [%message "int"] [%sexp_of: int] to_int_exn of_int_exn

  let string =
    create [%message "string"] [%sexp_of: string] to_utf8_bytes_exn of_utf8_bytes
  ;;

  let string_cached =
    create [%message "string"] [%sexp_of: string] to_utf8_bytes_exn of_utf8_bytes_cached
  ;;

  let unit =
    create
      [%message "unit"]
      [%sexp_of: unit]
      (fun value -> assert (is_nil value))
      (const nil)
  ;;

  let value = create [%message "value"] [%sexp_of: value] Fn.id Fn.id

  let alist t1 t2 =
    create
      [%message "alist" ~_:(name t1 : Sexp.t) ~_:(name t2 : Sexp.t)]
      (sexp_of_list (Tuple2.sexp_of_t (to_sexp t1) (to_sexp t2)))
      (to_list_exn ~f:(fun cons_cell ->
         of_value_exn t1 (car_exn cons_cell), of_value_exn t2 (cdr_exn cons_cell)))
      (fun l ->
         list (List.map l ~f:(fun (a, b) -> cons (to_value t1 a) (to_value t2 b))))
  ;;

  let list t =
    create
      [%message "list" ~_:(name t : Sexp.t)]
      (sexp_of_list (to_sexp t))
      (to_list_exn ~f:(of_value_exn t))
      (fun l -> list (List.map l ~f:(to_value t)))
  ;;

  let array_as_list t =
    create
      [%message "array-as-list" ~_:(name t : Sexp.t)]
      (sexp_of_array (to_sexp t))
      (list_to_array_exn ~f:(of_value_exn t))
      (Array.fold_right ~init:nil ~f:(fun elt elisp_list ->
         cons (to_value t elt) elisp_list))
  ;;

  let vector t =
    create
      [%message "vector" ~_:(name t : Sexp.t)]
      (sexp_of_array (to_sexp t))
      (to_array_exn ~f:(of_value_exn t))
      (fun a -> vector (Array.map a ~f:(to_value t)))
  ;;

  let tuple t1 t2 =
    create
      [%sexp (name t1 : Sexp.t), (name t2 : Sexp.t)]
      (Tuple2.sexp_of_t (to_sexp t1) (to_sexp t2))
      (fun v -> of_value_exn t1 (car_exn v), of_value_exn t2 (cdr_exn v))
      (fun (a1, a2) -> cons (to_value t1 a1) (to_value t2 a2))
  ;;

  let tuple2_as_list t1 t2 =
    create
      [%sexp (name t1 : Sexp.t), (name t2 : Sexp.t)]
      (Tuple2.sexp_of_t (to_sexp t1) (to_sexp t2))
      (fun v -> of_value_exn t1 (car_exn v), of_value_exn t2 (cadr_exn v))
      (fun (a1, a2) -> cons (to_value t1 a1) (cons (to_value t2 a2) nil))
  ;;

  let map t ~name ~of_ ~to_ =
    create
      name
      (Fn.compose (to_sexp t) to_)
      (Fn.compose of_ (of_value_exn t))
      (Fn.compose (to_value t) to_)
  ;;

  let map_id t name = map t ~name ~of_:Fn.id ~to_:Fn.id

  let nil_or t =
    create
      [%message "nil_or" ~_:(name t : Sexp.t)]
      (function
        | None -> Atom "nil"
        | Some v -> to_sexp t v)
      (fun v -> if is_nil v then None else Some (v |> of_value_exn t))
      (function
        | None -> nil
        | Some v -> (to_value t) v)
  ;;

  let option t =
    create
      [%message "option" ~_:(name t : Sexp.t)]
      (sexp_of_option (to_sexp t))
      (fun v -> if is_nil v then None else Some (car_exn v |> of_value_exn t))
      (function
        | None -> nil
        | Some v -> cons (to_value t v) nil)
  ;;

  (* embed ocaml values as strings which are sexp representations *)
  let sexpable (type a) (module A : Sexpable with type t = a) ~name =
    create
      [%message "sexpable" ~_:(name : Sexp.t)]
      [%sexp_of: A.t]
      (fun v -> A.t_of_sexp (Sexp.of_string (of_value_exn string v)))
      (fun a -> A.sexp_of_t a |> Sexp.to_string_mach |> to_value string)
  ;;

  let path_list =
    map
      (nil_or string)
      ~name:[%message "path-list-element"]
      ~of_:(Option.value ~default:".")
      ~to_:Option.return
    |> list
  ;;
end

module type Subtype = Subtype with type value := t with type 'a type_ := 'a Type.t

module Make_subtype (M : Make_subtype_arg) = struct
  open M

  type nonrec t = t [@@deriving sexp_of]

  let is_in_subtype = is_in_subtype
  let to_value t = t

  let of_value_exn t =
    if not (is_in_subtype t)
    then
      raise_s
        [%message
          (concat [ "["; name; "]'s [of_value_exn] got value not in subtype" ])
            ~_:(t : t)];
    t
  ;;

  let type_ = Type.create [%message name] [%sexp_of: t] of_value_exn to_value
  let t = type_
  let eq (t1 : t) t2 = eq t1 t2
end

module Stat = struct
  type t =
    { emacs_free_performed : int
    ; emacs_free_scheduled : int
    }
  [@@deriving sexp_of]

  external num_emacs_free_performed : unit -> int = "ecaml_num_emacs_free_performed"
  external num_emacs_free_scheduled : unit -> int = "ecaml_num_emacs_free_scheduled"

  let now () =
    { emacs_free_performed = num_emacs_free_performed ()
    ; emacs_free_scheduled = num_emacs_free_scheduled ()
    }
  ;;

  let diff t2 t1 =
    { emacs_free_performed = t2.emacs_free_performed - t1.emacs_free_performed
    ; emacs_free_scheduled = t2.emacs_free_scheduled - t1.emacs_free_scheduled
    }
  ;;
end

module Expert = struct
  let have_active_env = have_active_env
  let non_local_exit_signal = non_local_exit_signal
  let raise_if_emacs_signaled = raise_if_emacs_signaled
end

module For_testing = struct
  let all_interned_symbols = all_interned_symbols

  exception Elisp_signal = Elisp_signal
  exception Elisp_throw = Elisp_throw

  let map_elisp_signal g ~f =
    match g () with
    | a -> a
    | exception Elisp_signal { symbol; data } ->
      Nothing.unreachable_code
        (f ~symbol ~data ~reraise:(fun ~symbol ~data ->
           raise (Elisp_signal { symbol; data })))
  ;;

  let map_elisp_signal_omit_data f =
    map_elisp_signal f ~f:(fun ~symbol ~data:_ ~reraise -> reraise ~symbol ~data:nil)
  ;;
end

module Private = struct
  module Block_on_async = Block_on_async
  module Enqueue_foreground_block_on_async = Enqueue_foreground_block_on_async
  module Run_outside_async = Run_outside_async

  let block_on_async here ?context f =
    (Set_once.get_exn Block_on_async.set_once here).f here ?context f
  ;;

  let enqueue_foreground_block_on_async here ?context ?raise_exceptions_to_monitor f =
    (Set_once.get_exn Enqueue_foreground_block_on_async.set_once here).f
      here
      ?context
      ?raise_exceptions_to_monitor
      f
  ;;

  let run_outside_async here ?allowed_in_background f =
    (Set_once.get_exn Run_outside_async.set_once here).f here ?allowed_in_background f
  ;;

  let ecaml_profile_print_length = ecaml_profile_print_length
  let ecaml_profile_print_level = ecaml_profile_print_level
  let message_zero_alloc = message_zero_alloc
  let message_t = message_t
end
OCaml

Innovation. Community. Security.