fsharp/env.fs

   1 module Env
   2
   3     open Types
   4
   5     let makeEmpty () = Env()
   6
   7     let ofList lst =
   8         let env = makeEmpty ()
   9         let accumulate (e : Env) (k, v) = e.Add(k, v); e
  10         List.fold accumulate env lst
  11
  12     let set (env : EnvChain) key node =
  13         match env with
  14         | head::_ -> head.[key] <- node
  15         | _ -> raise <| Error.noEnvironment ()
  16
  17     let rec find (chain : EnvChain) key =
  18         match chain with
  19         | [] -> None
  20         | env::rest ->
  21             match env.TryGetValue(key) with
  22             | true, v -> Some(v)
  23             | false, _ -> find rest key
  24
  25     let get chain key =
  26         match find chain key with
  27         | Some(v) -> v
  28         | None -> raise <| Error.symbolNotFound key
  29
  30     let private getNextValue =
  31         let counter = ref 0
  32         fun () -> System.Threading.Interlocked.Increment(counter)
  33
  34     let makeBuiltInFunc f =
  35         BuiltInFunc(getNextValue (), f)
  36
  37     let makeFunc f body binds env =
  38         Func(getNextValue (), f, body, binds, env)
  39
  40     let makeMacro f body binds env =
  41         Macro(getNextValue (), f, body, binds, env)
  42
  43     let makeRootEnv () =
  44         let wrap name f = name, makeBuiltInFunc f
  45         let env =
  46             [ wrap "+" Core.add
  47               wrap "-" Core.subtract
  48               wrap "*" Core.multiply
  49               wrap "/" Core.divide
  50               wrap "list" Core.list
  51               wrap "list?" Core.isList
  52               wrap "empty?" Core.isEmpty
  53               wrap "count" Core.count
  54               wrap "=" Core.eq
  55               wrap "<" Core.lt
  56               wrap "<=" Core.le
  57               wrap ">=" Core.ge
  58               wrap ">" Core.gt
  59               wrap "pr-str" Core.pr_str
  60               wrap "str" Core.str
  61               wrap "prn" Core.prn
  62               wrap "println" Core.println
  63               wrap "read-string" Core.read_str
  64               wrap "slurp" Core.slurp
  65               wrap "cons" Core.cons
  66               wrap "concat" Core.concat
  67               wrap "nth" Core.nth
  68               wrap "first" Core.first
  69               wrap "rest" Core.rest
  70               wrap "throw" Core.throw
  71               wrap "map" Core.map
  72               wrap "apply" Core.apply
  73               wrap "nil?" (Core.isConst Node.NIL)
  74               wrap "true?" (Core.isConst Node.TRUE)
  75               wrap "false?" (Core.isConst Node.FALSE)
  76               wrap "symbol?" Core.isSymbol
  77               wrap "symbol" Core.symbol
  78               wrap "keyword?" Core.isKeyword
  79               wrap "keyword" Core.keyword
  80               wrap "sequential?" Core.isSequential
  81               wrap "vector?" Core.isVector
  82               wrap "vector" Core.vector
  83               wrap "map?" Core.isMap
  84               wrap "hash-map" Core.hashMap
  85               wrap "assoc" Core.assoc
  86               wrap "dissoc" Core.dissoc
  87               wrap "get" Core.get
  88               wrap "contains?" Core.contains
  89               wrap "keys" Core.keys
  90               wrap "vals" Core.vals ]
  91             |> ofList
  92         [ env ]
  93
  94     let makeNew outer symbols nodes =
  95         let env = (makeEmpty ())::outer
  96         let rec loop symbols nodes =
  97             match symbols, nodes with
  98             | [Symbol("&"); Symbol(s)], nodes ->
  99                 set env s (List nodes)
 100                 env
 101             | Symbol("&")::_, _ -> raise <| Error.onlyOneSymbolAfterAmp ()
 102             | Symbol(s)::symbols, n::nodes ->
 103                 set env s n
 104                 loop symbols nodes
 105             | [], [] -> env
 106             | _, [] -> raise <| Error.notEnoughValues ()
 107             | [], _ -> raise <| Error.tooManyValues ()
 108             | _, _ -> raise <| Error.errExpectedX "symbol"
 109         loop symbols nodes
 110
 111     (* Active Patterns to help with pattern matching nodes *)
 112     let inline (|IsMacro|_|) env = function
 113         | List(Symbol(sym)::rest) ->
 114             match find env sym with
 115             | Some(Macro(_, _, _, _, _) as m) -> Some(IsMacro m, rest)
 116             | _ -> None
 117         | _ -> None