Source

blub / blub_num.ml

Full commit
open Format
open Blub_types
open Blub_common
open Blub_environment.Env

let addn = function
    [| |] -> Sint 0
  | [| x |] -> x
  | [| Sint x; Sint y |] -> Sint (x+y)
  | [| Sfloat x; Sfloat y |] -> Sfloat (x +. y)
  | [| Sint x; Sfloat y |] -> Sfloat (float x +. y)
  | [| Sfloat x; Sint y |] -> Sfloat (float y +. x)
  | ints ->
      let ints = Array.map (fun (Sint x) -> x) ints in
      Sint (Array.fold_right (+) ints 0)
;;

let add1 = function
    Sint x -> Sint (x+1)
;;

let subn = function
    [| Sint x |] -> Sint (-x)
  | [| Sint x; Sint y |] -> Sint (x-y)
  | [| Sfloat x; Sfloat y |] -> Sfloat (x -. y)
  | ints ->
      let ints = Array.map (fun (Sint x) -> x) ints in
      Sint (Array.fold_left (-) (2 * ints.(0)) ints)
;;

let muln = function
    [| |] -> Sint 1
  | [| x |] -> x
  | [| Sint x; Sint y |] -> Sint (x*y)
  | [| Sint x; Sfloat y |] -> Sfloat ((float x) *. y)
  | [| Sfloat x; Sfloat y |] -> Sfloat (x *. y)
  | [| Sfloat x; Sint y |] -> Sfloat (x *. (float y))
;;

let divn = function
    [| |] -> Sint 1
  | [| x |] -> x
  | [| Sint x; Sint y |] -> Sint (x/y)
  | [| Sint x; Sfloat y |] -> Sfloat ((float x) /. y)
  | [| Sfloat x; Sfloat y |] -> Sfloat (x /. y)
  | [| Sfloat x; Sint y |] -> Sfloat (x /. (float y))
;;



let cmp2 eq_only a b =
  match (a, b) with
      (Sint i1, Sint i2) ->
	if i1 > i2 then 1 else if i1 < i2 then -1 else 0
    | (Sfloat i1, Sfloat i2) ->
	if i1 > i2 then 1 else if i1 < i2 then -1 else 0
    | _ ->
	printf "Invalid args: %a and %a\n%!" pp_sval a pp_sval b;
	assert false

(*
  | _ ->
    begin
      match snum_fixtypes a b with
	(Sreal r1, Sreal r2) ->
	  let r = r1 -. r2 in
	    if r > 0.0 then 1 else if r < 0.0 then -1 else 0
      | (Scomplex z1, Scomplex z2) ->
	  if eq_only then
	    if z1 = z2 then 0 else 1
	  else
	    if z1.Complex.im = 0.0 && z2.Complex.im = 0.0 then
	      begin
		let r = z1.Complex.re -. z2.Complex.re in
		  if r > 0.0 then 1 else if r < 0.0 then -1 else 0
	      end
	    else
	      raise (Error "complex numbers compared")
      | (Srational r1, Srational r2) ->
	  compare_ratio r1 r2
      | (Sbigint bi1, Sbigint bi2) ->
	  compare_big_int bi1 bi2
      | _ -> raise (Error "cmp: invalid args")
    end
*)
;;

let snum_eq av =
  match Array.length av with
    0 | 1 -> Strue
  | n ->
      let a0 = av.(0) in
      let rec loop i =
	if i < n then
	  begin
	    if cmp2 true a0 av.(i) <> 0 then Sfalse
	    else loop (i + 1)
	  end
	else
	  Strue
      in
	loop 1
;;

let snum_rel op = function
    [| |] | [| _ |] -> Strue
  | [| x; y |] ->
      if op (cmp2 false x y) 0 then Strue else Sfalse
  | av ->
      let n = Array.length av in
      let rec loop v i =
	if i < n then
	  begin
	    if op (cmp2 false v av.(i)) 0 then loop av.(i) (i + 1)
	    else Sfalse
	  end
	else
	  Strue
      in
	loop av.(0) 1
;;

let blub_assert e1 = 
  assert (e1 != Sfalse);
  Snull
;;

let init e =
  set_pfn e addn "+";
  set_pf1 e add1 "add1";
  set_pfn e subn "-";
  set_pfn e muln "*";
  set_pfn e divn "/";
  set_pfn e snum_eq "=";

  set_pfn e (snum_rel (>)) ">";
  set_pfn e (snum_rel (<)) "<";
  set_pfn e (snum_rel (>=)) ">=";
  set_pfn e (snum_rel (<=)) "<=";

  set_pf1 e blub_assert "assert"
;;