guile/step3_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 (import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)
  17         (srfi srfi-1) (ice-9 receive) (env))
  18
  19 (define *primitives*
  20   `((+ ,+)
  21     (- ,-)
  22     (* ,*)
  23     (/ ,/)))
  24
  25 (define *toplevel*
  26   (receive (b e) (unzip2 *primitives*)
  27     (make-Env #:binds b #:exprs e)))
  28
  29 (define (READ str)
  30   (read_str str))
  31
  32 (define (eval_ast ast env)
  33   (define (_eval x) (EVAL x env))
  34   (match ast
  35     ((? symbol? sym) (env-has sym env))
  36     ((? list? lst) (map _eval lst))
  37     ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
  38     ((? hash-table? ht)
  39      ;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or
  40      ;;       there'll be strange bugs!!!
  41      (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht)))
  42     (else ast)))
  43
  44 (define (EVAL ast env)
  45   (define (->list kvs) ((if (vector? kvs) vector->list identity) kvs))
  46   (define (%unzip2 kvs)
  47     (let lp((next kvs) (k '()) (v '()))
  48       (cond
  49        ;; NOTE: reverse is very important here!
  50        ((null? next) (values (reverse k) (reverse v)))
  51        ((null? (cdr next))
  52         (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs)))
  53        (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
  54   (match ast
  55     ((? (lambda (x) (not (list? x)))) (eval_ast ast env))
  56     (() ast)
  57     (('def! k v) ((env 'set) k (EVAL v env)))
  58     (('let* kvs body)
  59      (let* ((new-env (make-Env #:outer env))
  60             (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
  61        (receive (keys vals) (%unzip2 (->list kvs))
  62          (for-each setter keys vals))
  63        (EVAL body new-env)))
  64     (else
  65       (let ((el (eval_ast ast env)))
  66         (apply (car el) (cdr el))))))
  67
  68 (define (PRINT exp)
  69   (and (not (eof-object? exp))
  70        (format #t "~a~%" (pr_str exp #t))))
  71
  72 (define (LOOP continue?)
  73   (and continue? (REPL)))
  74
  75 (define (REPL)
  76   (LOOP
  77    (let ((line (_readline "user> ")))
  78      (cond
  79        ((eof-object? line) #f)
  80        ((string=? line "") #t)
  81        (else
  82          (catch 'mal-error
  83                 (lambda () (PRINT (EVAL (READ line) *toplevel*)))
  84                 (lambda (k . e)
  85                   (format #t "Error: ~a~%" (pr_str (car e) #t)))))))))
  86
  87 (REPL)