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:   | Equal of expr * expr                 (* Integer comparison [e1 = e2] *)
  21:   | Less of expr * expr                  (* Integer comparison [e1 < e2] *)
  22:   | If of expr * expr * expr                 (* Conditional [if e1 then e2 else e3] *)
  23:   | Fun of name * name * ty * ty * expr (* Function [fun f(x:s):t is e] *)
  24:   | Apply of expr * expr                 (* Application [e1 e2] *)
  25: 
  26: (* Toplevel commands *)
  27: type toplevel_cmd =
  28:   | Expr of expr       (* Expression *)
  29:   | Def of name * expr (* Value definition [let x = e] *)
  30: 
  31: (* Convert a type to string *)
  32: let string_of_type ty =
  33:   let rec to_str n ty =
  34:     let (m, str) =
  35:       match ty with
  36:         | TInt -> (2, "int")
  37:         | TBool -> (2, "bool")
  38:         | TArrow (ty1, ty2) -> (1, (to_str 1 ty1) ^ " -> " ^ (to_str 0 ty2))
  39:     in
  40:       if m > n then str else "(" ^ str ^ ")"
  41:   in
  42:     to_str (-1) ty
  43: 
  44: (* Convert an expression to string *)
  45: let string_of_expr e =
  46:   let rec to_str n e =
  47:     let (m, str) =
  48:       match e with
  49:         | Int n -> (7, string_of_int n)
  50:         | Bool b -> (7, string_of_bool b)
  51:         | Var x -> (7, x)
  52:         | Apply (e1, e2) -> (6, (to_str 5 e1) ^ " " ^ (to_str 6 e2))
  53:         | Times (e1, e2) -> (5, (to_str 4 e1) ^ " * " ^ (to_str 5 e2))
  54:         | Plus (e1, e2) -> (4, (to_str 3 e1) ^ " + " ^ (to_str 4 e2))
  55:         | Minus (e1, e2) -> (4, (to_str 3 e1) ^ " - " ^ (to_str 4 e2))
  56:         | Equal (e1, e2) -> (3, (to_str 3 e1) ^ " = " ^ (to_str 3 e2))
  57:         | Less (e1, e2) -> (3, (to_str 3 e1) ^ " < " ^ (to_str 3 e2))
  58:         | If (e1, e2, e3) -> (2, "if " ^ (to_str 2 e1) ^ " then " ^
  59:                                 (to_str 2 e2) ^ " else " ^ (to_str 2 e3))
  60:         | Fun (f, x, ty1, ty2, e) ->
  61:             (1, "fun " ^ f ^ "(" ^ x ^ " : " ^ (string_of_type ty1) ^ 
  62:                ") : " ^ (string_of_type ty2) ^ " is " ^ (to_str 0 e))
  63:     in
  64:       if m > n then str else "(" ^ str ^ ")"
  65:   in
  66:     to_str (-1) e
  67: 
  68: (* [subst [(x1,e1);...;(xn;en)] e] replaces in expression [e] all
  69:     free occurrences of variables [x1], ..., [xn] with expressions
  70:     [e1], ..., [en], respectively. *)
  71: let rec subst s = function
  72:   | (Var x) as e -> (try List.assoc x s with Not_found -> e)
  73:   | (Int _ | Bool _) as e -> e
  74:   | Times (e1, e2) -> Times (subst s e1, subst s e2)
  75:   | Plus (e1, e2) -> Plus (subst s e1, subst s e2)
  76:   | Minus (e1, e2) -> Minus (subst s e1, subst s e2)
  77:   | Equal (e1, e2) -> Equal (subst s e1, subst s e2)
  78:   | Less (e1, e2) -> Less (subst s e1, subst s e2)
  79:   | If (e1, e2, e3) -> If (subst s e1, subst s e2, subst s e3)
  80:   | Fun (f, x, ty1, ty2, e) ->
  81:       let s' = List.remove_assoc f (List.remove_assoc x s) in
  82:         Fun (f, x, ty1, ty2, subst s' e)
  83:   | 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:     Var x ->
  26:       (try List.assoc x ctx with
  27:            Not_found -> type_error ("unknown variable " ^ x))
  28:   | Int _ -> TInt
  29:   | Bool _ -> TBool
  30:   | Times (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TInt
  31:   | Plus (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TInt
  32:   | Minus (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TInt
  33:   | Equal (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TBool
  34:   | Less (e1, e2) -> check ctx TInt e1 ; check ctx TInt e2 ; TBool
  35:   | If (e1, e2, e3) ->
  36:       check ctx TBool e1 ;
  37:       let ty = type_of ctx e2 in
  38:         check ctx ty e3 ; ty
  39:   | Fun (f, x, ty1, ty2, e) ->
  40:       check ((f, TArrow(ty1,ty2)) :: (x, ty1) :: ctx) ty2 e ;
  41:       TArrow (ty1, ty2)
  42:   | Apply (e1, e2) ->
  43:       (match type_of ctx e1 with
  44:            TArrow (ty1, ty2) -> check ctx ty1 e2 ; ty2
  45:          | ty ->
  46:              type_error (string_of_expr e1 ^
  47:                          " is used as a function but its type is "
  48:                          ^ 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 _ -> true
  13:   | Var _ | Times _ | 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:   | Times (Int k1, Int k2) -> Int (k1 * k2)
  28:   | Times (Int k1, e2)     -> Times (Int k1, eval1 e2)
  29:   | Times (e1, e2)         -> Times (eval1 e1, e2)
  30:   | Plus (Int k1, Int k2)  -> Int (k1 + k2)
  31:   | Plus (Int k1, e2)      -> Plus (Int k1, eval1 e2)
  32:   | Plus (e1, e2)          -> Plus (eval1 e1, e2)
  33:   | Minus (Int k1, Int k2) -> Int (k1 - k2)
  34:   | Minus (Int k1, e2)     -> Minus (Int k1, eval1 e2)
  35:   | Minus (e1, e2)         -> Minus (eval1 e1, e2)
  36:   | Equal (Int k1, Int k2) -> Bool (k1 = k2)
  37:   | Equal (Int k1, e2)     -> Equal (Int k1, eval1 e2)
  38:   | Equal (e1, e2)         -> Equal (eval1 e1, e2)
  39:   | Less (Int k1, Int k2)  -> Bool (k1 < k2)
  40:   | Less (Int k1, e2)      -> Less (Int k1, eval1 e2)
  41:   | Less (e1, e2)          -> Less (eval1 e1, e2)
  42:   | If (Bool true, e2, e3) -> e2
  43:   | If (Bool false, e2, e3)-> e3
  44:   | If (e1, e2, e3)        -> If (eval1 e1, e2, e3)
  45:   | Apply (Fun (f, x, _, _, e) as v1, v2) when is_value v2 ->
  46:       subst [(f, v1); (x, v2)] e
  47:   | Apply (Fun _ as v1, e2) -> Apply (v1, eval1 e2)
  48:   | Apply (e1, e2) -> Apply (eval1 e1, e2)
  49: 
  50: (** [eval e] evaluates program [e]. The evaluation returns a value,
  51:     diverges, or raises the [Runtime] exception. *)
  52: let rec eval e =
  53:   let rec loop e = if is_value e then e else loop (eval1 e)
  54:   in
  55:     loop e

machine.ml

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

compile.ml

   1: (** MiniML 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:   | Bool b -> [IBool b]
  11:   | Times (e1, e2) -> (compile e1) @ (compile e2) @ [IMult]
  12:   | Plus (e1, e2) -> (compile e1) @ (compile e2) @ [IAdd]
  13:   | Minus (e1, e2) -> (compile e1) @ (compile e2) @ [ISub]
  14:   | Equal (e1, e2) -> (compile e1) @ (compile e2) @ [IEqual]
  15:   | Less (e1, e2) -> (compile e1) @ (compile e2) @ [ILess]
  16:   | If (e1, e2, e3) -> (compile e1) @ [IBranch (compile e2, compile e3)]
  17:   | Fun (f, x, _, _, e) -> [IClosure (f, x, compile e @ [IPopEnv])]
  18:   | 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:   | var             { VAR (Lexing.lexeme lexbuf) }
  31:   | eof             { EOF }
  32: 
  33: {
  34: }

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

miniml.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:     [miniml] runs the interactive loop.
  12: 
  13:     [miniml dat1 ... datN] evaluates the contents of files
  14:     [dat1],...,[datN] then runs the interactive loop.
  15: 
  16:     [miniml -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:     Syntax.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) ^