stuff
This commit is contained in:
NikolajDanger
376
W1/fasto/Fasto/Interpreter.fs
Normal file
376
W1/fasto/Fasto/Interpreter.fs
Normal file
@ -0,0 +1,376 @@
|
||||
(* An interpreter for Fasto. *)
|
||||
|
||||
module Interpreter
|
||||
|
||||
(*
|
||||
|
||||
An interpreter executes a (Fasto) program by inspecting the abstract syntax
|
||||
tree of the program, and doing what needs to be done in another programming
|
||||
language (F#).
|
||||
|
||||
As mentioned in AbSyn.fs, some Fasto expressions are implicitly typed. The
|
||||
interpreter infers the missing types, and checks the types of the operands
|
||||
before performing any Fasto operation. Some type errors might still occur though.
|
||||
|
||||
Any valid Fasto program must contain a "main" function, which is the entry
|
||||
point of the program. The return value of this function is the result of the
|
||||
Fasto program.
|
||||
|
||||
The main function of interest in this module is:
|
||||
|
||||
val evalProg : AbSyn.UntypedProg -> AbSyn.Value
|
||||
|
||||
*)
|
||||
|
||||
open System
|
||||
open AbSyn
|
||||
|
||||
(* An exception for reporting run-time errors. *)
|
||||
exception MyError of string * Position
|
||||
|
||||
type FunTable = SymTab.SymTab<UntypedFunDec>
|
||||
type VarTable = SymTab.SymTab<Value>
|
||||
|
||||
(* Build a function table, which associates a function names with function
|
||||
declarations. *)
|
||||
let rec buildFtab (fdecs : UntypedFunDec list) : FunTable =
|
||||
match fdecs with
|
||||
| [] -> let p = (0, 0)
|
||||
let ch = 'a'
|
||||
let fdec_chr = FunDec ("chr", Char, [Param ("n", Int) ], Constant (CharVal ch, p), p)
|
||||
let fdec_ord = FunDec ("ord", Int, [Param ("c", Char)], Constant (IntVal 1, p), p)
|
||||
SymTab.fromList [("chr", fdec_chr); ("ord", fdec_ord)]
|
||||
| ( fdcl::fs ) ->
|
||||
(* Bind the user-defined functions, in reverse order. *)
|
||||
let fid = getFunName fdcl
|
||||
let pos = getFunPos fdcl
|
||||
let ftab = buildFtab fs
|
||||
match SymTab.lookup fid ftab with
|
||||
| None -> SymTab.bind fid fdcl ftab
|
||||
| Some ofdecl ->
|
||||
(* Report the first occurrence of the name. *)
|
||||
raise (MyError ("Already defined function: "+fid, getFunPos ofdecl))
|
||||
|
||||
(* Check whether a value matches a type. *)
|
||||
let rec typeMatch (tpval : Type * Value) : bool =
|
||||
match tpval with
|
||||
| ( Int, IntVal _ ) -> true
|
||||
| ( Bool, BoolVal _) -> true
|
||||
| ( Char, CharVal _) -> true
|
||||
| ( Array t, ArrayVal (vals, tp) ) ->
|
||||
(t = tp) && (List.map (fun value -> typeMatch (t, value)) vals |> List.fold (&&) true)
|
||||
| (_, _) -> false
|
||||
|
||||
let reportBadType (str : string)
|
||||
(want : string)
|
||||
(v : Value)
|
||||
(pos : Position) =
|
||||
let msg = "Bad type for " + str + ": expected " + want + ", but got " +
|
||||
ppType (valueType v) + " (" + (ppVal 0 v) + ")"
|
||||
raise (MyError(msg, pos))
|
||||
|
||||
let reportWrongType str tp v pos = reportBadType str (ppType tp) v pos
|
||||
|
||||
let reportNonArray str v pos = reportBadType str "an array" v pos
|
||||
|
||||
(* Bind the formal parameters of a function declaration to actual parameters in
|
||||
a new vtab. *)
|
||||
|
||||
let rec bindParams (fargs : Param list)
|
||||
(aargs : Value list)
|
||||
(fid : String)
|
||||
(pdec : Position)
|
||||
(pcall : Position) : VarTable =
|
||||
match (fargs, aargs) with
|
||||
| ([], []) -> SymTab.empty ()
|
||||
| (Param (faid, fatp) :: fargs, v :: aargs) ->
|
||||
let vtab = bindParams fargs aargs fid pdec pcall
|
||||
if typeMatch(fatp, v)
|
||||
then match SymTab.lookup faid vtab with
|
||||
None -> SymTab.bind faid v vtab
|
||||
| Some m -> raise (MyError( "Formal argument is already in symbol table!"+
|
||||
" In function: "+fid+" formal argument: "+faid
|
||||
, pdec ))
|
||||
else reportWrongType ("argument " + faid + " of function " + fid)
|
||||
fatp v pcall
|
||||
| (_, _) -> raise (MyError("Number of formal and actual params do not match in call to "+fid,
|
||||
pcall))
|
||||
|
||||
|
||||
(* Interpreter for Fasto expressions:
|
||||
1. vtab holds bindings between variable names and
|
||||
their interpreted value (Fasto.Value).
|
||||
2. ftab holds bindings between function names and
|
||||
function declarations (Fasto.FunDec).
|
||||
3. Returns the interpreted value. *)
|
||||
let rec evalExp (e : UntypedExp, vtab : VarTable, ftab : FunTable) : Value =
|
||||
match e with
|
||||
| Constant (v,_) -> v
|
||||
| ArrayLit (l, t, pos) ->
|
||||
let els = (List.map (fun x -> evalExp(x, vtab, ftab)) l)
|
||||
let elt = match els with
|
||||
| [] -> Int (* Arbitrary *)
|
||||
| v::_ -> valueType v
|
||||
ArrayVal (els, elt)
|
||||
| StringLit(s, pos) ->
|
||||
let cvs = List.map (fun c -> CharVal c) (Seq.toList s)
|
||||
ArrayVal (cvs, Char)
|
||||
| Var(id, pos) ->
|
||||
let res = SymTab.lookup id vtab
|
||||
match res with
|
||||
| None -> raise (MyError("Unknown variable "+id, pos))
|
||||
| Some m -> m
|
||||
| Plus(e1, e2, pos) ->
|
||||
let res1 = evalExp(e1, vtab, ftab)
|
||||
let res2 = evalExp(e2, vtab, ftab)
|
||||
match (res1, res2) with
|
||||
| (IntVal n1, IntVal n2) -> IntVal (n1+n2)
|
||||
| (IntVal _, _) -> reportWrongType "right operand of +" Int res2 (expPos e2)
|
||||
| (_, _) -> reportWrongType "left operand of +" Int res1 (expPos e1)
|
||||
| Minus(e1, e2, pos) ->
|
||||
let res1 = evalExp(e1, vtab, ftab)
|
||||
let res2 = evalExp(e2, vtab, ftab)
|
||||
match (res1, res2) with
|
||||
| (IntVal n1, IntVal n2) -> IntVal (n1-n2)
|
||||
| (IntVal _, _) -> reportWrongType "right operand of -" Int res2 (expPos e2)
|
||||
| (_, _) -> reportWrongType "left operand of -" Int res1 (expPos e1)
|
||||
(* TODO: project task 1:
|
||||
Look in `AbSyn.fs` for the arguments of the `Times`
|
||||
(`Divide`,...) expression constructors.
|
||||
Implementation similar to the cases of Plus/Minus.
|
||||
Try to pattern match the code above.
|
||||
For `Divide`, remember to check for attempts to divide by zero.
|
||||
For `And`/`Or`: make sure to implement the short-circuit semantics,
|
||||
e.g., `And (e1, e2, pos)` should not evaluate `e2` if `e1` already
|
||||
evaluates to false.
|
||||
*)
|
||||
| Times(_, _, _) ->
|
||||
failwith "Unimplemented interpretation of multiplication"
|
||||
| Divide(_, _, _) ->
|
||||
failwith "Unimplemented interpretation of division"
|
||||
| And (_, _, _) ->
|
||||
failwith "Unimplemented interpretation of &&"
|
||||
| Or (_, _, _) ->
|
||||
failwith "Unimplemented interpretation of ||"
|
||||
| Not(_, _) ->
|
||||
failwith "Unimplemented interpretation of not"
|
||||
| Negate(_, _) ->
|
||||
failwith "Unimplemented interpretation of negate"
|
||||
| Equal(e1, e2, pos) ->
|
||||
let r1 = evalExp(e1, vtab, ftab)
|
||||
let r2 = evalExp(e2, vtab, ftab)
|
||||
match (r1, r2) with
|
||||
| (IntVal n1, IntVal n2) -> BoolVal (n1 = n2)
|
||||
| (BoolVal b1, BoolVal b2) -> BoolVal (b1 = b2)
|
||||
| (CharVal c1, CharVal c2) -> BoolVal (c1 = c2)
|
||||
| (ArrayVal _, _) -> reportBadType "left operand of =" "a base type" r1 pos
|
||||
| (_, _) -> reportWrongType "right operand of =" (valueType r1) r2 pos
|
||||
| Less(e1, e2, pos) ->
|
||||
let r1 = evalExp(e1, vtab, ftab)
|
||||
let r2 = evalExp(e2, vtab, ftab)
|
||||
match (r1, r2) with
|
||||
| (IntVal n1, IntVal n2 ) -> BoolVal (n1 < n2)
|
||||
| (BoolVal false, BoolVal true) -> BoolVal true
|
||||
| (BoolVal _, BoolVal _ ) -> BoolVal false
|
||||
| (CharVal c1, CharVal c2 ) -> BoolVal ( (int c1) < (int c2) )
|
||||
| (ArrayVal _, _) -> reportBadType "left operand of <" "a base type" r1 pos
|
||||
| (_, _) -> reportWrongType "right operand of <" (valueType r1) r2 pos
|
||||
| If(e1, e2, e3, pos) ->
|
||||
let cond = evalExp(e1, vtab, ftab)
|
||||
match cond with
|
||||
| BoolVal true -> evalExp(e2, vtab, ftab)
|
||||
| BoolVal false -> evalExp(e3, vtab, ftab)
|
||||
| other -> reportWrongType "if condition" Bool cond (expPos e1)
|
||||
//raise (MyError("If condition is not a boolean", pos))
|
||||
(* The case of length receives special treatment below *)
|
||||
| Apply("length", [arg], pos) ->
|
||||
let evarg = evalExp(arg, vtab, ftab)
|
||||
match evarg with
|
||||
| ArrayVal (lst, _) -> IntVal (List.length lst)
|
||||
| otherwise -> reportNonArray "argument of length" evarg pos
|
||||
| Apply("length", args, pos) ->
|
||||
let msg = sprintf "Call to length function expects exactly one arg, given: %i" (List.length args)
|
||||
raise (MyError(msg, pos))
|
||||
(* general case of function application *)
|
||||
| Apply(fid, args, pos) ->
|
||||
let evargs = List.map (fun e -> evalExp(e, vtab, ftab)) args
|
||||
match (SymTab.lookup fid ftab) with
|
||||
| Some f -> callFunWithVtable(f, evargs, SymTab.empty(), ftab, pos)
|
||||
| None -> raise (MyError("Call to unknown function "+fid, pos))
|
||||
| Let(Dec(id,e,p), exp, pos) ->
|
||||
let res = evalExp(e, vtab, ftab)
|
||||
let nvtab = SymTab.bind id res vtab
|
||||
evalExp(exp, nvtab, ftab)
|
||||
| Index(id, e, tp, pos) ->
|
||||
let indv = evalExp(e, vtab, ftab)
|
||||
let arr = SymTab.lookup id vtab
|
||||
match (arr, indv) with
|
||||
| (None, _) -> raise (MyError("Unknown array variable "+id, pos))
|
||||
| (Some (ArrayVal(lst, tp)), IntVal ind) ->
|
||||
let len = List.length(lst)
|
||||
if( len > ind && ind >= 0 )
|
||||
then lst.Item(ind)
|
||||
else let msg = sprintf "Array index out of bounds! Array length: %i, index: %i" len ind
|
||||
raise (MyError( msg, pos ))
|
||||
| (Some m, IntVal _) -> reportNonArray ("indexing into " + id) m pos
|
||||
| (_, _) -> reportWrongType "indexing expression" Int indv pos
|
||||
| Iota (e, pos) ->
|
||||
let sz = evalExp(e, vtab, ftab)
|
||||
match sz with
|
||||
| IntVal size ->
|
||||
if size >= 0
|
||||
then ArrayVal( List.map (fun x -> IntVal x) [0..size-1], Int )
|
||||
else let msg = sprintf "Argument of \"iota\" is negative: %i" size
|
||||
raise (MyError(msg, pos))
|
||||
| _ -> reportWrongType "argument of \"iota\"" Int sz pos
|
||||
| Map (farg, arrexp, _, _, pos) ->
|
||||
let arr = evalExp(arrexp, vtab, ftab)
|
||||
let farg_ret_type = rtpFunArg farg ftab pos
|
||||
match arr with
|
||||
| ArrayVal (lst,tp1) ->
|
||||
let mlst = List.map (fun x -> evalFunArg (farg, vtab, ftab, pos, [x])) lst
|
||||
ArrayVal (mlst, farg_ret_type)
|
||||
| otherwise -> reportNonArray "2nd argument of \"map\"" arr pos
|
||||
| Reduce (farg, ne, arrexp, tp, pos) ->
|
||||
let farg_ret_type = rtpFunArg farg ftab pos
|
||||
let arr = evalExp(arrexp, vtab, ftab)
|
||||
let nel = evalExp(ne, vtab, ftab)
|
||||
match arr with
|
||||
| ArrayVal (lst,tp1) ->
|
||||
List.fold (fun acc x -> evalFunArg (farg, vtab, ftab, pos, [acc;x])) nel lst
|
||||
| otherwise -> reportNonArray "3rd argument of \"reduce\"" arr pos
|
||||
(* TODO project task 2: `replicate(n, a)`
|
||||
Look in `AbSyn.fs` for the arguments of the `Replicate`
|
||||
(`Map`,`Scan`) expression constructors.
|
||||
- evaluate `n` then evaluate `a`,
|
||||
- check that `n` evaluates to an integer value >= 0
|
||||
- If so then create an array containing `n` replicas of
|
||||
the value of `a`; otherwise raise an error (containing
|
||||
a meaningful message).
|
||||
*)
|
||||
| Replicate (_, _, _, _) ->
|
||||
failwith "Unimplemented interpretation of replicate"
|
||||
|
||||
(* TODO project task 2: `filter(p, arr)`
|
||||
pattern match the implementation of map:
|
||||
- check that the function `p` result type (use `rtpFunArg`) is bool;
|
||||
- evaluate `arr` and check that the (value) result corresponds to an array;
|
||||
- use F# `List.filter` to keep only the elements `a` of `arr` which succeed
|
||||
under predicate `p`, i.e., `p(a) = true`;
|
||||
- create an `ArrayVal` from the (list) result of the previous step.
|
||||
*)
|
||||
| Filter (_, _, _, _) ->
|
||||
failwith "Unimplemented interpretation of filter"
|
||||
|
||||
(* TODO project task 2: `scan(f, ne, arr)`
|
||||
Implementation similar to reduce, except that it produces an array
|
||||
of the same type and length to the input array `arr`.
|
||||
*)
|
||||
| Scan (_, _, _, _, _) ->
|
||||
failwith "Unimplemented interpretation of scan"
|
||||
|
||||
| Read (t,p) ->
|
||||
let str = Console.ReadLine()
|
||||
match t with
|
||||
| Int -> let v : int = int str
|
||||
IntVal v
|
||||
| Bool when str = "true" -> BoolVal true
|
||||
| Bool when str = "false" -> BoolVal false
|
||||
| Char -> let v : char = char str
|
||||
CharVal v
|
||||
| otherwise -> raise (MyError("Read operation is valid only on basic types ", p))
|
||||
|
||||
| Write(exp,t,p) ->
|
||||
let v = evalExp(exp, vtab, ftab)
|
||||
match v with
|
||||
| IntVal n -> printfn "%i " n
|
||||
| BoolVal b -> let res = if(b) then "true " else "false "
|
||||
printfn "%s" res
|
||||
| CharVal c -> printfn "%c " c
|
||||
| ArrayVal (a, Char) ->
|
||||
let mapfun = function
|
||||
| CharVal c -> c
|
||||
| otherwise -> raise (MyError("Write argument " +
|
||||
ppVal 0 v +
|
||||
" should have been evaluated to string", p))
|
||||
printfn "%s" ( System.String.Concat (List.map mapfun a) )
|
||||
| otherwise -> raise (MyError("Write can be called only on basic and array(char) types ", p))
|
||||
v
|
||||
|
||||
|
||||
|
||||
(* finds the return type of a function argument *)
|
||||
and rtpFunArg (funarg : UntypedFunArg)
|
||||
(ftab : FunTable)
|
||||
(callpos : Position)
|
||||
: Type =
|
||||
match funarg with
|
||||
| FunName fid ->
|
||||
match SymTab.lookup fid ftab with
|
||||
| None -> raise (MyError("Call to unknown function "+fid, callpos))
|
||||
| Some (FunDec (_, rettype, _, _, _)) -> rettype
|
||||
| Lambda (rettype, _, _, _) -> rettype
|
||||
|
||||
(* evalFunArg takes as argument a FunArg, a vtable, an ftable, the
|
||||
position where the call is performed, and the list of actual arguments.
|
||||
It returns the result of calling the (lambda) function.
|
||||
*)
|
||||
and evalFunArg ( funarg : UntypedFunArg
|
||||
, vtab : VarTable
|
||||
, ftab : FunTable
|
||||
, callpos : Position
|
||||
, aargs : Value list
|
||||
) : Value =
|
||||
match funarg with
|
||||
| (FunName fid) ->
|
||||
let fexp = SymTab.lookup fid ftab
|
||||
match fexp with
|
||||
| None -> raise (MyError("Call to known function "+fid, callpos))
|
||||
| Some f -> callFunWithVtable(f, aargs, SymTab.empty(), ftab, callpos)
|
||||
| Lambda (rettype, parms, body, fpos) ->
|
||||
callFunWithVtable ( FunDec ("<anonymous>", rettype, parms, body, fpos)
|
||||
, aargs, vtab, ftab, callpos )
|
||||
|
||||
(* Interpreter for Fasto function calls:
|
||||
1. f is the function declaration.
|
||||
2. args is a list of (already interpreted) arguments.
|
||||
3. vtab is the variable symbol table
|
||||
4. ftab is the function symbol table (containing f itself).
|
||||
5. pcall is the position of the function call. *)
|
||||
and callFunWithVtable (fundec : UntypedFunDec
|
||||
, aargs : Value list
|
||||
, vtab : VarTable
|
||||
, ftab : FunTable
|
||||
, pcall : Position
|
||||
) : Value =
|
||||
let (FunDec (fid, rtp, fargs, body, pdcl)) = fundec
|
||||
match fid with
|
||||
(* treat the special functions *)
|
||||
| "ord" -> match aargs with
|
||||
| [CharVal c] -> IntVal (int c)
|
||||
| [v] -> reportWrongType "argument of \"ord\"" Char v pcall
|
||||
| _ -> raise (MyError ("Wrong argument count for \"ord\"", pcall))
|
||||
| "chr" -> match aargs with
|
||||
| [IntVal n] -> CharVal (char n)
|
||||
| [v] -> reportWrongType "argument of \"chr\"" Int v pcall
|
||||
| _ -> raise (MyError ("Wrong argument count for \"chr\"", pcall))
|
||||
| _ ->
|
||||
let vtab' = SymTab.combine (bindParams fargs aargs fid pdcl pcall) vtab
|
||||
let res = evalExp (body, vtab', ftab)
|
||||
if typeMatch (rtp, res)
|
||||
then res
|
||||
else reportWrongType ("result of function \"" + fid + "\"") rtp res pcall
|
||||
|
||||
(* Interpreter for Fasto programs:
|
||||
1. builds the function symbol table,
|
||||
2. interprets the body of "main", and
|
||||
3. returns its result. *)
|
||||
and evalProg (prog : UntypedProg) : Value =
|
||||
let ftab = buildFtab prog
|
||||
let mainf = SymTab.lookup "main" ftab
|
||||
match mainf with
|
||||
| None -> raise (MyError("Could not find the main function", (0,0)))
|
||||
| Some m ->
|
||||
match getFunArgs m with
|
||||
| [] -> callFunWithVtable(m, [], SymTab.empty(), ftab, (0,0))
|
||||
| _ -> raise (MyError("The main function is not allowed to have parameters", getFunPos m))
|
||||
Reference in New Issue
Block a user