23
23
* Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *)
24
24
25
25
type ident = Ident .t
26
-
27
26
type apply_status = App_na | App_infer_full | App_uncurry
28
27
29
28
type ap_info = {
@@ -414,13 +413,12 @@ let switch lam (lam_switch : lambda_switch) : t =
414
413
415
414
let stringswitch (lam : t ) cases default : t =
416
415
match lam with
417
- | Lconst (Const_string a ) -> Ext_list. assoc_by_string cases a default
416
+ | Lconst (Const_string { s; unicode = false } ) ->
417
+ Ext_list. assoc_by_string cases s default
418
418
| _ -> Lstringswitch (lam, cases, default)
419
419
420
420
let true_ : t = Lconst Const_js_true
421
-
422
421
let false_ : t = Lconst Const_js_false
423
-
424
422
let unit : t = Lconst Const_js_undefined
425
423
426
424
let rec seq (a : t ) b : t =
@@ -436,28 +434,19 @@ let rec seq (a : t) b : t =
436
434
| _ -> Lsequence (a, b)
437
435
438
436
let var id : t = Lvar id
439
-
440
437
let global_module id = Lglobal_module id
441
-
442
438
let const ct : t = Lconst ct
443
439
444
440
let function_ ~attr ~arity ~params ~body : t =
445
441
Lfunction { arity; params; body; attr }
446
442
447
443
let let_ kind id e body : t = Llet (kind, id, e, body)
448
-
449
444
let letrec bindings body : t = Lletrec (bindings, body)
450
-
451
445
let while_ a b : t = Lwhile (a, b)
452
-
453
446
let try_ body id handler : t = Ltrywith (body, id, handler)
454
-
455
447
let for_ v e1 e2 dir e3 : t = Lfor (v, e1, e2, dir, e3)
456
-
457
448
let assign v l : t = Lassign (v, l)
458
-
459
449
let staticcatch a b c : t = Lstaticcatch (a, b, c)
460
-
461
450
let staticraise a b : t = Lstaticraise (a, b)
462
451
463
452
module Lift = struct
@@ -478,9 +467,7 @@ module Lift = struct
478
467
Lconst ((Const_nativeint b)) *)
479
468
480
469
let int64 b : t = Lconst (Const_int64 b)
481
-
482
- let string b : t = Lconst (Const_string b)
483
-
470
+ let string s : t = Lconst (Const_string { s; unicode = false })
484
471
let char b : t = Lconst (Const_char b)
485
472
end
486
473
@@ -496,8 +483,8 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t =
496
483
Lift. int (Int32. of_float (float_of_string a))
497
484
(* | Pnegfloat -> Lift.float (-. a) *)
498
485
(* | Pabsfloat -> Lift.float (abs_float a) *)
499
- | Pstringlength , Const_string a ->
500
- Lift. int (Int32. of_int (String. length a ))
486
+ | Pstringlength , Const_string { s; unicode = false } ->
487
+ Lift. int (Int32. of_int (String. length s ))
501
488
(* | Pnegbint Pnativeint, ( (Const_nativeint i)) *)
502
489
(* -> *)
503
490
(* Lift.nativeint (Nativeint.neg i) *)
@@ -568,8 +555,13 @@ let prim ~primitive:(prim : Lam_primitive.t) ~args loc : t =
568
555
| Psequor , Const_js_true , (Const_js_true | Const_js_false ) -> true_
569
556
| Psequor , Const_js_false , Const_js_true -> true_
570
557
| Psequor , Const_js_false , Const_js_false -> false_
571
- | Pstringadd , Const_string a , Const_string b -> Lift. string (a ^ b)
572
- | (Pstringrefs | Pstringrefu ), Const_string a , Const_int { i = b } -> (
558
+ | ( Pstringadd ,
559
+ Const_string { s = a; unicode = false },
560
+ Const_string { s = b; unicode = false } ) ->
561
+ Lift. string (a ^ b)
562
+ | ( (Pstringrefs | Pstringrefu ),
563
+ Const_string { s = a; unicode = false },
564
+ Const_int { i = b } ) -> (
573
565
try Lift. char (String. get a (Int32. to_int b)) with _ -> default () )
574
566
| _ -> default () )
575
567
| _ -> (
0 commit comments