viewcvs.cgi/compile/operators.ml

open Location
type type_fun = Types.t -> bool -> Types.t

module Unary = struct
  module Op = struct
    type t = (loc -> type_fun -> type_fun) * (Value.t -> Value.t)
  end
  module Proxy = Custom.Proxy(Custom.String)(Typer)(Op)
  include Pool.NoHash(Proxy)

  let register name make typ run ser deser =
    Proxy.register name make
      { Proxy.content = (fun x -> (typ x, run x));
        Proxy.serialize = ser;
        Proxy.deserialize = deser };;
      
  Typer.mk_unary_op := (fun name env -> mk (Proxy.instantiate name env));;
  Typer.typ_unary_op := (fun i -> fst (Proxy.content (value i)));;
  Eval.eval_unary_op := (fun i -> snd (Proxy.content (value i)));;
  Lambda.Put.unary_op := serialize;;
  Lambda.Get.unary_op := deserialize;;
end

module Binary = struct
  module Op = struct
    type t = (loc -> type_fun -> type_fun -> type_fun) * 
        (Value.t -> Value.t -> Value.t)
  end
  module Proxy = Custom.Proxy(Custom.String)(Typer)(Op)
  include Pool.NoHash(Proxy)

  let register name make typ run ser deser =
    Proxy.register name make
      { Proxy.content = (fun x -> (typ x, run x));
        Proxy.serialize = ser;
        Proxy.deserialize = deser };;
      
  Typer.mk_binary_op := (fun name env -> mk (Proxy.instantiate name env));;
  Typer.typ_binary_op := (fun i -> fst (Proxy.content (value i)));;
  Eval.eval_binary_op := (fun i -> snd (Proxy.content (value i)));;
  Lambda.Put.binary_op := serialize;;
  Lambda.Get.binary_op := deserialize;;
end


let register op arity typ eval =
  Typer.register_op op arity typ;
  Eval.register_op op eval

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 =
  register op 1
    (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))
    (Value.Abstraction ([(dom,codom)],eval))

let register_op op ?(expect=Types.any) typ eval =
  register_unary op 
    (fun tf _ _ -> let t = tf expect true in typ t)
    eval
1	open Location
2	type type_fun = Types.t -> bool -> Types.t
3
4	module Unary = struct
5	module Op = struct
6	type t = (loc -> type_fun -> type_fun) * (Value.t -> Value.t)
7	end
8	module Proxy = Custom.Proxy(Custom.String)(Typer)(Op)
9	include Pool.NoHash(Proxy)
10
11	let register name make typ run ser deser =
12	Proxy.register name make
13	{ Proxy.content = (fun x -> (typ x, run x));
14	Proxy.serialize = ser;
15	Proxy.deserialize = deser };;
16
17	Typer.mk_unary_op := (fun name env -> mk (Proxy.instantiate name env));;
18	Typer.typ_unary_op := (fun i -> fst (Proxy.content (value i)));;
19	Eval.eval_unary_op := (fun i -> snd (Proxy.content (value i)));;
20	Lambda.Put.unary_op := serialize;;
21	Lambda.Get.unary_op := deserialize;;
22	end
23
24	module Binary = struct
25	module Op = struct
26	type t = (loc -> type_fun -> type_fun -> type_fun) *
27	(Value.t -> Value.t -> Value.t)
28	end
29	module Proxy = Custom.Proxy(Custom.String)(Typer)(Op)
30	include Pool.NoHash(Proxy)
31
32	let register name make typ run ser deser =
33	Proxy.register name make
34	{ Proxy.content = (fun x -> (typ x, run x));
35	Proxy.serialize = ser;
36	Proxy.deserialize = deser };;
37
38	Typer.mk_binary_op := (fun name env -> mk (Proxy.instantiate name env));;
39	Typer.typ_binary_op := (fun i -> fst (Proxy.content (value i)));;
40	Eval.eval_binary_op := (fun i -> snd (Proxy.content (value i)));;
41	Lambda.Put.binary_op := serialize;;
42	Lambda.Get.binary_op := deserialize;;
43	end
44
45
46	let register op arity typ eval =
47	Typer.register_op op arity typ;
48	Eval.register_op op eval
49
50	let register_unary op typ eval =
51	register op 1
52	(function
53	\| [ tf ] ->
54	typ tf
55	\| _ ->
56	raise (Typer.Error (
57	("Built-in operator " ^ op ^ " needs exactly one argument")))
58	)
59	(function
60	\| [ v ] -> eval v
61	\| _ -> assert false
62	)
63
64	let register_binary op typ eval =
65	register op 1
66	(function
67	\| [ tf1; tf2 ] ->
68	typ tf1 tf2
69	\| _ ->
70	raise (Typer.Error (
71	("Built-in operator " ^ op ^ " needs exactly two arguments")))
72	)
73	(function
74	\| [ v1; v2 ] -> eval v1 v2
75	\| _ -> assert false
76	)
77
78	let register_cst op t v =
79	register op 0
80	(function
81	\| [ ] -> fun _ _ -> t
82	\| _ -> assert false)
83	(function
84	\| [ ] -> v
85	\| _ -> assert false
86	)
87
88	let register_fun op dom codom eval =
89	register_cst op
90	(Types.arrow (Types.cons dom) (Types.cons codom))
91	(Value.Abstraction ([(dom,codom)],eval))
92
93	let register_op op ?(expect=Types.any) typ eval =
94	register_unary op
95	(fun tf _ _ -> let t = tf expect true in typ t)
96	eval