operators.ml 1.68 KB
Newer Older
1
open Cduce_loc
2 3
type type_fun = Types.t -> bool -> Types.t

4 5
let register op arity typ eval =
  Typer.register_op op arity typ;
6
  Eval.register_op op eval
7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22

let register_unary op typ eval =
  register op 1
    (function
       | [ tf ] -> 
	   typ tf
       | _ ->
	   raise (Typer.Error (
	     ("Built-in operator " ^ op ^ " needs exactly one argument")))
    )
    (function
       | [ v ] -> eval v
       | _ -> assert false
    )

let register_binary op typ eval =
23
  register op 2
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
    (function
       | [ tf1; tf2 ] -> 
	   typ tf1 tf2
       | _ ->
	   raise (Typer.Error (
	     ("Built-in operator " ^ op ^ " needs exactly two arguments")))
    )
    (function
       | [ v1; v2 ] -> eval v1 v2
       | _ -> assert false
    )

let register_cst op t v =
  register op 0
    (function
       | [ ] -> fun _ _  -> t
       | _ -> assert false)
    (function
       | [ ] -> v
       | _ -> assert false
    )

let register_fun op dom codom eval =
  register_cst op
    (Types.arrow (Types.cons dom) (Types.cons codom))
49
    (Value.Abstraction (Some [(dom,codom)],eval, Value.Identity))
50

51 52 53 54 55 56 57
let register_fun2 op dom1 dom2 codom eval =
  let t2 = Types.arrow (Types.cons dom2) (Types.cons codom) in
  let iface2 = Some [(dom2,codom)] in
  register_cst op
    (Types.arrow (Types.cons dom1) (Types.cons t2))
    (Value.Abstraction (Some [(dom1,t2)],(fun v1 ->
					    Value.Abstraction (iface2,
58
							       eval v1, Value.Identity)), Value.Identity))
59 60 61 62
let register_op op ?(expect=Types.any) typ eval =
  register_unary op 
    (fun tf _ _ -> let t = tf expect true in typ t)
    eval
63 64 65 66 67

let register_op2 op t1 t2 s eval =
  register_binary op
    (fun tf1 tf2 _ _ -> ignore (tf1 t1 false); ignore (tf2 t2 false); s)
    eval