Skip to content

Commit 7b2d001

Browse files
committed
Adding builtins
1 parent 6cf5a94 commit 7b2d001

File tree

5 files changed

+200
-46
lines changed

5 files changed

+200
-46
lines changed

src/interface/env.ml

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -28,6 +28,7 @@ module type Print = sig
2828

2929
type 'a key
3030

31+
val key : unit -> 'a key
3132
val get : t -> 'a key -> 'a option
3233
val set : t -> 'a key -> 'a -> t
3334

src/languages/smtlib2/v2.6/script/print.ml

Lines changed: 174 additions & 31 deletions
Original file line numberDiff line numberDiff line change
@@ -178,6 +178,23 @@ module Make
178178
module F = Dolmen_intf.View.TFF
179179
module E = Dolmen_std.View.Assoc(V)
180180

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+
181198
(* Helpers *)
182199
(* ******* *)
183200

@@ -284,23 +301,39 @@ module Make
284301
| Constructor (_, l) -> List.fold_left Env.Term_var.bind env l
285302

286303
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 ()
291315
| _ -> `Nope
292316

293317
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 *)
304337
| _ -> `None
305338

306339
let term_cst_poly _env c =
@@ -322,22 +355,22 @@ module Make
322355
and term_view env fmt t_ty view =
323356
match (view : _ F.Term.view) with
324357
| 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)
326359
| Match (scrutinee, cases) -> term_match env fmt (scrutinee, cases)
327360
| Binder (Exists (tys, ts), body) -> quant "exists" env fmt (tys, ts, body)
328361
| Binder (Forall (tys, ts), body) -> quant "forall" env fmt (tys, ts, body)
329362
| Binder (Letand l, body) -> letand env fmt (l, body)
330363
| Binder (Letin l, body) -> letin env fmt (l, body)
331364

332-
and term_app env fmt (t_ty, head, args) =
365+
and term_app env fmt (t_ty, head, ty_args, args) =
333366
(* first, we need to undo any left/right associativity/chainability that
334367
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 =
337370
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
341374
in
342375
match V.Term.Cst.builtin head, args with
343376
| B.And, t :: _ ->
@@ -346,23 +379,25 @@ module Make
346379
begin match term_cst_chainable env h with
347380
| `Chainable top_head ->
348381
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
351384
end
352-
| `Nope -> head, args
385+
| `Nope -> head, ty_args, args
353386
end
354-
| _ -> head, args
387+
| _ -> head, ty_args, args
355388
end
356-
| _ -> head, args
389+
| _ -> head, ty_args, args
357390
in
391+
358392
(* smtlib has implicit type arguments, i.e. the type args are not printed.
359393
Therefore, whenever a polymorphic symbol is used, its type arguments
360394
need to be inferable from its term arguments. Hence, when a symbol is
361395
polymorphic and there are no term arguments, we need to print an
362396
explicit type annotation to disambiguate things. In the other cases,
363397
we suppose that a symbol's type arguments can be deduced from the term
364398
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
366401
match args with
367402
| [] ->
368403
if term_cst_poly env head then
@@ -373,10 +408,18 @@ module Make
373408
| _ :: _ ->
374409
Format.fprintf fmt "(%a@ %a)" (id ~allow_keyword:false env) h (list term env) args
375410
in
411+
376412
(* 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 *)
379421
match V.Term.Cst.builtin head with
422+
380423
(* Base + Algebraic datatypes *)
381424
| B.Base | B.Constructor _ | B.Destructor _ ->
382425
p Term (Env.Term_cst.name env head)
@@ -385,6 +428,32 @@ module Make
385428
| Simple s -> p Term (N.indexed "is" [s])
386429
| _ -> _cannot_print "expected a simple for a constructor name"
387430
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+
388457
(* Boolean core *)
389458
| B.True -> simple "true"
390459
| B.False -> simple "false"
@@ -396,12 +465,77 @@ module Make
396465
| B.Ite -> simple "ite"
397466
| B.Equal -> simple "="
398467
| 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 *)
400474
| 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 *)
402533
| _ -> _cannot_print "unknown term builtin"
403534

404535
and letin env fmt (l, body) =
536+
(* reset some env state *)
537+
let env = set_omit_to_real env false in
538+
(* actual printing *)
405539
match l with
406540
| [] -> term env fmt body
407541
| binding :: r ->
@@ -410,6 +544,9 @@ module Make
410544
(var_binding env' env) binding (letin env') (r, body)
411545

412546
and letand env fmt (l, body) =
547+
(* reset some env state *)
548+
let env = set_omit_to_real env false in
549+
(* actual printing *)
413550
let env' = List.fold_left add_binding_to_env env l in
414551
Format.fprintf fmt "@[<hv>(let @[<hv>(%a)@]@ %a)@]"
415552
(list (var_binding env') env) l (term env) body
@@ -418,6 +555,9 @@ module Make
418555
Format.fprintf fmt "@[<hov 2>(%a@ %a)@]" (term_var var_env) v (term t_env) t
419556

420557
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 *)
421561
Format.fprintf fmt "@[<hv 2>(match@ @[<hov>%a@]@ (%a))"
422562
(term env) scrutinee
423563
(list match_case env) cases
@@ -435,6 +575,9 @@ module Make
435575
(term_cst env) c (list term_var env) args
436576

437577
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 *)
438581
(* TODO: patterns/triggers *)
439582
match tys, ts with
440583
| _ :: _, _ -> _cannot_print "type quantification"

src/loop/export.ml

Lines changed: 13 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -96,6 +96,9 @@ module Env(E : Expr_intf.Export)(N : NS) = struct
9696
hmap = H.empty;
9797
}
9898

99+
let key () =
100+
H.Key.create { unit = (); }
101+
99102
let get { hmap; _ } k =
100103
H.find k hmap
101104

@@ -235,7 +238,7 @@ module Smtlib2_6
235238
) env params
236239
) env cases
237240

238-
let print_simple_decl { env; fmt; } = function
241+
let print_simple_decl env fmt = function
239242
| `Type_decl c ->
240243
Format.fprintf fmt "%a@." (P.declare_sort env) c
241244
| `Term_decl c ->
@@ -292,8 +295,8 @@ module Smtlib2_6
292295
Format.fprintf fmt "%a@." (P.declare_datatypes env) l;
293296
env
294297
| l, [], false ->
295-
List.iter (print_simple_decl acc) l;
296298
let env = List.fold_left register_simple_decl env l in
299+
List.iter (print_simple_decl env fmt) l;
297300
env
298301
| _ ->
299302
assert false (* TODO: better error / can this happen ? *)
@@ -308,15 +311,21 @@ module Smtlib2_6
308311
| [], [], _ -> assert false (* internal invariant: should not happen *)
309312
| _ :: _, _ :: _, _ -> assert false (* can this happen ? *)
310313
| _ :: _, [], true -> assert false (* TODO: proper error / cannot print *)
314+
(* Note: we might want to have the body of a definition printed with
315+
an env that does not contain said definition, if only for shadowing
316+
purposes, but that would not change much for the smt2 since shadowing
317+
of constants is not allowed. *)
311318
| l, [], false ->
312319
List.fold_left (fun env ((c, _, _) as def) ->
320+
let env = Env.Ty_cst.bind env c in
313321
Format.fprintf fmt "%a@." (P.define_sort env) def;
314-
Env.Ty_cst.bind env c
322+
env
315323
) env l
316324
| [], l, false ->
317325
List.fold_left (fun env ((c, _, _) as def) ->
326+
let env = Env.Term_cst.bind env c in
318327
Format.fprintf fmt "%a@." (P.define_fun env) def;
319-
Env.Term_cst.bind env c
328+
env
320329
) env l
321330
| [], [(c, _, _) as def], true ->
322331
let env = Env.Term_cst.bind env c in

0 commit comments

Comments
 (0)