guile/stepA_mal.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 ;; Primitives which doesn't unbox args in default.
  20 ;; This is a trick to implement meta-info taking advange of the original
  21 ;; types of Guile as possible.
  22 (define *unbox-exception* '(meta assoc swap!))
  23
  24 (define *toplevel*
  25   (receive (b e) (unzip2 core.ns)
  26     (let ((env (make-Env #:binds b #:exprs (map make-func e))))
  27       (for-each (lambda (f)
  28                   (callable-unbox-set! ((env 'get) f) #f))
  29                 *unbox-exception*)
  30       env)))
  31
  32 (define (READ)
  33   (read_str (_readline "user> ")))
  34
  35 (define (eval_ast ast env)
  36   (define (_eval x) (EVAL x env))
  37   (match ast
  38     ((? symbol? sym) (env-has sym env))
  39     ((? list? lst) (map _eval lst))
  40     ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
  41     ((? hash-table? ht)
  42      ;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or
  43      ;;       there'll be strange bugs!!!
  44      (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht)))
  45     (else ast)))
  46
  47 (define (eval_func ast env)
  48   (define (_eval o) (EVAL o env))
  49   (define (func? x)
  50     (let ((f (if (list? x)
  51                  (EVAL x env)
  52                  x)))
  53       (if (callable? f)
  54           f
  55           (and=> (env-check f env) is-func?))))
  56   (cond
  57    ((func? (car ast))
  58     => (lambda (c)
  59          (callable-apply c (map _eval (cdr ast)))))
  60    (else (throw 'mal-error (format #f "'~a' not found" (car ast))))))
  61
  62 (define (eval_seq ast env)
  63   (cond
  64    ((null? ast) nil)
  65    ((null? (cdr ast)) (EVAL (car ast) env))
  66    (else
  67     (EVAL (car ast) env)
  68     (eval_seq (cdr ast) env))))
  69
  70 (define (is_macro_call ast env)
  71   (and (list? ast)
  72        (> (length ast) 0)
  73        (and=> (env-check (car ast) env) is-macro?)))
  74
  75 (define (_macroexpand ast env)
  76   (cond
  77    ((is_macro_call ast env)
  78     => (lambda (c)
  79          ;; NOTE: Macros are normal-order, so we shouldn't eval args here.
  80          ;;       Or it's applicable-order.
  81          (_macroexpand (callable-apply c (cdr ast)) env)))
  82    (else ast)))
  83
  84 (define (EVAL ast env)
  85   (define (%unzip2 kvs)
  86     (let lp((next kvs) (k '()) (v '()))
  87       (cond
  88        ;; NOTE: reverse is very important here!
  89        ((null? next) (values (reverse k) (reverse v)))
  90        ((null? (cdr next))
  91         (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs)))
  92        (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
  93   (define (_quasiquote obj)
  94     (match obj
  95       ((('unquote unq) rest ...) `(cons ,unq ,(_quasiquote rest)))
  96       (('unquote unq) unq)
  97       ((('splice-unquote unqsp) rest ...) `(concat ,unqsp ,(_quasiquote rest)))
  98       ((head rest ...) (list 'cons (_quasiquote head) (_quasiquote rest)))
  99       (else `(quote ,obj))))
 100   ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means
 101   ;;       it'll bring some trouble in control flow. We have to use continuations to return
 102   ;;       and use non-standard `break' feature. In a word, not elegant at all.
 103   ;;       The named let loop is natural for Scheme, but it looks a bit cheating. But NO!
 104   ;;       Such kind of loop is actually `while loop' in Scheme, I don't take advantage of
 105   ;;       TCO in Scheme to implement TCO, but it's the same principle with normal loop.
 106   ;;       If you're Lispy enough, there's no recursive at all while you saw named let loop.
 107   (let tco-loop((ast ast) (env env)) ; expand as possible
 108     (let ((ast (_macroexpand ast env)))
 109       (match ast
 110         ((? non-list?) (eval_ast ast env))
 111         (() ast)
 112         (('defmacro! k v)
 113          (let ((c (EVAL v env)))
 114            (callable-is_macro-set! c #t)
 115            ((env 'set) k c)))
 116         (('macroexpand obj) (_macroexpand obj env))
 117         (('quote obj) obj)
 118         (('quasiquote obj) (EVAL (_quasiquote (->list obj)) env))
 119         (('def! k v) ((env 'set) k (EVAL v env)))
 120         (('let* kvs body)
 121          (let* ((new-env (make-Env #:outer env))
 122                 (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
 123            (receive (keys vals) (%unzip2 (->list kvs))
 124                     (for-each setter keys vals))
 125            (tco-loop body new-env)))
 126         (('do rest ...)
 127          (cond
 128           ((null? rest)
 129            (throw 'mal-error (format #f "do: Invalid form! '~a'" rest)))
 130           ((= 1 (length rest)) (tco-loop (car rest) env))
 131           (else
 132            (let ((mexpr (take rest (1- (length rest))))
 133                  (tail-call (car (take-right rest 1))))
 134              (eval_seq mexpr env)
 135              (tco-loop tail-call env)))))
 136         (('if cnd thn els ...)
 137          (cond
 138           ((and (not (null? els)) (not (null? (cdr els))))
 139            ;; Invalid `if' form
 140            (throw 'mal-error
 141                   (format #f "if: failed to match any pattern in form '~a'" ast)))
 142           ((cond-true? (EVAL cnd env)) (tco-loop thn env))
 143           (else (if (null? els) nil (tco-loop (car els) env)))))
 144         (('fn* params body ...) ; function definition
 145          (make-anonymous-func
 146           (lambda args
 147             (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
 148               (cond
 149                ((null? body)
 150                 (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" ast)))
 151                ((= 1 (length body)) (tco-loop (car body) nenv))
 152                (else
 153                 (let ((mexpr (take body (1- (length body))))
 154                       (tail-call (car (take-right body 1))))
 155                   (eval_seq mexpr nenv)
 156                   (tco-loop tail-call nenv))))))))
 157         (('try* A ('catch* B C))
 158          (catch
 159           #t
 160           (lambda () (EVAL A env))
 161           (lambda (k . e)
 162             (case k
 163               ((mal-error)
 164                (let ((nenv (make-Env #:outer env #:binds (list B) #:exprs e)))
 165                  (EVAL C nenv)))
 166               ;; TODO: add backtrace
 167               (else (print-exception (current-output-port) #f k e))))))
 168         (else (eval_func ast env))))))
 169
 170 (define (EVAL-string str)
 171   (EVAL (read_str str) *toplevel*))
 172
 173 (define (PRINT exp)
 174   (and (not (eof-object? exp))
 175        (format #t "~a~%" (pr_str exp #t))))
 176
 177 (define (LOOP continue?)
 178   (and continue? (REPL)))
 179
 180 (define (REPL)
 181   (LOOP
 182    (catch #t
 183           (lambda () (PRINT (EVAL (READ) *toplevel*)))
 184           (lambda (k . e)
 185             (case k
 186               ((mal-error)
 187                (if (string=? (car e) "blank line")
 188                    (display "")
 189                    (format #t "Error: ~a~%" (car e))))
 190               (else (print-exception (current-output-port) #f k e)))))))
 191
 192 ;; initialization
 193 ((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*))))
 194 ((*toplevel* 'set) 'throw (make-func (lambda (val) (throw 'mal-error val))))
 195 ((*toplevel* 'set) '*ARGV* '())
 196 (EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 197 (EVAL-string "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))")
 198 (EVAL-string "(def! *gensym-counter* (atom 0))")
 199 (EVAL-string "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))")
 200 (EVAL-string "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))")
 201 (EVAL-string "(def! *host-language* \"guile\")")
 202
 203 (let ((args (cdr (command-line))))
 204   (cond
 205    ((> (length args) 0)
 206     ((*toplevel* 'set) '*ARGV* (cdr args))
 207     (EVAL-string (string-append "(load-file \"" (car args) "\")")))
 208    (else
 209     (EVAL-string "(println (str \"Mal (\" *host-language* \")\"))")
 210     (REPL))))