guile/step4_if_fn_do.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) (core) (types))
  18
  19 (define *toplevel*
  20   (receive (b e) (unzip2 core.ns)
  21     (make-Env #:binds b #:exprs e)))
  22
  23 (define (READ)
  24   (read_str (readline "user> ")))
  25
  26 (define (eval_ast ast env)
  27   (define (_eval x) (EVAL x env))
  28   (match ast
  29     ((? _nil? obj) obj)
  30     ((? symbol? sym) (env-has sym env))
  31     ((? list? lst) (map _eval lst))
  32     ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
  33     ((? hash-table? ht)
  34      (hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht)
  35      ht)
  36     (else ast)))
  37
  38 (define (eval_func ast env)
  39   (define expr (eval_ast ast env))
  40   (match expr
  41     (((? procedure? proc) args ...)
  42      (apply proc args))
  43     (else 'mal-error (format #f "'~a' is not a valid form to apply!" expr))))
  44
  45 (define (eval_seq ast env)
  46   (cond
  47    ((null? ast) nil)
  48    ((null? (cdr ast)) (EVAL (car ast) env))
  49    (else
  50     (EVAL (car ast) env)
  51     (eval_seq (cdr ast) env))))
  52
  53 (define (EVAL ast env)
  54   (define (->list kvs) ((if (vector? kvs) vector->list identity) kvs))
  55   (define (%unzip2 kvs)
  56     (let lp((next kvs) (k '()) (v '()))
  57       (cond
  58        ;; NOTE: reverse is very important here!
  59        ((null? next) (values (reverse k) (reverse v)))
  60        ((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs))
  61        (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
  62   (match ast
  63     (('def! k v) ((env 'set) k (EVAL v env)))
  64     (('let* kvs body)
  65      (let* ((new-env (make-Env #:outer env))
  66             (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
  67        (receive (keys vals) (%unzip2 (->list kvs))
  68          (for-each setter keys vals))
  69        (EVAL body new-env)))
  70     (('do rest ...) (eval_seq rest env))
  71     (('if cnd thn els ...)
  72      (cond
  73       ((and (not (null? els)) (not (null? (cdr els))))
  74        ;; Invalid `if' form
  75        (throw 'mal-error "failed to match any pattern in form " ast))
  76       ((cond-true? (EVAL cnd env)) (EVAL thn env))
  77       (else (if (null? els) nil (EVAL (car els) env)))))
  78     (('fn* params body ...) ; function definition
  79      (lambda args
  80        (eval_seq body (make-Env #:outer env #:binds (->list params) #:exprs args))))
  81     ((? list?) (eval_func ast env)) ; function calling
  82     (else (eval_ast ast env))))
  83
  84 (define (PRINT exp)
  85   (and (not (eof-object? exp))
  86        ;;(add-history str)
  87        (format #t "~a~%" (pr_str exp #t))))
  88
  89 (define (LOOP continue?)
  90   (and continue? (REPL)))
  91
  92 (define (REPL)
  93   (LOOP
  94    (catch 'mal-error
  95           (lambda () (PRINT (EVAL (READ) *toplevel*)))
  96           (lambda (k . e)
  97             (format #t "Error: ~a~%" (car e))))))
  98
  99 (REPL)