guile/env.scm

   1 ;;  Copyright (C) 2015
   2 ;;      "Mu Lei" known as "NalaGinrut" <NalaGinrut@gmail.com>
   3 ;;  This file is free software: you can redistribute it and/or modify
   4 ;;  it under the terms of the GNU General Public License as published by
   5 ;;  the Free Software Foundation, either version 3 of the License, or
   6 ;;  (at your option) any later version.
   7
   8 ;;  This file is distributed in the hope that it will be useful,
   9 ;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 ;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 ;;  GNU General Public License for more details.
  12
  13 ;;  You should have received a copy of the GNU General Public License
  14 ;;  along with this program.  If not, see <http://www.gnu.org/licenses/>.
  15
  16 (library (env)
  17   (export make-Env env-has)
  18   (import (guile) (types)))
  19
  20 (define (env-has sym env)
  21   (let ((v ((env 'get) sym)))
  22     (if (equal? v '*mal-null*)
  23         (throw 'mal-error (format #f "'~a' not found" sym))
  24         v)))
  25
  26 (define* (make-Env #:key (outer nil) (binds '()) (exprs '()))
  27   (define _env (make-hash-table))
  28   (define (_set k v) (hash-set! _env k v))
  29   (define (_get k)
  30     (let ((v (hash-ref _env k '*mal-null*)))
  31       (if (equal? v '*mal-null*)
  32           (and (not (_nil? outer)) ((outer 'get) k))
  33           v)))
  34   (define (_find k) (_get k))
  35   (define (_show)
  36     (hash-for-each (lambda (k v) (format #t "~a : ~a~%" k v)) _env)
  37     (and (not (_nil? outer)) ((outer 'show))))
  38   (let lp((b binds) (e exprs))
  39     (cond
  40      ((null? b) #t)
  41      ((eq? (car b) '&) (hash-set! _env (cadr b) e)) ; handle varglist
  42      (else ; normal binding
  43       (when (not (symbol? (car b)))
  44         (throw 'mal-error "Invalid binding key!" (car b)))
  45       (hash-set! _env (car b) (car e))
  46       (lp (cdr b) (cdr e)))))
  47   (lambda (cmd)
  48     (case cmd
  49       ((set) _set)
  50       ((find) _find)
  51       ((get) _get)
  52       ((show) _show)
  53       (else (throw 'mal-error "BUG: Invalid cmd" cmd)))))