guile/step5_tco.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 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   ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means
  57   ;;       it'll bring some trouble in control flow. We have to use continuations to return
  58   ;;       and use non-standard `break' feature. In a word, not elegant at all.
  59   ;;       The named let loop is natural for Scheme, but it looks a bit cheating. But NO!
  60   ;;       Such kind of loop is actually `while loop' in Scheme, I don't take advantage of
  61   ;;       TCO in Scheme to implement TCO, but it's the same principle with normal loop.
  62   ;;       If you're Lispy enough, there's no recursive at all while you saw named let loop.
  63   (let tco-loop((ast ast) (env env))
  64     (match ast
  65       ((? non-list?) (eval_ast ast env))
  66       (() ast)
  67       (('def! k v) ((env 'set) k (EVAL v env)))
  68       (('let* kvs body)
  69        (let* ((new-env (make-Env #:outer env))
  70               (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
  71          (receive (keys vals) (%unzip2 (->list kvs))
  72                   (for-each setter keys vals))
  73          (tco-loop body new-env)))
  74        (('do rest ...)
  75         (cond
  76          ((null? rest)
  77           (throw 'mal-error (format #f "do: Invalid form! '~a'" rest)))
  78          ((= 1 (length rest)) (tco-loop (car rest) env))
  79          (else
  80           (let ((mexpr (take rest (1- (length rest))))
  81                 (tail-call (car (take-right rest 1))))
  82             (eval_seq mexpr env)
  83             (tco-loop tail-call env)))))
  84        (('if cnd thn els ...)
  85         (cond
  86          ((and (not (null? els)) (not (null? (cdr els))))
  87           ;; Invalid `if' form
  88           (throw 'mal-error
  89                  (format #f "if: failed to match any pattern in form '~a'" ast)))
  90          ((cond-true? (EVAL cnd env)) (tco-loop thn env))
  91          (else (if (null? els) nil (tco-loop (car els) env)))))
  92        (('fn* params body ...) ; function definition
  93         (make-func
  94          (lambda args
  95            (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
  96              (cond
  97               ((null? body)
  98                (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast)))
  99               ((= 1 (length body)) (tco-loop (car body) nenv))
 100               (else
 101                (let ((mexpr (take body (1- (length body))))
 102                      (tail-call (car (take-right body 1))))
 103                  (eval_seq mexpr nenv)
 104                  (tco-loop tail-call nenv))))))))
 105        (else
 106          (let ((el (map (lambda (x) (EVAL x env)) ast)))
 107            (callable-apply (car el) (cdr el)))))))
 108
 109 (define (EVAL-string str)
 110   (EVAL (read_str str) *toplevel*))
 111
 112 (define (PRINT exp)
 113   (and (not (eof-object? exp))
 114        (format #t "~a~%" (pr_str exp #t))))
 115
 116 (define (LOOP continue?)
 117   (and continue? (REPL)))
 118
 119 (define (REPL)
 120   (LOOP
 121    (let ((line (_readline "user> ")))
 122      (cond
 123        ((eof-object? line) #f)
 124        ((string=? line "") #t)
 125        (else
 126          (catch 'mal-error
 127                 (lambda () (PRINT (EVAL (READ line) *toplevel*)))
 128                 (lambda (k . e)
 129                   (format #t "Error: ~a~%" (pr_str (car e) #t)))))))))
 130
 131 (EVAL-string "(def! not (fn* (x) (if x false true)))")
 132
 133 (REPL)