guile step7 works

guile/core.scm

@@ -14,8 +14,10 @@
 ;;  along with this program.  If not, see <http://www.gnu.org/licenses/>.
 
 (library (core)
-  (export core.ns)
-  (import (guile) (rnrs) (types) (reader) (printer)))
+  (export core.ns ->list)
+  (import (guile) (rnrs) (types) (reader) (printer) (ice-9 match)))
+
+(define (->list o) ((if (vector? o) vector->list identity) o))
 
 (define (_count obj)
   (cond
@@ -27,8 +29,7 @@
 
 ;; Well, strange spec...
 (define (_equal? o1 o2)
-  (define (-> o) (if (vector? o) (vector->list o) o))
-  (equal? (-> o1) (-> o2)))
+  (equal? (->list o1) (->list o2)))
 
 (define (pr-str . args)
   (define (pr x) (pr_str x #t))
@@ -52,6 +53,12 @@
     (throw 'mal-error "File/dir doesn't exist" filename))
   (call-with-input-file filename get-string-all))
 
+(define (_cons x y)
+  (cons x (->list y)))
+
+(define (concat . args)
+  (apply append (map ->list args)))
+
 (define *primitives*
   `((list        ,list)
     (list?       ,list?)
@@ -73,6 +80,8 @@
     (println     ,println)
     (read-string ,read_str)
     (slurp       ,slurp)
+    (cons        ,_cons)
+    (concat      ,concat)
 
 ))
 

guile/step7_quote.scm

@@ -0,0 +1,144 @@
+;;  Copyright (C) 2015
+;;      "Mu Lei" known as "NalaGinrut" <NalaGinrut@gmail.com>
+;;  This file is free software: you can redistribute it and/or modify
+;;  it under the terms of the GNU General Public License as published by
+;;  the Free Software Foundation, either version 3 of the License, or
+;;  (at your option) any later version.
+
+;;  This file is distributed in the hope that it will be useful,
+;;  but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;  GNU General Public License for more details.
+
+;;  You should have received a copy of the GNU General Public License
+;;  along with this program.  If not, see <http://www.gnu.org/licenses/>.
+
+(import (readline) (reader) (printer) (ice-9 match) (srfi srfi-43)
+        (srfi srfi-1) (ice-9 receive) (env) (core) (types))
+
+(define *toplevel*
+  (receive (b e) (unzip2 core.ns)
+    (make-Env #:binds b #:exprs e)))
+
+(define (READ)
+  (read_str (readline "user> ")))
+
+(define (eval_ast ast env)
+  (define (_eval x) (EVAL x env))
+  (match ast
+    ((? _nil? obj) obj)
+    ((? symbol? sym)
+     (or ((env 'get) sym)
+         ;; delay eval is good design here
+         (lambda _ (throw 'mal-error (format #f "procedure '~a' not found" sym)))))
+    ((? list? lst) (map _eval lst))
+    ((? vector? vec) (vector-map (lambda (i x) (_eval x)) vec))
+    ((? hash-table? ht)
+     (hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht)
+     ht)
+    (else ast)))
+
+(define (eval_func ast env)
+  (define expr (eval_ast ast env))
+  (match expr
+    (((? procedure? proc) args ...)
+     (apply proc args))
+    (else 'mal-error (format #f "'~a' is not a valid form to apply!" expr))))
+
+(define (eval_seq ast env)
+  (cond
+   ((null? ast) nil)
+   ((null? (cdr ast)) (EVAL (car ast) env))
+   (else
+    (EVAL (car ast) env)
+    (eval_seq (cdr ast) env))))
+
+(define (EVAL ast env)
+  (define (%unzip2 kvs)
+    (let lp((next kvs) (k '()) (v '()))
+      (cond
+       ;; NOTE: reverse is very important here!
+       ((null? next) (values (reverse k) (reverse v)))
+       ((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs)) 
+       (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
+  (define (_quasiquote obj e)
+    (match obj
+      (((? pair? p) ('unquote unq) rest ...) `(,@p ,(EVAL unq e) ,@rest))
+      ((x ('unquote unq) rest ...) `(,x ,(EVAL unq e) ,@rest))
+      (('unquote unq) (EVAL unq e))
+      (((? pair? p) ('splice-unquote unqsp) rest ...) `(,@p ,@(EVAL unqsp e) ,@rest))
+      ((x ('splice-unquote unqsp) rest ...) `(,x ,@(EVAL unqsp e) ,@rest))
+      (('splice-unquote unqsp) (EVAL unqsp e))
+      (else obj)))
+  ;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means
+  ;;       it'll bring some trouble in control flow. We have to use continuations to return
+  ;;       and use non-standard `break' feature. In a word, not elegant at all.
+  ;;       The named let loop is natural for Scheme, but it looks a bit cheating. But NO!
+  ;;       Such kind of loop is actually `while loop' in Scheme, I don't take advantage of
+  ;;       TCO in Scheme to implement TCO, but it's the same principle with normal loop.
+  ;;       If you're Lispy enough, there's no recursive at all while you saw named let loop.
+  (let tco-loop((ast ast) (env env))
+    (match ast
+      (('quote obj) obj)
+      (('quasiquote obj) (_quasiquote (->list obj) env))
+      (('def! k v) ((env 'set) k (EVAL v env)))
+      (('let* kvs body)
+       (let* ((new-env (make-Env #:outer env))
+              (setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
+         (receive (keys vals) (%unzip2 (->list kvs))
+                  (for-each setter keys vals))
+         (tco-loop body new-env)))
+       (('do rest ...)
+        (cond
+         ((null? rest) (throw 'mal-error "do: Invalid form!" rest))
+         ((= 1 (length rest)) (tco-loop (car rest) env))
+         (else
+          (let ((mexpr (take rest (1- (length rest))))
+                (tail-call (car (take-right rest 1))))
+            (eval_seq mexpr env)
+            (tco-loop tail-call env)))))
+       (('if cnd thn els ...)
+        (cond
+         ((and (not (null? els)) (not (null? (cdr els))))
+          ;; Invalid `if' form
+          (throw 'mal-error "if: failed to match any pattern in form " ast))
+         ((cond-true? (EVAL cnd env)) (tco-loop thn env))
+         (else (if (null? els) nil (tco-loop (car els) env)))))
+       (('fn* params body ...) ; function definition
+        (lambda args
+          (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
+            (cond
+             ((null? body) (throw 'mal-error "fn*: bad lambda in form " ast))
+             ((= 1 (length body)) (tco-loop (car body) nenv))
+             (else
+              (let ((mexpr (take body (1- (length body))))
+                    (tail-call (car (take-right body 1))))
+                (eval_seq mexpr nenv)
+                (tco-loop tail-call nenv)))))))
+       ((? list?) (eval_func ast env)) ; function calling
+       (else (eval_ast ast env)))))
+
+(define (EVAL-string str)
+  (EVAL (read_str str) *toplevel*))
+
+(define (PRINT exp)
+  (and (not (eof-object? exp))
+       ;;(add-history str)
+       (format #t "~a~%" (pr_str exp #t))))
+
+(define (LOOP continue?)
+  (and continue? (REPL)))
+
+(define (REPL)
+  (LOOP
+   (catch 'mal-error
+          (lambda () (PRINT (EVAL (READ) *toplevel*)))
+          (lambda (k . e)
+            (format #t "Error: ~a~%" (car e))))))
+
+;; initialization
+((*toplevel* 'set) 'eval (lambda (ast) (EVAL ast *toplevel*)))
+((*toplevel* 'set) '*ARGV* '())
+(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
+
+(REPL)