Paris7/compilation
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Activity

fmt.. sorry

Browse source
This commit is contained in:
Mylloon 2023-10-30 14:53:49 +01:00
parent 30eb4b0eaf
commit ceb2caa21e
Signed by: Anri
GPG key ID: A82D63DFF8D1317F
1 changed files with 212 additions and 194 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

406
flap/src/hopix/hopixInterpreter.ml
View file

@ -3,120 +3,142 @@ open Error
open HopixAST open HopixAST
(** [error pos msg] reports execution error messages. *) (** [error pos msg] reports execution error messages. *)
let error positions msg = let error positions msg = errorN "execution" positions msg
errorN "execution" positions msg
(** Every expression of Hopix evaluates into a [value]. (** Every expression of Hopix evaluates into a [value].
The [value] type is not defined here. Instead, it will be defined The [value] type is not defined here. Instead, it will be defined
by instantiation of following ['e gvalue] with ['e = environment]. by instantiation of following ['e gvalue] with ['e = environment].
Why? The value type and the environment type are mutually recursive Why? The value type and the environment type are mutually recursive
and since we do not want to define them simultaneously, this and since we do not want to define them simultaneously, this
parameterization is a way to describe how the value type will use parameterization is a way to describe how the value type will use
the environment type without an actual definition of this type. the environment type without an actual definition of this type. *)
*)
type 'e gvalue = type 'e gvalue =
| VInt of Mint.t | VInt of Mint.t
| VChar of char | VChar of char
| VString of string | VString of string
| VUnit | VUnit
| VTagged of constructor * 'e gvalue list | VTagged of constructor * 'e gvalue list
| VTuple of 'e gvalue list | VTuple of 'e gvalue list
| VRecord of (label * 'e gvalue) list | VRecord of (label * 'e gvalue) list
| VLocation of Memory.location | VLocation of Memory.location
| VClosure of 'e * pattern located * expression located | VClosure of 'e * pattern located * expression located
| VPrimitive of string * ('e gvalue Memory.t -> 'e gvalue -> 'e gvalue) | VPrimitive of string * ('e gvalue Memory.t -> 'e gvalue -> 'e gvalue)
(** Two values for booleans. *) (** Two values for booleans. *)
let ptrue = VTagged (KId "True", []) let ptrue = VTagged (KId "True", [])
let pfalse = VTagged (KId "False", []) let pfalse = VTagged (KId "False", [])
(** (** We often need to check that a value has a specific shape.
We often need to check that a value has a specific shape.
To that end, we introduce the following coercions. A To that end, we introduce the following coercions. A
coercion of type [('a, 'e)] coercion tries to convert an coercion of type [('a, 'e)] coercion tries to convert an
Hopix value into a OCaml value of type ['a]. If this conversion Hopix value into a OCaml value of type ['a]. If this conversion
fails, it returns [None]. fails, it returns [None]. *)
*)
type ('a, 'e) coercion = 'e gvalue -> 'a option type ('a, 'e) coercion = 'e gvalue -> 'a option
let fail = None let fail = None
let ret x = Some x let ret x = Some x
let value_as_int = function VInt x -> ret x | _ -> fail
let value_as_char = function VChar c -> ret c | _ -> fail let value_as_int = function
let value_as_string = function VString s -> ret s | _ -> fail | VInt x -> ret x
let value_as_tagged = function VTagged (k, vs) -> ret (k, vs) | _ -> fail | _ -> fail
let value_as_record = function VRecord fs -> ret fs | _ -> fail ;;
let value_as_location = function VLocation l -> ret l | _ -> fail
let value_as_closure = function VClosure (e, p, b) -> ret (e, p, b) | _ -> fail let value_as_char = function
let value_as_primitive = function VPrimitive (p, f) -> ret (p, f) | _ -> fail | VChar c -> ret c
| _ -> fail
;;
let value_as_string = function
| VString s -> ret s
| _ -> fail
;;
let value_as_tagged = function
| VTagged (k, vs) -> ret (k, vs)
| _ -> fail
;;
let value_as_record = function
| VRecord fs -> ret fs
| _ -> fail
;;
let value_as_location = function
| VLocation l -> ret l
| _ -> fail
;;
let value_as_closure = function
| VClosure (e, p, b) -> ret (e, p, b)
| _ -> fail
;;
let value_as_primitive = function
| VPrimitive (p, f) -> ret (p, f)
| _ -> fail
;;
let value_as_bool = function let value_as_bool = function
| VTagged (KId "True", []) -> true | VTagged (KId "True", []) -> true
| VTagged (KId "False", []) -> false | VTagged (KId "False", []) -> false
| _ -> assert false | _ -> assert false
;;
(** (** It is also very common to have to inject an OCaml value into
It is also very common to have to inject an OCaml value into the types of Hopix values. That is the purpose of a wrapper. *)
the types of Hopix values. That is the purpose of a wrapper.
*)
type ('a, 'e) wrapper = 'a -> 'e gvalue type ('a, 'e) wrapper = 'a -> 'e gvalue
let int_as_value x = VInt x
let int_as_value x = VInt x
let bool_as_value b = if b then ptrue else pfalse let bool_as_value b = if b then ptrue else pfalse
(** (** The flap toplevel needs to print the result of evaluations. This is
especially useful for debugging and testing purpose. Do not modify
The flap toplevel needs to print the result of evaluations. This is the code of this function since it is used by the testsuite. *)
especially useful for debugging and testing purpose. Do not modify
the code of this function since it is used by the testsuite.
*)
let print_value m v = let print_value m v =
(** To avoid to print large (or infinite) values, we stop at depth 5. *) (* To avoid to print large (or infinite) values, we stop at depth 5. *)
let max_depth = 5 in let max_depth = 5 in
let rec print_value d v = let rec print_value d v =
if d >= max_depth then "..." else if d >= max_depth
then "..."
else (
match v with match v with
| VInt x -> | VInt x -> Mint.to_string x
Mint.to_string x | VChar c -> "'" ^ Char.escaped c ^ "'"
| VChar c -> | VString s -> "\"" ^ String.escaped s ^ "\""
"'" ^ Char.escaped c ^ "'" | VUnit -> "()"
| VString s -> | VLocation a -> print_array_value d (Memory.dereference m a)
"\"" ^ String.escaped s ^ "\"" | VTagged (KId k, []) -> k
| VUnit -> | VTagged (KId k, vs) -> k ^ print_tuple d vs
"()" | VTuple vs -> print_tuple d vs
| VLocation a -> | VRecord fs ->
print_array_value d (Memory.dereference m a) "{"
| VTagged (KId k, []) -> ^ String.concat
k ", "
| VTagged (KId k, vs) -> (List.map (fun (LId f, v) -> f ^ " = " ^ print_value (d + 1) v) fs)
k ^ print_tuple d vs ^ "}"
| VTuple (vs) -> | VClosure _ -> "<fun>"
print_tuple d vs | VPrimitive (s, _) -> Printf.sprintf "<primitive: %s>" s)
| VRecord fs -> and print_tuple d vs =
"{" "(" ^ String.concat ", " (List.map (print_value (d + 1)) vs) ^ ")"
^ String.concat ", " ( and print_array_value d block =
List.map (fun (LId f, v) -> f ^ " = " ^ print_value (d + 1) v let r = Memory.read block in
) fs) ^ "}" let n = Mint.to_int (Memory.size block) in
| VClosure _ -> "[ "
"<fun>" ^ String.concat
| VPrimitive (s, _) -> ", "
Printf.sprintf "<primitive: %s>" s List.(
and print_tuple d vs = map
"(" ^ String.concat ", " (List.map (print_value (d + 1)) vs) ^ ")" (fun i -> print_value (d + 1) (r (Mint.of_int i)))
and print_array_value d block = (ExtStd.List.range 0 (n - 1)))
let r = Memory.read block in ^ " ]"
let n = Mint.to_int (Memory.size block) in
"[ " ^ String.concat ", " (
List.(map (fun i -> print_value (d + 1) (r (Mint.of_int i)))
(ExtStd.List.range 0 (n - 1))
)) ^ " ]"
in in
print_value 0 v print_value 0 v
;;
let print_values m vs = let print_values m vs = String.concat "; " (List.map (print_value m) vs)
String.concat "; " (List.map (print_value m) vs)
module Environment : sig module Environment : sig
(** Evaluation environments map identifiers to values. *) (** Evaluation environments map identifiers to values. *)
@ -126,14 +148,14 @@ module Environment : sig
val empty : t val empty : t
(** [bind env x v] extends [env] with a binding from [x] to [v]. *) (** [bind env x v] extends [env] with a binding from [x] to [v]. *)
val bind : t -> identifier -> t gvalue -> t val bind : t -> identifier -> t gvalue -> t
(** [update pos x env v] modifies the binding of [x] in [env] so (** [update pos x env v] modifies the binding of [x] in [env] so
that [x ↦ v] ∈ [env]. *) that [x ↦ v] ∈ [env]. *)
val update : Position.t -> identifier -> t -> t gvalue -> unit val update : Position.t -> identifier -> t -> t gvalue -> unit
(** [lookup pos x env] returns [v] such that [x ↦ v] ∈ env. *) (** [lookup pos x env] returns [v] such that [x ↦ v] ∈ env. *)
val lookup : Position.t -> identifier -> t -> t gvalue val lookup : Position.t -> identifier -> t -> t gvalue
(** [UnboundIdentifier (x, pos)] is raised when [update] or (** [UnboundIdentifier (x, pos)] is raised when [update] or
[lookup] assume that there is a binding for [x] in [env], [lookup] assume that there is a binding for [x] in [env],
@ -141,134 +163,126 @@ module Environment : sig
exception UnboundIdentifier of identifier * Position.t exception UnboundIdentifier of identifier * Position.t
(** [last env] returns the latest binding in [env] if it exists. *) (** [last env] returns the latest binding in [env] if it exists. *)
val last : t -> (identifier * t gvalue * t) option val last : t -> (identifier * t gvalue * t) option
(** [print env] returns a human readable representation of [env]. *) (** [print env] returns a human readable representation of [env]. *)
val print : t gvalue Memory.t -> t -> string val print : t gvalue Memory.t -> t -> string
end = struct end = struct
type t = type t =
| EEmpty | EEmpty
| EBind of identifier * t gvalue ref * t | EBind of identifier * t gvalue ref * t
let empty = EEmpty let empty = EEmpty
let bind e x v = EBind (x, ref v, e)
let bind e x v =
EBind (x, ref v, e)
exception UnboundIdentifier of identifier * Position.t exception UnboundIdentifier of identifier * Position.t
let lookup' pos x = let lookup' pos x =
let rec aux = function let rec aux = function
| EEmpty -> raise (UnboundIdentifier (x, pos)) | EEmpty -> raise (UnboundIdentifier (x, pos))
| EBind (y, v, e) -> | EBind (y, v, e) -> if x = y then v else aux e
if x = y then v else aux e
in in
aux aux
;;
let lookup pos x e = !(lookup' pos x e) let lookup pos x e = !(lookup' pos x e)
let update pos x e v = lookup' pos x e := v
let update pos x e v =
lookup' pos x e := v
let last = function let last = function
| EBind (x, v, e) -> Some (x, !v, e) | EBind (x, v, e) -> Some (x, !v, e)
| EEmpty -> None | EEmpty -> None
;;
let print_binding m (Id x, v) = let print_binding m (Id x, v) = x ^ " = " ^ print_value m !v
x ^ " = " ^ print_value m !v
let print m e = let print m e =
let b = Buffer.create 13 in let b = Buffer.create 13 in
let push x v = Buffer.add_string b (print_binding m (x, v)) in let push x v = Buffer.add_string b (print_binding m (x, v)) in
let rec aux = function let rec aux = function
| EEmpty -> Buffer.contents b | EEmpty -> Buffer.contents b
| EBind (x, v, EEmpty) -> push x v; aux EEmpty | EBind (x, v, EEmpty) ->
| EBind (x, v, e) -> push x v; Buffer.add_string b "\n"; aux e push x v;
aux EEmpty
| EBind (x, v, e) ->
push x v;
Buffer.add_string b "\n";
aux e
in in
aux e aux e
;;
end end
(** (** We have everything we need now to define [value] as an instantiation
We have everything we need now to define [value] as an instantiation of ['e gvalue] with ['e = Environment.t], as promised. *)
of ['e gvalue] with ['e = Environment.t], as promised.
*)
type value = Environment.t gvalue type value = Environment.t gvalue
(** (** The following higher-order function lifts a function [f] of type
The following higher-order function lifts a function [f] of type ['a -> 'b] as a [name]d Hopix primitive function, that is, an
['a -> 'b] as a [name]d Hopix primitive function, that is, an OCaml function of type [value -> value]. *)
OCaml function of type [value -> value]. let primitive name ?(error = fun () -> assert false) coercion wrapper f : value =
*) VPrimitive
let primitive name ?(error = fun () -> assert false) coercion wrapper f ( name
: value , fun x ->
= VPrimitive (name, fun x -> match coercion x with
match coercion x with | None -> error ()
| None -> error () | Some x -> wrapper (f x) )
| Some x -> wrapper (f x) ;;
)
type runtime = { type runtime =
memory : value Memory.t; { memory : value Memory.t
environment : Environment.t; ; environment : Environment.t
} }
type observable = { type observable =
new_memory : value Memory.t; { new_memory : value Memory.t
new_environment : Environment.t; ; new_environment : Environment.t
} }
(** [primitives] is an environment that contains the implementation (** [primitives] is an environment that contains the implementation
of all primitives (+, <, ...). *) of all primitives (+, <, ...). *)
let primitives = let primitives =
let intbin name out op = let intbin name out op =
let error m v = let error m v =
Printf.eprintf Printf.eprintf "Invalid arguments for `%s': %s\n" name (print_value m v);
"Invalid arguments for `%s': %s\n"
name (print_value m v);
assert false (* By typing. *) assert false (* By typing. *)
in in
VPrimitive (name, fun m -> function VPrimitive
| VInt x -> ( name
VPrimitive (name, fun m -> function , fun m -> function
| VInt y -> out (op x y) | VInt x ->
| v -> error m v) VPrimitive
| v -> error m v) ( name
, fun m -> function
| VInt y -> out (op x y)
| v -> error m v )
| v -> error m v )
in in
let bind_all what l x = let bind_all what l x =
List.fold_left (fun env (x, v) -> Environment.bind env (Id x) (what x v)) List.fold_left (fun env (x, v) -> Environment.bind env (Id x) (what x v)) x l
x l
in in
(* Define arithmetic binary operators. *) (* Define arithmetic binary operators. *)
let binarith name = let binarith name = intbin name (fun x -> VInt x) in
intbin name (fun x -> VInt x) in let binarithops = Mint.[ "`+`", add; "`-`", sub; "`*`", mul; "`/`", div ] in
let binarithops = Mint.(
[ ("`+`", add); ("`-`", sub); ("`*`", mul); ("`/`", div) ]
) in
(* Define arithmetic comparison operators. *) (* Define arithmetic comparison operators. *)
let cmparith name = intbin name bool_as_value in let cmparith name = intbin name bool_as_value in
let cmparithops = let cmparithops =
[ ("`=?`", ( = )); [ "`=?`", ( = ); "`<?`", ( < ); "`>?`", ( > ); "`>=?`", ( >= ); "`<=?`", ( <= ) ]
("`<?`", ( < ));
("`>?`", ( > ));
("`>=?`", ( >= ));
("`<=?`", ( <= )) ]
in in
let boolbin name out op = let boolbin name out op =
VPrimitive (name, fun _ x -> VPrimitive (name, fun _ y -> VPrimitive
out (op (value_as_bool x) (value_as_bool y)))) ( name
, fun _ x ->
VPrimitive (name, fun _ y -> out (op (value_as_bool x) (value_as_bool y))) )
in in
let boolarith name = boolbin name (fun x -> if x then ptrue else pfalse) in let boolarith name = boolbin name (fun x -> if x then ptrue else pfalse) in
let boolarithops = let boolarithops = [ "`||`", ( || ); "`&&`", ( && ) ] in
[ ("`||`", ( || )); ("`&&`", ( && )) ]
in
let generic_printer = let generic_printer =
VPrimitive ("print", fun m v -> VPrimitive
output_string stdout (print_value m v); ( "print"
flush stdout; , fun m v ->
VUnit output_string stdout (print_value m v);
) flush stdout;
VUnit )
in in
let print s = let print s =
output_string stdout s; output_string stdout s;
@ -276,81 +290,85 @@ let primitives =
VUnit VUnit
in in
let print_int = let print_int =
VPrimitive ("print_int", fun _ -> function VPrimitive
| VInt x -> print (Mint.to_string x) ( "print_int"
| _ -> assert false (* By typing. *) , fun _ -> function
) | VInt x -> print (Mint.to_string x)
| _ -> assert false (* By typing. *) )
in in
let print_string = let print_string =
VPrimitive ("print_string", fun _ -> function VPrimitive
| VString x -> print x ( "print_string"
| _ -> assert false (* By typing. *) , fun _ -> function
) | VString x -> print x
| _ -> assert false (* By typing. *) )
in in
let bind' x w env = Environment.bind env (Id x) w in let bind' x w env = Environment.bind env (Id x) w in
Environment.empty Environment.empty
|> bind_all binarith binarithops |> bind_all binarith binarithops
|> bind_all cmparith cmparithops |> bind_all cmparith cmparithops
|> bind_all boolarith boolarithops |> bind_all boolarith boolarithops
|> bind' "print" generic_printer |> bind' "print" generic_printer
|> bind' "print_int" print_int |> bind' "print_int" print_int
|> bind' "print_string" print_string |> bind' "print_string" print_string
|> bind' "true" ptrue |> bind' "true" ptrue
|> bind' "false" pfalse |> bind' "false" pfalse
|> bind' "nothing" VUnit |> bind' "nothing" VUnit
;;
let initial_runtime () = { let initial_runtime () =
memory = Memory.create (640 * 1024 (* should be enough. -- B.Gates *)); { memory = Memory.create (640 * 1024 (* should be enough. -- B.Gates *))
environment = primitives; ; environment = primitives
} }
;;
let rec evaluate runtime ast = let rec evaluate runtime ast =
try try
let runtime' = List.fold_left definition runtime ast in let runtime' = List.fold_left definition runtime ast in
(runtime', extract_observable runtime runtime') runtime', extract_observable runtime runtime'
with Environment.UnboundIdentifier (Id x, pos) -> with
| Environment.UnboundIdentifier (Id x, pos) ->
Error.error "interpretation" pos (Printf.sprintf "`%s' is unbound." x) Error.error "interpretation" pos (Printf.sprintf "`%s' is unbound." x)
(** [definition pos runtime d] evaluates the new definition [d] (** [definition pos runtime d] evaluates the new definition [d]
into a new runtime [runtime']. In the specification, this into a new runtime [runtime']. In the specification, this
is the judgment: is the judgment:
E, M ⊢ dv ⇒ E', M' E, M ⊢ dv ⇒ E', M' *)
*)
and definition runtime d = and definition runtime d =
failwith "Students! This is your job!" (* TODO *)
failwith "Students! This is your job!"
and expression' environment memory e = and expression' environment memory e =
expression (position e) environment memory (value e) expression (position e) environment memory (value e)
(** [expression pos runtime e] evaluates into a value [v] if (** [expression pos runtime e] evaluates into a value [v] if
E, M ⊢ e ⇓ v, M' E, M ⊢ e ⇓ v, M'
and E = [runtime.environment], M = [runtime.memory]. and E = [runtime.environment], M = [runtime.memory]. *)
*)
and expression _ environment memory = and expression _ environment memory =
failwith "Students! This is your job!" (* TODO *)
failwith "Students! This is your job!"
(** This function returns the difference between two runtimes. *) (** This function returns the difference between two runtimes. *)
and extract_observable runtime runtime' = and extract_observable runtime runtime' =
let rec substract new_environment env env' = let rec substract new_environment env env' =
if env == env' then new_environment if env == env'
else then new_environment
else (
match Environment.last env' with match Environment.last env' with
| None -> assert false (* Absurd. *) | None -> assert false (* Absurd. *)
| Some (x, v, env') -> | Some (x, v, env') ->
let new_environment = Environment.bind new_environment x v in let new_environment = Environment.bind new_environment x v in
substract new_environment env env' substract new_environment env env')
in in
{ { new_environment = substract Environment.empty runtime.environment runtime'.environment
new_environment = ; new_memory = runtime'.memory
substract Environment.empty runtime.environment runtime'.environment;
new_memory =
runtime'.memory
} }
;;
(** This function displays a difference between two runtimes. *) (** This function displays a difference between two runtimes. *)
let print_observable (_ : runtime) observation = let print_observable (_ : runtime) observation =
Environment.print observation.new_memory observation.new_environment Environment.print observation.new_memory observation.new_environment
;;