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(Node.NIL, getNextValue (), f)
  36
  37     let makeFunc f body binds env =
  38         Func(Node.NIL, getNextValue (), f, body, binds, env)
  39
  40     let makeMacro f body binds env =
  41         Macro(Node.NIL, 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               wrap "atom" (Core.atom getNextValue)
  92               wrap "atom?" Core.isAtom
  93               wrap "deref" Core.deref
  94               wrap "reset!" Core.reset
  95               wrap "swap!" Core.swap
  96               wrap "conj" Core.conj
  97               wrap "meta" Core.meta
  98               wrap "with-meta" Core.withMeta ]
  99             |> ofList
 100         [ env ]
 101
 102     let makeNew outer symbols nodes =
 103         let env = (makeEmpty ())::outer
 104         let rec loop symbols nodes =
 105             match symbols, nodes with
 106             | [Symbol("&"); Symbol(s)], nodes ->
 107                 set env s (Node.makeList nodes)
 108                 env
 109             | Symbol("&")::_, _ -> raise <| Error.onlyOneSymbolAfterAmp ()
 110             | Symbol(s)::symbols, n::nodes ->
 111                 set env s n
 112                 loop symbols nodes
 113             | [], [] -> env
 114             | _, [] -> raise <| Error.notEnoughValues ()
 115             | [], _ -> raise <| Error.tooManyValues ()
 116             | _, _ -> raise <| Error.errExpectedX "symbol"
 117         loop symbols nodes
 118
 119     (* Active Patterns to help with pattern matching nodes *)
 120     let inline (|IsMacro|_|) env = function
 121         | List(_, Symbol(sym)::rest) ->
 122             match find env sym with
 123             | Some(Macro(_, _, _, _, _, _) as m) -> Some(IsMacro m, rest)
 124             | _ -> None
 125         | _ -> None