| 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 str) |
| 24 | (read_str str)) |
| 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 | ;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or |
| 35 | ;; there'll be strange bugs!!! |
| 36 | (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht))) |
| 37 | (else ast))) |
| 38 | |
| 39 | (define (eval_seq ast env) |
| 40 | (cond |
| 41 | ((null? ast) nil) |
| 42 | ((null? (cdr ast)) (EVAL (car ast) env)) |
| 43 | (else |
| 44 | (EVAL (car ast) env) |
| 45 | (eval_seq (cdr ast) env)))) |
| 46 | |
| 47 | (define (EVAL ast env) |
| 48 | (define (%unzip2 kvs) |
| 49 | (let lp((next kvs) (k '()) (v '())) |
| 50 | (cond |
| 51 | ;; NOTE: reverse is very important here! |
| 52 | ((null? next) (values (reverse k) (reverse v))) |
| 53 | ((null? (cdr next)) |
| 54 | (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) |
| 55 | (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v)))))) |
| 56 | (match ast |
| 57 | ((? non-list?) (eval_ast ast env)) |
| 58 | (() ast) |
| 59 | (('def! k v) ((env 'set) k (EVAL v env))) |
| 60 | (('let* kvs body) |
| 61 | (let* ((new-env (make-Env #:outer env)) |
| 62 | (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env))))) |
| 63 | (receive (keys vals) (%unzip2 (->list kvs)) |
| 64 | (for-each setter keys vals)) |
| 65 | (EVAL body new-env))) |
| 66 | (('do rest ...) |
| 67 | (eval_seq rest env)) |
| 68 | (('if cnd thn els ...) |
| 69 | (cond |
| 70 | ((and (not (null? els)) (not (null? (cdr els)))) |
| 71 | ;; Invalid `if' form |
| 72 | (throw 'mal-error |
| 73 | (format #f "if: failed to match any pattern in form '~a'" ast))) |
| 74 | ((cond-true? (EVAL cnd env)) (EVAL thn env)) |
| 75 | (else (if (null? els) nil (EVAL (car els) env))))) |
| 76 | (('fn* params body ...) ; function definition |
| 77 | (lambda args |
| 78 | (eval_seq body (make-Env #:outer env #:binds (->list params) #:exprs args)))) |
| 79 | (else |
| 80 | (let ((el (map (lambda (x) (EVAL x env)) ast))) |
| 81 | (apply (car el) (cdr el)))))) |
| 82 | |
| 83 | (define (EVAL-string str) |
| 84 | (EVAL (read_str str) *toplevel*)) |
| 85 | |
| 86 | (define (PRINT exp) |
| 87 | (and (not (eof-object? exp)) |
| 88 | (format #t "~a~%" (pr_str exp #t)))) |
| 89 | |
| 90 | (define (LOOP continue?) |
| 91 | (and continue? (REPL))) |
| 92 | |
| 93 | (define (REPL) |
| 94 | (LOOP |
| 95 | (let ((line (_readline "user> "))) |
| 96 | (cond |
| 97 | ((eof-object? line) #f) |
| 98 | ((string=? line "") #t) |
| 99 | (else |
| 100 | (catch 'mal-error |
| 101 | (lambda () (PRINT (EVAL (READ line) *toplevel*))) |
| 102 | (lambda (k . e) |
| 103 | (format #t "Error: ~a~%" (pr_str (car e) #t))))))))) |
| 104 | |
| 105 | (EVAL-string "(def! not (fn* (x) (if x false true)))") |
| 106 | |
| 107 | (REPL) |