#####################
-SRCS = step0_repl.fs step1_read_print.fs step2_eval.fs step3_env.fs
+SRCS = step0_repl.fs step1_read_print.fs step2_eval.fs step3_env.fs \
+ step4_if_fn_do.fs
FSFLAGS = $(if $(strip $(DEBUG)),--debug+,)
CSFLAGS = $(if $(strip $(DEBUG)),-debug+,)
-module Core
-
- open Types
-
- let errArity () = EvalError("arity: wrong number of arguments")
- let errArgMismatch () = EvalError("argument mismatch")
-
- let inline toNumber node =
- match node with
- | Number(n) -> n
- | _ -> raise <| errArgMismatch ()
-
- let inline makeNumFolder op =
- (fun state node -> op state (node |> toNumber))
-
- let add nodes =
- let addNode = makeNumFolder (+)
- nodes |> Seq.fold addNode 0L |> Number
-
- let subtract nodes =
- let subtractNode = makeNumFolder (-)
- match nodes with
- | [] -> raise <| errArity ()
- | Number(first)::[] -> Number(-first)
- | Number(first)::rest -> rest |> Seq.fold subtractNode first |> Number
- | _ -> raise <| errArgMismatch ()
-
- let multiply nodes =
- let multiplyNode = makeNumFolder ( * )
- nodes |> Seq.fold multiplyNode 1L |> Number
-
- let divide nodes =
- let divideNode = makeNumFolder (/)
- match nodes with
- | [] -> raise <| errArity ()
- | Number(first)::[] -> 1L / first |> Number
- | Number(first)::rest -> rest |> Seq.fold divideNode first |> Number
- | _ -> raise <| errArgMismatch ()
+module Core
+
+ open Types
+
+ let errArity () = EvalError("arity: wrong number of arguments")
+ let errArgMismatch () = EvalError("argument mismatch")
+
+ let inline toBool b = if b then TRUE else FALSE
+
+ let inline twoNumberOp (f : int64 -> int64 -> Node) = function
+ | [Number(a); Number(b)] -> f a b
+ | [_; _] -> raise <| errArgMismatch ()
+ | _ -> raise <| errArity ()
+
+ let inline twoNodeOp (f : Node -> Node -> Node) = function
+ | [a; b] -> f a b
+ | _ -> raise <| errArity ()
+
+ let add = twoNumberOp (fun a b -> a + b |> Number)
+ let subtract = twoNumberOp (fun a b -> a - b |> Number)
+ let multiply = twoNumberOp (fun a b -> a * b |> Number)
+ let divide = twoNumberOp (fun a b -> a / b |> Number)
+ let lt = twoNodeOp (fun a b -> a < b |> toBool)
+ let le = twoNodeOp (fun a b -> a <= b |> toBool)
+ let ge = twoNodeOp (fun a b -> a >= b |> toBool)
+ let gt = twoNodeOp (fun a b -> a > b |> toBool)
+ let eq = twoNodeOp (fun a b -> a = b |> toBool)
+
+ let list nodes = List(nodes)
+ let isList = function
+ | [List(_)] -> TRUE
+ | [_] -> FALSE
+ | _ -> raise <| errArity ()
+
+ let isEmpty = function
+ | [List([])] -> TRUE
+ | _ -> FALSE
+
+ let count = function
+ | [List(a)] -> a |> List.fold (fun cnt _ -> cnt + 1L) 0L |> Number
+ | [Nil] -> ZERO
+ | [_] -> raise <| errArgMismatch ()
+ | _ -> raise <| errArity ()
| Some(v) -> v
| None -> raise <| errSymbolNotFound key
+ let makeFunc =
+ let counter = ref 0
+ let getNext () = System.Threading.Interlocked.Increment(counter)
+ fun f -> Func({ Tag = getNext (); F = f })
+
let makeRootEnv () =
- let wrap tag name func = name, Func({ Tag = tag; Name = name; F = func })
+ let wrap name f = name, makeFunc f
let env =
- [ wrap 1 "+" Core.add;
- wrap 2 "-" Core.subtract;
- wrap 3 "*" Core.multiply;
- wrap 4 "/" Core.divide ]
+ [ wrap "+" Core.add;
+ wrap "-" Core.subtract;
+ wrap "*" Core.multiply;
+ wrap "/" Core.divide;
+ wrap "list" Core.list;
+ wrap "list?" Core.isList;
+ wrap "empty?" Core.isEmpty;
+ wrap "count" Core.count;
+ wrap "=" Core.eq;
+ wrap "<" Core.lt;
+ wrap "<=" Core.le;
+ wrap ">=" Core.ge;
+ wrap ">" Core.gt ]
|> ofList
[ env ]
let errExpected tok = EvalError(sprintf "expected %s" tok)
- let mapPairs f (source : seq<_>) =
+ let iterPairs f (source : seq<_>) =
use iter = source.GetEnumerator()
let rec loop () =
if iter.MoveNext() then
let newEnv = Env.makeNew env
let binder = setBinding newEnv
match bindings with
- | List(lst) -> lst |> mapPairs binder
- | Vector(vec) -> vec |> mapPairs binder
+ | List(lst) -> lst |> iterPairs binder
+ | Vector(vec) -> vec |> iterPairs binder
| _ -> raise <| errExpected "list or vector"
eval newEnv form
| _ -> raise <| Core.errArity ()
| String(str) -> pr_str str
| Bool(true) -> appendStr "true"
| Bool(false) -> appendStr "false"
- | Func({ Tag = tag; Name = name; F = _}) -> pr_func tag name
+ | Func({ Tag = tag; F = _}) -> pr_func tag
and pr prefix node =
appendStr prefix
str |> Seq.iter appendChar
appendStr "\""
- and pr_func tag name =
- sprintf "#<%d %s>" tag name |> appendStr
+ and pr_func tag =
+ sprintf "#<func %d>" tag |> appendStr
and pr_list nodes =
appendStr "("
| _ -> raise <| errExpectedButEOF "map"
and readAtom = function
- | Token("nil")::rest -> Some(Nil), rest
- | Token("true")::rest -> Some(Bool(true)), rest
- | Token("false")::rest -> Some(Bool(false)), rest
+ | Token("nil")::rest -> SomeNIL, rest
+ | Token("true")::rest -> SomeTRUE, rest
+ | Token("false")::rest -> SomeFALSE, rest
| Tokenizer.String(str)::rest -> Some(String(str)), rest
| Tokenizer.Keyword(kw)::rest -> Some(Keyword(kw)), rest
| Tokenizer.Number(num)::rest -> Some(Number(Int64.Parse(num))), rest
--- /dev/null
+module REPL
+ open System
+
+ let read input =
+ try
+ Reader.read_str input
+ with
+ | Types.ReaderError(msg) ->
+ printfn "%s" msg
+ []
+
+ let eval env ast =
+ try
+ Some(Eval.eval env ast)
+ with
+ | Types.EvalError(msg) ->
+ printfn "%s" msg
+ None
+
+ let print v =
+ v
+ |> Printer.pr_str
+ |> printfn "%s"
+
+ let rep env input =
+ read input
+ |> Seq.ofList
+ |> Seq.choose (fun form -> eval env form)
+ |> Seq.iter (fun value -> print value)
+
+ let getReadlineMode (args : string array) =
+ if args.Length > 0 && args.[0] = "--raw" then
+ Readline.Mode.Raw
+ else
+ Readline.Mode.Terminal
+
+ [<EntryPoint>]
+ let main args =
+ let mode = getReadlineMode args
+ let env = Env.makeRootEnv ()
+ let rec loop () =
+ match Readline.read "user> " mode with
+ | null -> 0
+ | input ->
+ rep env input
+ loop ()
+ loop ()
| Bool of bool
| Func of F
and
- // Compare only on Tag and Name since functions are not IComparable
+ // Compare only on Tag since functions are not IComparable
[<CustomEquality; CustomComparison>]
- F = { Tag : int; Name : string; F : Node list -> Node }
+ F = { Tag : int; F : Node list -> Node }
override x.Equals(yobj) =
match yobj with
- | :? F as y -> x.Tag = y.Tag && x.Name = y.Name
+ | :? F as y -> x.Tag = y.Tag
| _ -> false
- override x.GetHashCode() =
- ((hash x.Tag) * 397) ^^^ (hash x.Name)
+ override x.GetHashCode() = hash x.Tag
interface System.IComparable with
member x.CompareTo yobj =
match yobj with
- | :? F as y ->
- let a = compare x.Tag y.Tag
- if a <> 0 then a
- else compare x.Name y.Name
+ | :? F as y -> compare x.Tag y.Tag
| _ -> invalidArg "yobj" "Cannot compare values of different types."
+
+ let TRUE = Bool(true)
+ let SomeTRUE = Some(TRUE)
+ let FALSE = Bool(false)
+ let SomeFALSE = Some(FALSE)
+ let NIL = Nil
+ let SomeNIL = Some(NIL)
+ let ZERO = Number(0L)
HCoop / jackhill / mal.git / commitdiff