Source file `types.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
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
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
(** A value identifier*)
type ide = string
[@@deriving show]

(** The type representing Abstract Syntax Tree expressions *)
type expr =
    | Unit
    | Integer of int
    | Boolean of bool
    | Symbol of ide
    | List of list_pattern
    (* List operations *)
    | Head of expr
    | Tail of expr
    | Cons of expr * expr
    (* Numerical Operations *)
    | Sum of expr * expr
    | Sub of expr * expr
    | Mult of expr * expr
    | Eq of expr * expr
    | Gt of expr * expr
    | Lt of expr * expr
    (* Boolean operations *)
    | And of expr * expr
    | Or of expr * expr
    | Not of expr
    (* Control flow and functions *)
    | IfThenElse of expr * expr * expr
    | Let of ide * expr * expr
    | Letlazy of ide * expr * expr
    | Letrec of ide * expr * expr
    | Letreclazy of ide * expr * expr
    | Lambda of ide list * expr
    | Apply of expr * expr list
    [@@deriving show { with_path = false }]
and list_pattern = EmptyList | ListValue of expr * list_pattern [@@deriving show { with_path = false }]
(** A type to build lists, mutually recursive with `expr` *)

(** A purely functional environment type, parametrized *)
type 'a env_t = (string * 'a) list [@@deriving show { with_path = false }]

(** A type that represents an evaluated (reduced) value *)
type evt =
    | EvtUnit
    | EvtInt of int
    | EvtBool of bool
    | EvtList of evt list
    | Closure of ide list * expr * (type_wrapper env_t)
    (** RecClosure keeps the function name in the constructor for recursion *)
    | RecClosure of ide * ide list * expr * (type_wrapper env_t)
    [@@deriving show { with_path = false }]
and type_wrapper =
    | LazyExpression of expr
    | AlreadyEvaluated of evt
    [@@deriving show]
(** Wrapper type that allows both AST expressions and
evaluated expression for lazy evaluation *)

let rec show_unpacked_evt e = match e with
    | EvtInt v -> string_of_int v
    | EvtBool v -> string_of_bool v
    | EvtList l -> "[" ^ (String.concat "; " (List.map show_unpacked_evt l)) ^ "]"
    | Closure (params, _, _) -> "(fun " ^ (String.concat " " params) ^ " -> ... )"
    | RecClosure (name, params, _, _) -> name ^ " = (rec fun " ^ (String.concat " " params) ^ " -> ... )"
    | _ -> show_evt e

(** An environment of already evaluated values  *)
type env_type = type_wrapper env_t 

(** A recursive type representing a stacktrace frame *)
type stackframe =
    | StackValue of int * expr * stackframe
    | EmptyStack
    [@@deriving show { with_path = false }]

(** Convert a native list to an AST list *)
let rec expand_list l = match l with
    | [] -> EmptyList
    | x::xs -> ListValue (x, expand_list xs)

(** Push an AST expression into a stack
    @param s The stack where to push the expression
    @param e The expression to push
*)
let push_stack (s: stackframe) (e: expr) = match s with
    | StackValue(d, ee, ss) -> StackValue(d+1, e, StackValue(d, ee, ss))
    | EmptyStack -> StackValue(1, e, EmptyStack)

(** Pop an AST expression from a stack *)
let pop_stack (s: stackframe) = match s with
    | StackValue(_, _, ss) -> ss
    | EmptyStack -> failwith "Stack underflow"

exception UnboundVariable of string
exception WrongBindList
exception TypeError of string
exception ListError of string
exception SyntaxError of string