syntax.ml

   1: (* Abstract syntax. *)
   2: 
   3: (* Variable names *)
   4: type name = string
   5: 
   6: (* Types *)
   7: type ty =
   8:   | TInt              (* Integers *)
   9:   | TBool             (* Booleans *)
  10:   | TArrow of ty * ty (* Functions *)
  11: 
  12: (* Expressions *)
  13: type expr =
  14:   | Var of name                          (* Variable *)
  15:   | Int of int                           (* Non-negative integer constant *)
  16:   | Bool of bool                         (* Boolean constant *)
  17:   | Times of expr * expr                 (* Product [e1 * e2] *)
  18:   | Plus of expr * expr                  (* Sum [e1 + e2] *)
  19:   | Minus of expr * expr                 (* Difference [e1 - e2] *)
  20:   | Division of expr * expr             (* Division [e1/e2], may result in [Error] *)
  21:   | Equal of expr * expr                 (* Integer comparison [e1 = e2] *)
  22:   | Less of expr * expr                  (* Integer comparison [e1 < e2] *)
  23:   | If of expr * expr * expr                 (* Conditional [if e1 then e2 else e3] *)
  24:   | Fun of name * name * ty * ty * expr (* Function [fun f(x:s):t is e] *)
  25:   | Apply of expr * expr                 (* Application [e1 e2] *)
  26:   | Error                               (* Special value indicating an error *)
  27: 
  28: (* Toplevel commands *)
  29: type toplevel_cmd =
  30:   | Expr of expr       (* Expression *)
  31:   | Def of name * expr (* Value definition [let x = e] *)
  32: 
  33: (* Convert a type to string *)
  34: let string_of_type ty =
  35:   let rec to_str n ty =
  36:     let (m, str) =
  37:       match ty with
  38:         | TInt -> (2, "int")
  39:         | TBool -> (2, "bool")
  40:         | TArrow (ty1, ty2) -> (1, (to_str 1 ty1) ^ " -> " ^ (to_str 0 ty2))
  41:     in
  42:       if m > n then str else "(" ^ str ^ ")"
  43:   in
  44:     to_str (-1) ty
  45: 
  46: (* Convert an expression to string *)
  47: let string_of_expr e =
  48:   let rec to_str n e =
  49:     let (m, str) =
  50:       match e with
  51:         | Int n -> (7, string_of_int n)
  52:         | Bool b -> (7, string_of_bool b)
  53:         | Var x -> (7, x)
  54:         | Error -> (7, "error")
  55:         | Apply (e1, e2) -> (6, (to_str 5 e1) ^ " " ^ (to_str 6 e2))
  56:         | Times (e1, e2) -> (5, (to_str 4 e1) ^ " * " ^ (to_str 5 e2))
  57:         | Division (e1, e2) -> (5, (to_str 4 e1) ^ " / " ^ (to_str 5 e2))
  58:         | Plus (e1, e2) -> (4, (to_str 3 e1) ^ " + " ^ (to_str 4 e2))
  59:         | Minus (e1, e2) -> (4, (to_str 3 e1) ^ " - " ^ (to_str 4 e2))
  60:         | Equal (e1, e2) -> (3, (to_str 3 e1) ^ " = " ^ (to_str 3 e2))
  61:         | Less (e1, e2) -> (3, (to_str 3 e1) ^ " < " ^ (to_str 3 e2))
  62:         | If (e1, e2, e3) -> (2, "if " ^ (to_str 2 e1) ^ " then " ^
  63:                                 (to_str 2 e2) ^ " else " ^ (to_str 2 e3))
  64:         | Fun (f, x, ty1, ty2, e) ->
  65:             (1, "fun " ^ f ^ "(" ^ x ^ " : " ^ (string_of_type ty1) ^ 
  66:                ") : " ^ (string_of_type ty2) ^ " is " ^ (to_str 0 e))
  67:     in
  68:       if m > n then str else "(" ^ str ^ ")"
  69:   in
  70:     to_str (-1) e
  71: 
  72: (* [subst [(x1,e1);...;(xn;en)] e] replaces in expression [e] all
  73:     free occurrences of variables [x1], ..., [xn] with expressions
  74:     [e1], ..., [en], respectively. *)
  75: let rec subst s = function
  76:   | (Var x) as e -> (try List.assoc x s with Not_found -> e)
  77:   | (Int _ | Bool _ | Error) as e -> e
  78:   | Times (e1, e2) -> Times (subst s e1, subst s e2)
  79:   | Division (e1, e2) -> Division (subst s e1, subst s e2)
  80:   | Plus (e1, e2) -> Plus (subst s e1, subst s e2)
  81:   | Minus (e1, e2) -> Minus (subst s e1, subst s e2)
  82:   | Equal (e1, e2) -> Equal (subst s e1, subst s e2)
  83:   | Less (e1, e2) -> Less (subst s e1, subst s e2)
  84:   | If (e1, e2, e3) -> If (subst s e1, subst s e2, subst s e3)
  85:   | Fun (f, x, ty1, ty2, e) ->
  86:       let s' = List.remove_assoc f (List.remove_assoc x s) in
  87:         Fun (f, x, ty1, ty2, subst s' e)
  88:   | Apply (e1, e2) -> Apply (subst s e1, subst s e2)

type_check.ml

   1: (** Type checking. *)
   2: 
   3: open Syntax
   4: 
   5: (** Exception indicating a type error. *)
   6: exception Type_error of string
   7: 
   8: (** [ty_error msg] reports a type error. *)
   9: let type_error msg = raise (Type_error msg)
  10: 
  11: (** [check ctx ty e] verifies that expression [e] has type [ty] in
  12:     context [ctx]. If it does, it returns unit, otherwise it raises the
  13:     [Type_error] exception. *)
  14: let rec check ctx ty e =
  15:   let ty' = type_of ctx e in
  16:     if ty' <> ty then
  17:       type_error
  18:         (string_of_expr e ^ " has type " ^ string_of_type ty' ^
  19:            " but is used as if it has type " ^ string_of_type ty)
  20: 
  21: (** [type_of ctx e] computes the type of expression [e] in context
  22:     [ctx]. If [e] does not have a type it raises the [Type_error]
  23:     exception. *)
  24: and type_of ctx = function
  25:   | Error -> assert false (* this should not happen as the user has no way of referring to Error *)
  26:   | Var x ->
  27:       (try List.assoc x ctx with
  28:            Not_found -> type_error ("unknown variable " ^ x))
  29:   | Int _ -> TInt
  30:   | Bool _ -> TBool
  31:   | Times (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TInt
  32:   | Division (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TInt
  33:   | Plus (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TInt
  34:   | Minus (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TInt
  35:   | Equal (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TBool
  36:   | Less (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TBool
  37:   | If (e1, e2, e3) ->
  38:       check ctx TBool e1 ;
  39:       let ty = type_of ctx e2 in
  40:         check ctx ty e3 ; ty
  41:   | Fun (f, x, ty1, ty2, e) ->
  42:       check ((f, TArrow(ty1,ty2)) :: (x, ty1) :: ctx) ty2 e ;
  43:       TArrow (ty1, ty2)
  44:   | Apply (e1, e2) ->
  45:       (match type_of ctx e1 with
  46:            TArrow (ty1, ty2) -> check ctx ty1 e2 ; ty2
  47:          | ty ->
  48:              type_error (string_of_expr e1 ^
  49:                          " is used as a function but its type is "
  50:                          ^ string_of_type ty))

eval.ml

   1: (** Evaluation rules, small-step operational semantics.
   2: 
   3:    This module is for demonstration purposes only. It is inefficient
   4:    and not used by the toplevel, which compiles programs to "machine"
   5:    language, see modules Machine and Compile.
   6: *)
   7: 
   8: open Syntax
   9: 
  10: (** [is_value e] returns true, if program [e] is a value. *)
  11: let is_value = function
  12:   | Int _ | Bool _ | Fun _ | Error -> true
  13:   | Var _ | Times _ | Division _ | Plus _ | Minus _
  14:   | Equal _ | Less _ | If _ | Apply _ -> false
  15: 
  16: (** An exception indicating a value. *)
  17: exception Value
  18: 
  19: (** An exception indicating a runtime error. *)
  20: exception Runtime
  21: 
  22: (** [eval1 e] performs a single evaluation step. It raises exception
  23:     Value if [e] is a value. *)
  24: let rec eval1 = function
  25:   | Var _ -> raise Runtime
  26:   | Int _ | Bool _ | Fun _ -> raise Value
  27:   | Division (Int k1, Int k2) -> Int (k1 / k2)
  28:   | Division (Int k1, Error)  -> Error
  29:   | Division (Int k1, e2)  -> Division (Int k1, eval1 e2)
  30:   | Division (Error, e2)   -> Error
  31:   | Division (e1, e2)      -> Division (eval1 e1, e2)
  32:   | Times (Int k1, Int k2) -> Int (k1 * k2)
  33:   | Times (Int k1, Error)  -> Error
  34:   | Times (Int k1, e2)     -> Times (Int k1, eval1 e2)
  35:   | Times (Error, e2)      -> Error
  36:   | Times (e1, e2)         -> Times (eval1 e1, e2)
  37:   | Plus (Int k1, Int k2)  -> Int (k1 + k2)
  38:   | Plus (Int k1, Error)   -> Error
  39:   | Plus (Int k1, e2)      -> Plus (Int k1, eval1 e2)
  40:   | Plus (Error, e2)       -> Error
  41:   | Plus (e1, e2)          -> Plus (eval1 e1, e2)
  42:   | Minus (Int k1, Int k2) -> Int (k1 - k2)
  43:   | Minus (Int k1, Error)  -> Error
  44:   | Minus (Int k1, e2)     -> Minus (Int k1, eval1 e2)
  45:   | Minus (Error, e2)      -> Error
  46:   | Minus (e1, e2)         -> Minus (eval1 e1, e2)
  47:   | Equal (Int k1, Int k2) -> Bool (k1 = k2)
  48:   | Equal (Int k1, Error)  -> Error
  49:   | Equal (Int k1, e2)     -> Equal (Int k1, eval1 e2)
  50:   | Equal (Error, e2)      -> Error
  51:   | Equal (e1, e2)         -> Equal (eval1 e1, e2)
  52:   | Less (Int k1, Int k2)  -> Bool (k1 < k2)
  53:   | Less (Int k1, Error)   -> Error
  54:   | Less (Int k1, e2)      -> Less (Int k1, eval1 e2)
  55:   | Less (Error, e2)       -> Error
  56:   | Less (e1, e2)          -> Less (eval1 e1, e2)
  57:   | If (Bool true, e2, e3) -> e2
  58:   | If (Bool false, e2, e3)-> e3
  59:   | If (Error, e2, e3)     -> Error
  60:   | If (e1, e2, e3)        -> If (eval1 e1, e2, e3)
  61:   | Apply (Fun (f, x, _, _, e), Error) -> Error
  62:   | Apply (Fun (f, x, _, _, e) as v1, v2) when is_value v2 ->
  63:       subst [(f, v1); (x, v2)] e
  64:   | Apply (Fun _ as v1, e2) -> Apply (v1, eval1 e2)
  65:   | Apply (Error, e2) -> Error
  66:   | Apply (e1, e2) -> Apply (eval1 e1, e2)
  67:   | _ -> assert false
  68: 
  69: (** [eval e] evaluates program [e]. The evaluation returns a value,
  70:     diverges, or raises the [Runtime] exception. *)
  71: let rec eval e =
  72:   let rec loop e = if is_value e then e else loop (eval1 e)
  73:   in
  74:     loop e

machine.ml

   1: (** A simple abstract machine for executing programs compiled from
   2:     MiniML+error or a similar purely functional language. *)
   3: 
   4: 
   5: (** The abstract machine is built from frames environments and stacks.
   6: 
   7:     A frame is a list of machine instructions, usually representing
   8:     the body of a function or a branch of conditional statement.
   9: 
  10:     An environment is a mapping from variable names to machine values.
  11:     A machine value is an integer, a boolean value, or a closure. A
  12:     closure represents a compiled function and is a triple
  13:     [(x,frm,env)] where [x] is the name of the function argument,
  14:     [frm] is the frame representing the function body, and [env] is
  15:     the environment of variables that can be accessed by the function
  16:     body.
  17: 
  18:     The state of the machine is described by a triple [(f,s,e)] where
  19:     [f] is a stack of frames, [s] is a stack of machine values, and
  20:     [e] is a stack of environments. At each step the machine executes
  21:     the first instruction of the first frame from [f].
  22: 
  23:     For a special treatment of errors we have the special error state.
  24:     If the machine reaches this state, it immediately stops executing
  25:     the program.
  26: *)
  27: 
  28: 
  29: (** The datatype of variable names. A more efficient implementation
  30:     would use de Bruijn indices but we want to keep things simple. *)
  31: type name = Syntax.name
  32: 
  33: (** Machine values. *)
  34: type mvalue =
  35:   | MInt of int                        (** Integer *)
  36:   | MBool of bool                      (** Boolean value *)
  37:   | MClosure of name * frame * environ (** Closure *)
  38:   | MError                             (** Error state *)
  39: 
  40: (**
  41:    There are three kinds of machine instructions.
  42: 
  43:    The first kind manipules tha stack of machine values. These are
  44:    arithmetical operations, integer comparison, variable lookup,
  45:    placing constants onto the stack, and closure formation.
  46: 
  47:    The second kind are the control instructions. These are branching
  48:    instruction, execution of a closure, and popping of an environment.
  49: 
  50:    The third kind is the instruction which causes the error state.
  51: *)
  52: 
  53: and instr =
  54:   | IErr                            (** error state *)
  55:   | IMult                           (** multiplication *)
  56:   | IDiv                            (** division (may cause error state) *)
  57:   | IAdd                            (** addition *)
  58:   | ISub                            (** subtraction *)
  59:   | IEqual                          (** equality *)
  60:   | ILess                           (** less than *)
  61:   | IVar of name                      (** push value of variable *)
  62:   | IInt of int                       (** push integer constant *)
  63:   | IBool of bool                     (** push boolean constant *)
  64:   | IClosure of name * name * frame (** push closure *)
  65:   | IBranch of frame * frame        (** branch *)
  66:   | ICall                           (** execute a closure *)
  67:   | IPopEnv                         (** pop environment *)
  68: 
  69: (** A frame is a list (stack) of instructions *)
  70: and frame = instr list
  71: 
  72: (** An environment is an association list mapping names to values *)
  73: and environ = (name * mvalue) list
  74: 
  75: (** A stack of machine values *)
  76: and stack = mvalue list
  77: 
  78: (** Exception indicating a runtime error *)
  79: exception Machine_error of string
  80: 
  81: (** Report a runtime error *)
  82: let error msg = raise (Machine_error msg)
  83: 
  84: (** Convert a machine value to string *)
  85: let string_of_mvalue = function
  86:   | MInt k -> string_of_int k
  87:   | MBool b -> string_of_bool b
  88:   | MClosure _ -> "<fun>" (** Closures cannot be reasonably displayed *)
  89:   | MError -> "error"
  90: 
  91: (** [lookup x envs] scans through the list of environments [envs] and
  92:     returns the first value of variable [x] found. *)
  93: let lookup x = function
  94:     env::_ -> (try List.assoc x env with Not_found -> error ("unknown " ^ x))
  95:   | _ -> error ("unknown" ^ x)
  96: 
  97: (** Decompose a stack into top and rest. *)
  98: let pop = function
  99:     [] -> error "empty stack"
 100:   | v::s -> (v, s)
 101: 
 102: (** Pop a boolean value from a stack. *)
 103: let pop_bool = function
 104:     MBool b :: s -> (b, s)
 105:   | _ -> error "bool expected"
 106: 
 107: (** Pop a value and a closure from a stack. *)
 108: let pop_app = function
 109:     v :: MClosure (x, f, e) :: s -> (x, f, e, v, s)
 110:   | _ -> error "value and closure expected"
 111: 
 112: 
 113: (** Arithmetical operations take their arguments from a stack and put the
 114:     result onto the stack. We use auxiliary functions that do this. *)
 115: 
 116: (** Multiplication *)
 117: let mult = function
 118:     (MInt x) :: (MInt y) :: s -> MInt (y * x) :: s
 119:   | _ -> error "int and int expected in mult"
 120: 
 121: (** Division *)
 122: let quot = function
 123:   | (MInt 0) :: (MInt y) :: s -> MError :: s
 124:   | (MInt x) :: (MInt y) :: s -> MInt (y / x) :: s
 125:   | _ -> error "int and int expected in mult"
 126: 
 127: (** Addition *)
 128: let add = function
 129:     (MInt x) :: (MInt y) :: s -> MInt (y + x) :: s
 130:   | _ -> error "int and int expected in add"
 131: 
 132: (** Subtraction *)
 133: let sub = function
 134:     (MInt x) :: (MInt y) :: s -> MInt (y - x) :: s
 135:   | _ -> error "int and int expected in sub"
 136: 
 137: (** Equality *)
 138: let equal = function
 139:     (MInt x) :: (MInt y) :: s -> MBool (y = x) :: s
 140:   | _ -> error "int and int expected in equal"
 141: 
 142: (** Less than *)
 143: let less = function
 144:     (MInt x) :: (MInt y) :: s -> MBool (y < x) :: s
 145:   | _ -> error "int and int expected in less"
 146: 
 147: (** [exec instr frms stck envs] executes instruction [instr] in the
 148:     given state [(frms, stck, envs)], where [frms] is a stack of frames,
 149:     [stck] is a stack of machine values, and [envs] is a stack of
 150:     environments. The return value is a new state and a flag indicating
 151:     whether we reached an error state.
 152:  *)
 153: let exec instr frms stck envs =
 154:   match instr with
 155:     | IErr -> ([], [MError], [])
 156:     (* Arithmetic *)
 157:     | IMult  -> (frms, mult stck, envs)
 158:     | IDiv   -> (frms, quot stck, envs)
 159:     | IAdd   -> (frms, add stck, envs)
 160:     | ISub   -> (frms, sub stck, envs)
 161:     | IEqual -> (frms, equal stck, envs)
 162:     | ILess  -> (frms, less stck, envs)
 163:     (* Pushing values onto stack *)
 164:     | IVar x  -> (frms, (lookup x envs) :: stck, envs)
 165:     | IInt k  -> (frms, (MInt k) :: stck, envs)
 166:     | IBool b -> (frms, (MBool b) :: stck, envs)
 167:     | IClosure (f, x, frm) ->
 168:         (match envs with
 169:              env :: _ ->
 170:                let rec c = MClosure (x, frm, (f,c) :: env) in
 171:                  (frms, c :: stck, envs)
 172:            | [] -> error "no environment for a closure")
 173:     (* Control instructions *)
 174:     | IBranch (f1, f2) ->
 175:         let (b, stck') = pop_bool stck in
 176:           ((if b then f1 else f2) :: frms, stck', envs)
 177:     | ICall ->
 178:         let (x, frm, env, v, stck') = pop_app stck in
 179:           (frm :: frms, stck', ((x,v) :: env) :: envs)
 180:     | IPopEnv ->
 181:         (match envs with
 182:              [] -> error "no environment to pop"
 183:            | _ :: envs' -> (frms, stck, envs'))
 184: 
 185: (** [run frm env] executes the frame [frm] in environment [env]. *)
 186: let run frm env =
 187:   let rec loop = function
 188:     | (_, MError::_, _) -> MError
 189:     | ([], [v], _) -> v
 190:     | ((i::is) :: frms, stck, envs) -> loop (exec i (is::frms) stck envs)
 191:     | ([] :: frms, stck, envs) -> loop (frms, stck, envs)
 192:     | _ -> error "illegal end of program"
 193:   in
 194:     loop ([frm], [], [env])

compile.ml

   1: (** MiniML+error compiler. *)
   2: 
   3: open Syntax
   4: open Machine
   5: 
   6: (** [compile e] compiles program [e] into a list of machine instructions. *)
   7: let rec compile = function
   8:   | Var x -> [IVar x]
   9:   | Int k -> [IInt k]
  10:   | Error -> [IErr]
  11:   | Bool b -> [IBool b]
  12:   | Times (e1, e2) -> (compile e1) @ (compile e2) @ [IMult]
  13:   | Division (e1, e2) -> (compile e1) @ (compile e2) @ [IDiv]
  14:   | Plus (e1, e2) -> (compile e1) @ (compile e2) @ [IAdd]
  15:   | Minus (e1, e2) -> (compile e1) @ (compile e2) @ [ISub]
  16:   | Equal (e1, e2) -> (compile e1) @ (compile e2) @ [IEqual]
  17:   | Less (e1, e2) -> (compile e1) @ (compile e2) @ [ILess]
  18:   | If (e1, e2, e3) -> (compile e1) @ [IBranch (compile e2, compile e3)]
  19:   | Fun (f, x, _, _, e) -> [IClosure (f, x, compile e @ [IPopEnv])]
  20:   | Apply (e1, e2) -> (compile e1) @ (compile e2) @ [ICall]

lexer.mll

   1: {
   2:   open Parser
   3: }
   4: 
   5: let var = ['a'-'z' 'A'-'Z']+
   6: 
   7: rule token = parse
   8:     [' ' '\t' '\r' '\n'] { token lexbuf }
   9:   | ['0'-'9']+           { INT (int_of_string(Lexing.lexeme lexbuf)) }
  10:   | "int"                { TINT }
  11:   | "bool"               { TBOOL }
  12:   | "true"               { TRUE }
  13:   | "false"               { FALSE }
  14:   | "fun"           { FUN }
  15:   | "is"            { IS }
  16:   | "if"            { IF }
  17:   | "then"          { THEN }
  18:   | "else"          { ELSE }
  19:   | "let"           { LET }  
  20:   | ";;"            { SEMICOLON2 }
  21:   | '='             { EQUAL }
  22:   | '<'             { LESS }
  23:   | "->"            { TARROW }
  24:   | ':'             { COLON }
  25:   | '('             { LPAREN }
  26:   | ')'             { RPAREN }
  27:   | '+'             { PLUS }
  28:   | '-'             { MINUS }
  29:   | '*'             { TIMES }
  30:   | '/'             { DIVIDE }
  31:   | var             { VAR (Lexing.lexeme lexbuf) }
  32:   | eof             { EOF }
  33: 
  34: {
  35: }

parser.mly

   1: %{
   2:   open Syntax
   3: %}
   4: 
   5: %token TINT
   6: %token TBOOL
   7: %token TARROW
   8: %token <Syntax.name> VAR
   9: %token <int> INT
  10: %token TRUE FALSE
  11: %token PLUS
  12: %token MINUS
  13: %token TIMES
  14: %token DIVIDE
  15: %token EQUAL LESS
  16: %token IF THEN ELSE
  17: %token FUN IS
  18: %token COLON
  19: %token LPAREN RPAREN
  20: %token LET
  21: %token SEMICOLON2
  22: %token EOF
  23: 
  24: %start toplevel
  25: %type <Syntax.toplevel_cmd list> toplevel
  26: 
  27: %nonassoc FUN IS
  28: %nonassoc IF THEN ELSE
  29: %nonassoc EQUAL LESS
  30: %left PLUS MINUS
  31: %left TIMES DIVIDE
  32: %left COLON
  33: %right TARROW
  34: 
  35: %%
  36: 
  37: toplevel:
  38:     EOF                      { [] }
  39:   | def EOF                  { [$1] }
  40:   | def SEMICOLON2 EOF       { [$1] }
  41:   | expr EOF                 { [Expr $1] }
  42:   | expr SEMICOLON2 EOF      { [Expr $1] }
  43:   | def SEMICOLON2 toplevel  { $1 :: $3 }
  44:   | expr SEMICOLON2 toplevel { (Expr $1) :: $3 }
  45: 
  46: def: LET VAR EQUAL expr { Def ($2, $4) }
  47: 
  48: expr:
  49:     non_app             { $1 }
  50:   | app                 { $1 }
  51:   | arith               { $1 }
  52:   | boolean             { $1 }
  53:   | IF expr THEN expr ELSE expr        { If ($2, $4, $6) }
  54:   | FUN VAR LPAREN VAR COLON ty RPAREN COLON ty IS expr { Fun ($2, $4, $6, $9, $11) }
  55: 
  56: app:
  57:     app non_app         { Apply ($1, $2) }
  58:   | non_app non_app     { Apply ($1, $2) }
  59: 
  60: non_app:
  61:     VAR                                  { Var $1 }
  62:   | TRUE                          { Bool true }
  63:   | FALSE                         { Bool false }
  64:   | INT                                  { Int $1 }
  65:   | LPAREN expr RPAREN                  { $2 }    
  66: 
  67: arith:
  68:   | MINUS INT           { Int (-$2) }
  69:   | expr PLUS expr        { Plus ($1, $3) }
  70:   | expr MINUS expr        { Minus ($1, $3) }
  71:   | expr TIMES expr        { Times ($1, $3) }
  72:   | expr DIVIDE expr        { Division ($1, $3) }
  73: 
  74: boolean:
  75:   | expr EQUAL expr { Equal ($1, $3) }
  76:   | expr LESS expr  { Less ($1, $3) }
  77: 
  78: ty:
  79:     TBOOL         { TBool }
  80:   | TINT         { TInt }
  81:   | ty TARROW ty { TArrow ($1, $3) }
  82:   | LPAREN ty RPAREN { $2 }
  83: 
  84: %%
  85: 

minimlerror.ml

   1: (** Toplevel interactive loop. *)
   2: 
   3: (** The toplevel accepts global value definitions and expressions,
   4:     separated by double semicolon [;;] when contained in a file.
   5: 
   6:     A global value definition [let x = e] defines a value [x].
   7: *)
   8: 
   9: (** Usage:
  10: 
  11:     [minimlerror] runs the interactive loop.
  12: 
  13:     [minimlerror dat1 ... datN] evaluates the contents of files
  14:     [dat1],...,[datN] then runs the interactive loop.
  15: 
  16:     [minimlerror -n dat1 ..., datN] evaluates the contents of files
  17:     [dat1],...,[datN] and exits.
  18: *)
  19: 
  20: open Syntax
  21: 
  22: (** A context describing the types of globally defined values. *)
  23: type context = (name * ty) list
  24: 
  25: (** An environment describing globally defined values. *)
  26: type env = (name * Machine.mvalue) list
  27: 
  28:     
  29: (** [exec_cmd (ctx, env) cmd] executes the toplevel command [cmd] and
  30:     returns the new context-environment pair and a string representing the
  31:     result of evaluation. *)
  32: let exec_cmd (ctx, env) = function
  33:     Expr e ->
  34:       (* check the type of [e], compile it, and run it. *)
  35:       let ty = Type_check.type_of ctx e in
  36:       let frm = Compile.compile e in
  37:       let v = Machine.run frm env in
  38:         ((ctx, env),
  39:          "- : " ^ (Syntax.string_of_type ty) ^ " = " ^ (Machine.string_of_mvalue v))
  40:   | Def (x, e) ->
  41:       (* check the type of [e], compile it, run it, and return a new
  42:          context-environemtn pair with [x] defined as [e]. *)
  43:       let ty = Type_check.type_of ctx e in
  44:       let frm = Compile.compile e in
  45:       let v = Machine.run frm env in
  46:         (((x,ty)::ctx, (x,v)::env),
  47:          x ^ " : " ^ (Syntax.string_of_type ty) ^ " = " ^
  48:            (Machine.string_of_mvalue v))
  49: ;;
  50: 
  51: let _ = Eval.eval
  52: 
  53: (** [exec_cmds (ctx, env) cmds] executes a list of commands in the inital
  54:     context [ctx] and environment [env] and returns the new context and
  55:     environment. *)
  56: let exec_cmds ce cmds =
  57:   List.fold_left
  58:     (fun ce cmd -> let (ce', msg) = exec_cmd ce cmd in print_endline msg ; ce')
  59:     ce cmds
  60: ;;
  61: 
  62: (** [shell ctx env] is the interactive shell. Here [ctx] and [env] are
  63:     the context and environment of global definitions. *)
  64: let shell ctx env =
  65:   print_string ("MiniML+error. Press ") ;
  66:   print_string (match Sys.os_type with
  67:                     "Unix" | "Cygwin" -> "Ctrl-D"
  68:                   | "Win32" -> "Ctrl-Z"
  69:                   | _ -> "EOF") ;
  70:   print_endline " to exit." ;
  71:   let global_ctx = ref ctx in
  72:   let global_env = ref env in
  73:     try
  74:       while true do
  75:           try
  76:             (* read a line, parse it and exectute it *)
  77:             print_string "MiniML+error> ";
  78:             let str = read_line () in
  79:             let cmds = Parser.toplevel Lexer.token (Lexing.from_string str) in
  80:             let (ctx, env) = exec_cmds (!global_ctx, !global_env) cmds in
  81:               (* set the new values of the global context and environment *)
  82:               global_ctx := ctx ;
  83:               global_env := env
  84:           with
  85:             | Type_check.Type_error msg -> print_endline ("Type error: " ^ msg)
  86:             | Machine.Machine_error msg -> print_endline ("Runtime error: " ^ msg)
  87:             | Failure _ | Parsing.Parse_error -> print_endline "Syntax error."
  88:       done 
  89:     with
  90:         End_of_file -> print_endline "\nGood bye."
  91: 
  92: (** The main program. *)
  93: let main =
  94:   let noninteractive = ref false in
  95:   let files = ref [] in
  96:     Arg.parse
  97:       [("-n", Arg.Set noninteractive, "do not run the interactive shell")]
  98:       (fun f -> files := f :: !files)
  99:       "Usage: minimlerror [-n] [file] ..." ;
 100:     try
 101:       let ctx, env =
 102:         List.fold_left
 103:           (fun ce f ->
 104:              let fh = open_in f in
 105:              let cmds = Parser.toplevel Lexer.token (Lexing.from_channel fh) in
 106:                close_in fh ;
 107:                exec_cmds ce cmds)
 108:           ([],[]) !files
 109:       in    
 110:         if not !noninteractive then shell ctx env
 111:     with
 112:       | Type_check.Type_error msg -> print_endline ("Type error: " ^ msg)
 113:       | Machine.Machine_error msg -> print_endline ("Runtime error: " ^ msg)
 114:       | Failure _ | Parsing.Parse_error -> print_endline "Syntax error."
 115: