type prim = {name : string; arity : int}
let succ = {name ="succ"; arity = 1}
let plus = {name = "plus"; arity = 2}
type constr = Int of int | Constr of string
type const = {constr : constr; carity : int}
type exp =
| Const of const * exp list
| Prim of prim * exp list
| Var of var
| App of exp * exp
| Fonction of var * exp
| Liaison of var * exp * exp
and var = string;;
type valeur =
| Vconst of const * valeur list
| Vfonction of var * exp * env
and env = (var * valeur) list;;
type error =
| Libre of string
| Delta of prim * valeur list
| Beta of exp
exception Error of error
let error e = raise (Error e);;
let pair = {constr = Constr "paire"; carity = 2};;
let int n = {constr = Int n; carity = 0};;
let fst = {name= "fst"; arity = 1; }
let snd = {name= "snd"; arity = 1; };;
let delta_plus
[ Vconst ({constr = Int x}, []); Vconst ({constr = Int y},[])] =
Vconst (int (x + y), [])
let delta_succ [ Vconst ({constr = Int x}, [])] = Vconst (int (x+1), [])
let delta_fst [Vconst ({constr = Constr "paire"}, [x; y])] = x
let delta_snd [Vconst ({constr = Constr "paire"}, [x; y])] = y
let delta =
[ "succ", delta_succ; "plus", delta_plus;
"fst", delta_fst; "snd", delta_snd ] ;;
let find x env =
try List.assoc x env with Not_found -> error (Libre x);;
let rec eval env = function
| Const (c, args) -> Vconst (c, List.map (eval env) args)
| Var x -> find x env
| Fonction (x, a) as f -> Vfonction (x, a, env)
| App (a1, a2) as e ->
let f = eval env a1 in
let v = eval env a2 in
begin match f with
| Vfonction (x, a, env0) ->
eval ((x, v) :: env0) a
| Vconst _ -> error (Beta e)
end
| Prim (f, args) ->
let vargs = List.map (eval env) args in
begin try (List.assoc f.name delta) vargs
with x -> error (Delta (f, vargs))
end
| Liaison (x, e1, e2) ->
eval env (App (Fonction (x, e2), e1)) ;;
|