guile step9 works

guile/core.scm

@@ -41,11 +41,11 @@
 
 (define (prn . args)
   (format #t "~a~%" (apply pr-str args))
-  nil)  
+  nil)
 
 (define (println . args)
   (define (pr x) (pr_str x #f))
-  (format #t "~{~a~^ ~}~%" (map pr args) " ")
+  (format #t "~{~a~^ ~}~%" (map pr args))
   nil)
 
 (define (slurp filename)
@@ -77,6 +77,64 @@
       '()
       (cdr ll)))
 
+(define (_map f lst) (map (callable-closure f) (->list lst)))
+
+(define (_apply f . args)
+  (define ll
+    (let lp((next (->list args)) (ret '()))
+      (cond
+       ((null? next) (reverse ret))
+       (else
+        (let ((n (->list (car next))))
+          (lp (cdr next) (if (list? n)
+                             (append (reverse n) ret)
+                             (cons n ret))))))))
+    (apply (callable-closure f) ll))
+
+(define (->symbol x)
+  ((if (symbol? x) identity string->symbol) x))
+
+(define (->keyword x)
+  ((if (_keyword? x) identity string->keyword) x))
+
+(define* (list->hash-map lst #:optional (ht (make-hash-table)))
+  (cond
+   ((null? lst) ht)
+   (else
+    (let lp((next lst))
+      (cond
+       ((null? next) ht)
+       (else
+        (when (null? (cdr next))
+          (throw 'mal-error
+                 (format #f "hash-map: '~a' lack of value" (car next))))
+        (let ((k (car next))
+              (v (cadr next)))
+          (hash-set! ht k v)
+          (lp (cddr next)))))))))
+
+(define (_hash-map . lst) (list->hash-map lst))
+
+(define (_assoc ht . lst) (list->hash-map lst (hash-table-clone ht)))
+
+(define (_get ht k)
+  (if (_nil? ht)
+      nil
+      (hash-ref ht k nil)))
+
+(define (_dissoc ht . lst)
+  (define ht2 (hash-table-clone ht))
+  (for-each (lambda (k) (hash-remove! ht2 k)) lst)
+  ht2)
+
+(define (_keys ht) (hash-map->list (lambda (k v) k) ht))
+
+(define (_vals ht) (hash-map->list (lambda (k v) v) ht))
+
+(define (_contains? ht k) (if (hash-ref ht k) #t #f))
+
+(define (_sequential? o) (or (list? o) (vector? o)))
+
 (define *primitives*
   `((list        ,list)
     (list?       ,list?)
@@ -103,7 +161,26 @@
     (nth         ,_nth)
     (first       ,_first)
     (rest        ,_rest)
-
+    (map         ,_map)
+    (apply       ,_apply)
+    (nil?        ,_nil?)
+    (true?       ,(lambda (x) (eq? x #t)))
+    (false?      ,(lambda (x) (eq? x #f)))
+    (symbol?     ,symbol?)
+    (symbol      ,->symbol)
+    (keyword     ,->keyword)
+    (keyword?    ,_keyword?)
+    (vector?     ,vector?)
+    (vector      ,vector)
+    (hash-map    ,_hash-map)
+    (map?        ,hash-table?)
+    (assoc       ,_assoc)
+    (get         ,_get)
+    (dissoc      ,_dissoc)
+    (keys        ,_keys)
+    (vals        ,_vals)
+    (contains?   ,_contains?)
+    (sequential? ,_sequential?)
 ))
 
 ;; Well, we have to rename it to this strange name...

guile/printer.scm

@@ -21,13 +21,14 @@
   (call-with-output-string
    (lambda (port)
      (display "{" port)
-     (for-each
-      (lambda (h)
-        (format port "~a ~a" (car h) (cdr h)))
-      (hash-map->list
-       (lambda (k v)
-         (cons (p k) (p v)))
-       hm))
+     (display
+      (string-join
+       (hash-map->list
+        (lambda (k v)
+          (format #f "~a ~a" (pr_str k #t) v))
+        hm)
+       " ")
+      port)
      (display "}" port))))
 
 (define (pr_str obj readable?)

guile/reader.scm

@@ -65,15 +65,17 @@
   (cond
    ((null? lst) ht)
    (else
-    (let lp((k (car lst)))
+    (let lp((next lst))
       (cond
-       ((null? k) ht)
+       ((null? next) ht)
        (else
-        (when (null? (cdr lst))
-              (throw 'mal-error "read_hashmap: lack of value" k))
-        (let ((v (cadr lst)))
+        (when (null? (cdr next))
+          (throw 'mal-error
+                 (format #f "read_hashmap: '~a' lack of value" (car next))))
+        (let ((k (car next))
+              (v (cadr next)))
           (hash-set! ht k v)
-          (lp (cddr lst)))))))))
+          (lp (cddr next)))))))))
 
 (define (read_atom reader)
   (define (->str s)
@@ -90,7 +92,7 @@
                (->str (match:substring m 1))
                (throw 'mal-error "expected '\"'"))))
      ((string-match "^:(.*)" token)
-      => (lambda (m) (_keyword (match:substring m 1))))
+      => (lambda (m) (string->keyword (match:substring m 1))))
      ((string=? "nil" token) nil)
      ((string=? "true" token) #t)
      ((string=? "false" token) #f)

guile/step2_eval.scm

@@ -42,7 +42,7 @@
   (match expr
     (((? procedure? proc) args ...)
      (apply proc args))
-    (else 'mal-error (format #f "'~a' is not a valid form to apply!" expr))))
+    (else (throw 'mal-error (format #f "'~a' not found" (car expr))))))
 
 (define (EVAL ast env)
   (match ast

guile/step3_env.scm

@@ -45,7 +45,7 @@
   (match expr
     (((? procedure? proc) args ...)
      (apply proc args))
-    (else 'mal-error (format #f "'~a' is not a valid form to apply!" expr))))
+    (else (throw 'mal-error (format #f "'~a' not found" (car expr))))))
 
 (define (EVAL ast env)
   (define (->list kvs) ((if (vector? kvs) vector->list identity) kvs))

guile/step4_if_fn_do.scm

@@ -40,7 +40,7 @@
   (match expr
     (((? procedure? proc) args ...)
      (apply proc args))
-    (else 'mal-error (format #f "'~a' is not a valid form to apply!" expr))))
+    (else (throw 'mal-error (format #f "'~a' not found" (car expr))))))
 
 (define (eval_seq ast env)
   (cond

guile/step5_tco.scm

@@ -40,7 +40,7 @@
   (match expr
     (((? procedure? proc) args ...)
      (apply proc args))
-    (else 'mal-error (format #f "'~a' is not a valid form to apply!" expr))))
+    (else (throw 'mal-error (format #f "'~a' not found" (car expr))))))
 
 (define (eval_seq ast env)
   (cond

guile/step6_file.scm

@@ -40,7 +40,7 @@
   (match expr
     (((? procedure? proc) args ...)
      (apply proc args))
-    (else 'mal-error (format #f "'~a' is not a valid form to apply!" expr))))
+    (else (throw 'mal-error (format #f "'~a' not found" (car expr))))))
 
 (define (eval_seq ast env)
   (cond

guile/step7_quote.scm

@@ -42,7 +42,7 @@
    ((func? (car ast))
     => (lambda (f)
          (apply (callable-closure f) (map _eval (cdr ast)))))
-   (else 'mal-error (format #f "'~a' is not a valid form to apply!" ast))))
+   (else (throw 'mal-error (format #f "'~a' not found" (car ast))))))
 
 (define (eval_seq ast env)
   (cond

guile/step8_macros.scm

@@ -42,7 +42,7 @@
    ((func? (car ast))
     => (lambda (c)
          (callable-apply c (map _eval (cdr ast)))))
-   (else 'mal-error (format #f "'~a' is not a valid form to apply!" ast))))
+   (else (throw 'mal-error (format #f "'~a' not found" (car ast))))))
 
 (define (eval_seq ast env)
   (cond
@@ -60,8 +60,6 @@
   (cond
    ((is_macro_call ast env)
     => (lambda (c)
-         ;;(format #t "AAA: ~a, ~a~%" ast (_macroexpand (callable-apply c (cdr ast)) env))
-         ;;(format #t "BBB: ~a~%" (_macroexpand (callable-apply c (cdr ast)) env))
          ;; NOTE: Macros are normal-order, so we shouldn't eval args here.
          ;;       Or it's applicable-order.
          (_macroexpand (callable-apply c (cdr ast)) env)))
@@ -90,7 +88,6 @@
   ;;       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)) ; expand as possible
-    ;;(format #t "CCC: ~a === ~a~%" ast (_macroexpand ast env))
     (let ((ast (_macroexpand ast env)))
       (match ast
         ((? non-list?) (eval_ast ast env))

guile/step9_try.scm

@@ -0,0 +1,176 @@
+;;  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 (map (lambda (x) (make-callable #f x)) 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) (env-has sym env))
+    ((? 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 (_eval o) (EVAL o env))
+  (define (func? x) (and=> (env-check x env) is-func?))
+  ;;(format #t "AAA: ~a~%" (func? (car ast)))
+  (cond
+   ((func? (car ast))
+    => (lambda (c)
+         (callable-apply c (map _eval (cdr ast)))))
+   (else (throw 'mal-error (format #f "'~a' not found" (car ast))))))
+
+(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 (is_macro_call ast env)
+  (and (list? ast)
+       (and=> (env-check (car ast) env) is-macro?)))
+
+(define (_macroexpand ast env)
+  (cond
+   ((is_macro_call ast env)
+    => (lambda (c)
+         ;;(format #t "AAA: ~a, ~a~%" ast (_macroexpand (callable-apply c (cdr ast)) env))
+         ;;(format #t "BBB: ~a~%" (_macroexpand (callable-apply c (cdr ast)) env))
+         ;; NOTE: Macros are normal-order, so we shouldn't eval args here.
+         ;;       Or it's applicable-order.
+         (_macroexpand (callable-apply c (cdr ast)) env)))
+   (else ast)))
+   
+(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)
+    (match obj
+      ((('unquote unq) rest ...) `(cons ,unq ,(_quasiquote rest)))
+      (('unquote unq) unq)
+      ((('splice-unquote unqsp) rest ...) `(concat ,unqsp ,(_quasiquote rest)))
+      ((head rest ...) (list 'cons (_quasiquote head) (_quasiquote rest)))
+      (else `(quote ,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)) ; expand as possible
+    ;;(format #t "CCC: ~a === ~a~%" ast (_macroexpand ast env))
+    (let ((ast (_macroexpand ast env)))
+      (match ast
+        ((? non-list?) (eval_ast ast env))
+        (('defmacro! k v)
+         (let ((c (EVAL v env)))
+           (callable-is_macro-set! c #t)
+           ((env 'set) k c)))
+        (('macroexpand obj) (_macroexpand obj env))
+        (('quote obj) obj)
+        (('quasiquote obj) (EVAL (_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
+         (make-func
+          (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))))))))
+        (('try* A ('catch* B C))
+         (catch
+          #t
+          (lambda () (EVAL A env))
+          (lambda e
+            (let ((nenv (make-Env #:outer env #:binds (list B) #:exprs (cdr e))))
+              (EVAL C nenv)))))
+        (else (eval_func 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)
+            (if (string=? (car e) "blank line")
+                (display "")
+                (format #t "Error: ~a~%" (car e)))))))
+
+;; initialization
+((*toplevel* 'set) 'eval (make-func (lambda (ast) (EVAL ast *toplevel*))))
+((*toplevel* 'set) 'throw (make-func (lambda (val) (throw 'mal-error val))))
+((*toplevel* 'set) '*ARGV* '())
+(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
+(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)))))))")
+(EVAL-string "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))")
+(REPL)

guile/types.scm

@@ -15,28 +15,32 @@
 
 (library (types)
   (export string-sub *eof* non-list?
-          _keyword _keyword?
+          string->keyword _keyword?
           nil _nil?
           cond-true?
           atom atom? atom-val atom-val-set!
           make-callable callable? callable-is_macro
           callable-is_macro-set! callable-closure
-          is-func? is-macro? make-func callable-apply)
+          is-func? is-macro? make-func callable-apply
+          hash-table-clone)
   (import (guile) (rnrs) (ice-9 regex) (ice-9 session)))
 
 (define (non-list? x) (not (list? x)))
 
+
 (define (string-sub str p1 p2)
   (regexp-substitute/global #f p1 str 'pre p2 'post))
 
 (define *eof* (call-with-input-string "" read))
 
-(define (_keyword? k)
-  (and (string? k) (string-match "^\u029e" k)))
-
-(define (_keyword str)
+(define (string->keyword str)
+  (when (not (string? str))
+    (throw 'mal-error (format #f "string->keyword: '~a' is not a string" str)))
   (string-append "\u029e" str))
 
+(define (_keyword? k)
+  (and (string? k) (if (string-match "^\u029e" k) #t #f)))
+
 (define nil 'nil)
 
 (define (_nil? obj) (eq? nil obj))
@@ -55,6 +59,7 @@
 
 (define (callable-apply c arglst)
   (define closure (callable-closure c))
+  ;;(format #t "ZZZ: ~a~%" `(apply ,closure ,arglst))
   (apply closure arglst))
 
 (define (callable-check c b)
@@ -62,5 +67,10 @@
        (eq? (callable-is_macro c) b)
        c))
 
-(define (is-func? sym) (callable-check sym #f))
-(define (is-macro? sym) (callable-check sym #t))
+(define (is-func? c) (callable-check c #f))
+(define (is-macro? c) (callable-check c #t))
+
+(define (hash-table-clone ht)
+  (define cht (make-hash-table))
+  (hash-for-each (lambda (k v) (hash-set! cht k v)) ht)
+  cht)