@@ -178,6 +178,23 @@ module Make
178
178
module F = Dolmen_intf.View. TFF
179
179
module E = Dolmen_std.View. Assoc (V )
180
180
181
+ (* Env suff *)
182
+ (* ******** *)
183
+
184
+ (* Applications of `to_real` that are **directly** under an arithmetic
185
+ operator (such as '+'), can omit to print applications of `to_real`,
186
+ since these will be added back when parsing/typing. *)
187
+ let can_omit_to_real_key : bool Env.key = Env. key ()
188
+ let set_omit_to_real env b =
189
+ match Env. get env can_omit_to_real_key with
190
+ | Some b' when b = b' -> env
191
+ | _ -> Env. set env can_omit_to_real_key b
192
+ let can_omit_to_real env =
193
+ match Env. get env can_omit_to_real_key with
194
+ | Some true -> true
195
+ | _ -> false
196
+
197
+
181
198
(* Helpers *)
182
199
(* ******* *)
183
200
@@ -284,23 +301,39 @@ module Make
284
301
| Constructor (_ , l ) -> List. fold_left Env.Term_var. bind env l
285
302
286
303
let term_cst_chainable _env c =
287
- match V.Term.Cst. builtin c with
288
- | B. Base -> `Nope
289
- | B. Equal -> `Chainable (fun c ->
290
- match V.Term.Cst. builtin c with B. Equal -> true | _ -> false )
304
+ (* WARNING: this `blt` function should only be called with builtins that
305
+ do not have payload (such as terms), since the polymorphic comparison
306
+ will not work adequately in these cases. *)
307
+ let blt b = fun c -> V.Term.Cst. builtin c = b in
308
+ let b = V.Term.Cst. builtin c in
309
+ let yup () = `Chainable (blt b) in
310
+ match b with
311
+ | B. Equal
312
+ | B. Lt (`Int | `Real ) | B. Leq (`Int | `Real )
313
+ | B. Gt (`Int | `Real ) | B. Geq (`Int | `Real )
314
+ -> yup ()
291
315
| _ -> `Nope
292
316
293
317
let term_cst_assoc _env c =
294
- match V.Term.Cst. builtin c with
295
- | B. Base -> `None
296
- | B. Or -> `Left_assoc (fun c ->
297
- match V.Term.Cst. builtin c with B. Or -> true | _ -> false )
298
- | B. And -> `Left_assoc (fun c ->
299
- match V.Term.Cst. builtin c with B. And -> true | _ -> false )
300
- | B. Xor -> `Left_assoc (fun c ->
301
- match V.Term.Cst. builtin c with B. Xor -> true | _ -> false )
302
- | B. Imply -> `Right_assoc (fun c ->
303
- match V.Term.Cst. builtin c with B. Imply -> true | _ -> false )
318
+ (* WARNING: this `blt` function should only be called with builtins that
319
+ do not have payload (such as terms), since the polymorphic comparison
320
+ will not work adequately in these cases. *)
321
+ let blt b = fun c -> V.Term.Cst. builtin c = b in
322
+ let b = V.Term.Cst. builtin c in
323
+ let left () = `Left_assoc (blt b) in
324
+ let right () = `Right_assoc (blt b) in
325
+ match b with
326
+ (* left associative builtins *)
327
+ | B. Or | B. And | B. Xor
328
+ | B. Add (`Int | `Real )
329
+ | B. Sub (`Int | `Real )
330
+ | B. Mul (`Int | `Real )
331
+ | B. Div `Real
332
+ -> left ()
333
+ (* Right associative builtins *)
334
+ | B. Imply
335
+ -> right ()
336
+ (* all others are non-associative *)
304
337
| _ -> `None
305
338
306
339
let term_cst_poly _env c =
@@ -322,22 +355,22 @@ module Make
322
355
and term_view env fmt t_ty view =
323
356
match (view : _ F.Term.view ) with
324
357
| Var v -> term_var env fmt v
325
- | App (head , _ , args ) -> term_app env fmt (t_ty, head, args)
358
+ | App (head , ty_args , args ) -> term_app env fmt (t_ty, head, ty_args , args)
326
359
| Match (scrutinee , cases ) -> term_match env fmt (scrutinee, cases)
327
360
| Binder (Exists (tys , ts ), body ) -> quant " exists" env fmt (tys, ts, body)
328
361
| Binder (Forall (tys , ts ), body ) -> quant " forall" env fmt (tys, ts, body)
329
362
| Binder (Letand l , body ) -> letand env fmt (l, body)
330
363
| Binder (Letin l , body ) -> letin env fmt (l, body)
331
364
332
- and term_app env fmt (t_ty , head , args ) =
365
+ and term_app env fmt (t_ty , head , ty_args , args ) =
333
366
(* first, we need to undo any left/right associativity/chainability that
334
367
may have been expanded by the typechecker or other mechanism. *)
335
- let head, args =
336
- let args =
368
+ let head, ty_args, args =
369
+ let ty_args, args =
337
370
match term_cst_assoc env head with
338
- | `Left_assoc top_head -> E. left_assoc top_head args
339
- | `Right_assoc top_head -> E. right_assoc top_head args
340
- | `None -> args
371
+ | `Left_assoc top_head -> None , E. left_assoc top_head args
372
+ | `Right_assoc top_head -> None , E. right_assoc top_head args
373
+ | `None -> Some ty_args, args
341
374
in
342
375
match V.Term.Cst. builtin head, args with
343
376
| B. And , t :: _ ->
@@ -346,23 +379,25 @@ module Make
346
379
begin match term_cst_chainable env h with
347
380
| `Chainable top_head ->
348
381
begin match E. chainable top_head args with
349
- | Some new_args -> h, new_args
350
- | None -> head, args
382
+ | Some new_args -> h, None , new_args
383
+ | None -> head, ty_args, args
351
384
end
352
- | `Nope -> head, args
385
+ | `Nope -> head, ty_args, args
353
386
end
354
- | _ -> head, args
387
+ | _ -> head, ty_args, args
355
388
end
356
- | _ -> head, args
389
+ | _ -> head, ty_args, args
357
390
in
391
+
358
392
(* smtlib has implicit type arguments, i.e. the type args are not printed.
359
393
Therefore, whenever a polymorphic symbol is used, its type arguments
360
394
need to be inferable from its term arguments. Hence, when a symbol is
361
395
polymorphic and there are no term arguments, we need to print an
362
396
explicit type annotation to disambiguate things. In the other cases,
363
397
we suppose that a symbol's type arguments can be deduced from the term
364
398
arguments. *)
365
- let aux h args =
399
+ let aux ?(omit_to_real =false ) h args =
400
+ let env = set_omit_to_real env omit_to_real in
366
401
match args with
367
402
| [] ->
368
403
if term_cst_poly env head then
@@ -373,10 +408,18 @@ module Make
373
408
| _ :: _ ->
374
409
Format. fprintf fmt " (%a@ %a)" (id ~allow_keyword: false env) h (list term env) args
375
410
in
411
+
376
412
(* small shorthand *)
377
- let p ns name = aux (Dolmen_std.Id. create ns name) args in
378
- let simple s = p Term (N. simple s) in
413
+ let p ?omit_to_real ns name =
414
+ aux ?omit_to_real (Dolmen_std.Id. create ns name) args
415
+ in
416
+ let simple ?omit_to_real s =
417
+ p ?omit_to_real Term (N. simple s)
418
+ in
419
+
420
+ (* Matching *)
379
421
match V.Term.Cst. builtin head with
422
+
380
423
(* Base + Algebraic datatypes *)
381
424
| B. Base | B. Constructor _ | B. Destructor _ ->
382
425
p Term (Env.Term_cst. name env head)
@@ -385,6 +428,32 @@ module Make
385
428
| Simple s -> p Term (N. indexed " is" [s])
386
429
| _ -> _cannot_print " expected a simple for a constructor name"
387
430
end
431
+
432
+ (* Cast *)
433
+ | B. Coercion ->
434
+ begin match ty_args with
435
+ | None -> assert false (* coercions should not be chainable/associative *)
436
+ | Some [a; b] ->
437
+ begin match V.Ty. view a, V.Ty. view b with
438
+
439
+ (* Int-> Real conversion *)
440
+ | App (ah, [] ), App (bh, [] )
441
+ when (match V.Ty.Cst. builtin ah with B. Int -> true | _ -> false ) &&
442
+ (match V.Ty.Cst. builtin bh with B. Real -> true | _ -> false ) ->
443
+ if can_omit_to_real env then
444
+ match args with
445
+ | [t] ->
446
+ term env fmt t
447
+ | _ -> _cannot_print " bad applicaiton of coercion"
448
+ else
449
+ simple " to_real"
450
+
451
+ (* fallback *)
452
+ | _ -> _cannot_print " unhandled builtin"
453
+ end
454
+ | Some _ -> _cannot_print " bad coercion application"
455
+ end
456
+
388
457
(* Boolean core *)
389
458
| B. True -> simple " true"
390
459
| B. False -> simple " false"
@@ -396,12 +465,77 @@ module Make
396
465
| B. Ite -> simple " ite"
397
466
| B. Equal -> simple " ="
398
467
| B. Distinct -> simple " distinct"
399
- (* TODO: complete support for all builtins *)
468
+
469
+ (* Arrays *)
470
+ | B. Store -> simple " store"
471
+ | B. Select -> simple " select"
472
+
473
+ (* Arithmetic *)
400
474
| B. Integer s -> p (Value Integer ) (N. simple s)
401
- | B. Add (`Int | `Real ) -> simple " +"
475
+ | B. Decimal s -> p (Value Real ) (N. simple s)
476
+ | B. Lt (`Int | `Real ) -> simple ~omit_to_real: true " <"
477
+ | B. Leq (`Int | `Real ) -> simple ~omit_to_real: true " <="
478
+ | B. Gt (`Int | `Real ) -> simple ~omit_to_real: true " >"
479
+ | B. Geq (`Int | `Real ) -> simple ~omit_to_real: true " >="
480
+ | B. Minus ( `Int | `Real ) -> simple " -"
481
+ | B. Add (`Int | `Real ) -> simple ~omit_to_real: true " +"
482
+ | B. Sub (`Int | `Real ) -> simple ~omit_to_real: true " -"
483
+ | B. Mul (`Int | `Real ) -> simple ~omit_to_real: true " *"
484
+ | B. Div `Real -> simple ~omit_to_real: true " /"
485
+ | B. Div_e `Int -> simple " div"
486
+ | B. Modulo_e `Int -> simple " mod"
487
+ | B. Abs -> simple " abs"
488
+ | B. Is_int `Real -> simple " is_int"
489
+ | B. Floor_to_int `Real -> simple " to_int"
490
+ | B. Divisible ->
491
+ begin match args with
492
+ | [x; y] ->
493
+ begin match V.Term. view y with
494
+ | App (f , [] , [] ) ->
495
+ begin match V.Term.Cst. builtin f with
496
+ | B. Integer s ->
497
+ let id = Dolmen_std.Id. create Term (N. indexed " divisible" [s]) in
498
+ aux id [x]
499
+ | _ -> _cannot_print " bad divisible application"
500
+ end
501
+ | _ -> _cannot_print " bad divisible application"
502
+ end
503
+ | _ -> _cannot_print " bad divisible application"
504
+ end
505
+
506
+ (* Bitvectors *)
507
+ | B. Bitvec s -> p (Value Binary ) (N. simple s) (* TODO: see if we can recover hex form ? *)
508
+ | B. Bitv_not _ -> simple " bvnot"
509
+ | B. Bitv_and _ -> simple " bvand"
510
+ | B. Bitv_or _ -> simple " bvor"
511
+ | B. Bitv_nand _ -> simple " bvnand"
512
+ | B. Bitv_nor _ -> simple " bvnor"
513
+ | B. Bitv_xor _ -> simple " bvxor"
514
+ | B. Bitv_xnor _ -> simple " bvxnor"
515
+ | B. Bitv_comp _ -> simple " bvcomp"
516
+ | B. Bitv_neg _ -> simple " bvneg"
517
+ | B. Bitv_add _ -> simple " bvadd"
518
+ | B. Bitv_sub _ -> simple " bvsub"
519
+ | B. Bitv_mul _ -> simple " bvsub"
520
+ | B. Bitv_udiv _ -> simple " bvudiv"
521
+ | B. Bitv_srem _ -> simple " bvsrem"
522
+ | B. Bitv_smod _ -> simple " bvsmod"
523
+ | B. Bitv_shl _ -> simple " bvshl"
524
+ | B. Bitv_lshr _ -> simple " bvlshr"
525
+ | B. Bitv_ashr _ -> simple " bvashr"
526
+ | B. Bitv_ult _ -> simple " bvult"
527
+ | B. Bitv_ule _ -> simple " bvule"
528
+ | B. Bitv_ugt _ -> simple " bvugt"
529
+ | B. Bitv_uge _ -> simple " bvuge"
530
+ | B. Bitv_slt _ -> simple " bvslt"
531
+
532
+ (* fallback *)
402
533
| _ -> _cannot_print " unknown term builtin"
403
534
404
535
and letin env fmt (l , body ) =
536
+ (* reset some env state *)
537
+ let env = set_omit_to_real env false in
538
+ (* actual printing *)
405
539
match l with
406
540
| [] -> term env fmt body
407
541
| binding :: r ->
@@ -410,6 +544,9 @@ module Make
410
544
(var_binding env' env) binding (letin env') (r, body)
411
545
412
546
and letand env fmt (l , body ) =
547
+ (* reset some env state *)
548
+ let env = set_omit_to_real env false in
549
+ (* actual printing *)
413
550
let env' = List. fold_left add_binding_to_env env l in
414
551
Format. fprintf fmt " @[<hv>(let @[<hv>(%a)@]@ %a)@]"
415
552
(list (var_binding env') env) l (term env) body
@@ -418,6 +555,9 @@ module Make
418
555
Format. fprintf fmt " @[<hov 2>(%a@ %a)@]" (term_var var_env) v (term t_env) t
419
556
420
557
and term_match env fmt (scrutinee , cases ) =
558
+ (* reset some env state *)
559
+ let env = set_omit_to_real env false in
560
+ (* actual printing *)
421
561
Format. fprintf fmt " @[<hv 2>(match@ @[<hov>%a@]@ (%a))"
422
562
(term env) scrutinee
423
563
(list match_case env) cases
@@ -435,6 +575,9 @@ module Make
435
575
(term_cst env) c (list term_var env) args
436
576
437
577
and quant q env fmt (tys , ts , body ) =
578
+ (* reset some env state *)
579
+ let env = set_omit_to_real env false in
580
+ (* actual printing *)
438
581
(* TODO: patterns/triggers *)
439
582
match tys, ts with
440
583
| _ :: _ , _ -> _cannot_print " type quantification"
0 commit comments