guile/step7_quote.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 (map make-func 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 (_eval o) (EVAL o env))
  40   (define (func? x) (and=> ((env 'get) x) is-func?))
  41   (cond
  42    ((func? (car ast))
  43     => (lambda (c)
  44          (callable-apply c (map _eval (cdr ast)))))
  45    (else (throw 'mal-error (format #f "'~a' not found" (car ast))))))
  46
  47 (define (eval_seq ast env)
  48   (cond
  49    ((null? ast) nil)
  50    ((null? (cdr ast)) (EVAL (car ast) env))
  51    (else
  52     (EVAL (car ast) env)
  53     (eval_seq (cdr ast) env))))
  54
  55 (define (EVAL ast env)
  56   (define (%unzip2 kvs)
  57     (let lp((next kvs) (k '()) (v '()))
  58       (cond
  59        ;; NOTE: reverse is very important here!
  60        ((null? next) (values (reverse k) (reverse v)))
  61        ((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs))
  62        (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
  63   ;; (define (_quasiquote ast)
  64   ;;   (define (non-pair? x) (not (pair? x)))
  65   ;;   (match ast
  66   ;;     ((? non-pair?) `(quote ,ast))
  67   ;;     (('unquote unq) unq)
  68   ;;     (((? pair? p) ('splice-unquote unqsp) rest ...)
  69   ;;      `(concat ,p ,unqsp ,(_quasiquote rest)))
  70   ;;     (else `(cons ,(_quasiquote (car ast)) ,(_quasiquote (cdr ast))))))
  71   (define (_quasiquote obj)
  72     (match obj
  73       ((('unquote unq) rest ...) `(cons ,unq ,(_quasiquote rest)))
  74       (('unquote unq) unq)
  75       ((('splice-unquote unqsp) rest ...) `(concat ,unqsp ,(_quasiquote rest)))
  76       ((head rest ...) (list 'cons (list 'quote head) (_quasiquote rest)))
  77       (else `(quote ,obj))))
  78   ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means
  79   ;;       it'll bring some trouble in control flow. We have to use continuations to return
  80   ;;       and use non-standard `break' feature. In a word, not elegant at all.
  81   ;;       The named let loop is natural for Scheme, but it looks a bit cheating. But NO!
  82   ;;       Such kind of loop is actually `while loop' in Scheme, I don't take advantage of
  83   ;;       TCO in Scheme to implement TCO, but it's the same principle with normal loop.
  84   ;;       If you're Lispy enough, there's no recursive at all while you saw named let loop.
  85   (let tco-loop((ast ast) (env env))
  86     (match ast
  87       (() ast)
  88       (('quote obj) obj)
  89       (('quasiquote obj) (EVAL (_quasiquote (->list obj)) env))
  90       (('def! k v) ((env 'set) k (EVAL v env)))
  91       (('let* kvs body)
  92        (let* ((new-env (make-Env #:outer env))
  93               (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
  94          (receive (keys vals) (%unzip2 (->list kvs))
  95                   (for-each setter keys vals))
  96          (tco-loop body new-env)))
  97        (('do rest ...)
  98         (cond
  99          ((null? rest) (throw 'mal-error "do: Invalid form!" rest))
 100          ((= 1 (length rest)) (tco-loop (car rest) env))
 101          (else
 102           (let ((mexpr (take rest (1- (length rest))))
 103                 (tail-call (car (take-right rest 1))))
 104             (eval_seq mexpr env)
 105             (tco-loop tail-call env)))))
 106        (('if cnd thn els ...)
 107         (cond
 108          ((and (not (null? els)) (not (null? (cdr els))))
 109           ;; Invalid `if' form
 110           (throw 'mal-error "if: failed to match any pattern in form " ast))
 111          ((cond-true? (EVAL cnd env)) (tco-loop thn env))
 112          (else (if (null? els) nil (tco-loop (car els) env)))))
 113        (('fn* params body ...) ; function definition
 114         (make-func
 115          (lambda args
 116            (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
 117              (cond
 118               ((null? body) (throw 'mal-error "fn*: bad lambda in form " ast))
 119               ((= 1 (length body)) (tco-loop (car body) nenv))
 120               (else
 121                (let ((mexpr (take body (1- (length body))))
 122                      (tail-call (car (take-right body 1))))
 123                  (eval_seq mexpr nenv)
 124                  (tco-loop tail-call nenv))))))))
 125        ((? list?) (eval_func ast env)) ; function calling
 126        (else (eval_ast ast env)))))
 127
 128 (define (EVAL-string str)
 129   (EVAL (read_str str) *toplevel*))
 130
 131 (define (PRINT exp)
 132   (and (not (eof-object? exp))
 133        (format #t "~a~%" (pr_str exp #t))))
 134
 135 (define (LOOP continue?)
 136   (and continue? (REPL)))
 137
 138 (define (REPL)
 139   (LOOP
 140    (catch 'mal-error
 141           (lambda () (PRINT (EVAL (READ) *toplevel*)))
 142           (lambda (k . e)
 143             (if (string=? (car e) "blank line")
 144                 (display "")
 145                 (format #t "Error: ~a~%" (car e)))))))
 146
 147 ;; initialization
 148 ((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*))))
 149 ((*toplevel* 'set) '*ARGV* '())
 150 (EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 151
 152 (let ((args (cdr (command-line))))
 153   (cond
 154    ((> (length args) 0)
 155     ((*toplevel* 'set) '*ARGV* (cdr args))
 156     (EVAL-string (string-append "(load-file \"" (car args) "\")")))
 157    (else (REPL))))