Merge pull request #358 from bjh21/bjh21-extra-tests

[jackhill/mal.git] / guile / step5_tco.scm

diff --git a/guile/step5_tco.scm b/guile/step5_tco.scm
index 5971aa4..909aa8b 100644 (file)
--- a/guile/step5_tco.scm
+++ b/guile/step5_tco.scm
@@ -17,11 +17,11 @@
         (srfi srfi-1) (ice-9 receive) (env) (core) (types))
 
 (define *toplevel*
-  (receive (b e) (unzip2 core.ns) 
-    (make-Env #:binds b #:exprs e)))
+  (receive (b e) (unzip2 core.ns)
+    (make-Env #:binds b #:exprs (map make-func e))))
 
-(define (READ)
-  (read_str (_readline "user> ")))
+(define (READ str)
+  (read_str str))
 
 (define (eval_ast ast env)
   (define (_eval x) (EVAL x env))
@@ -31,17 +31,11 @@
     ((? 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)
+     ;; NOTE: we must allocate a new hashmap here to avoid any side-effects, or
+     ;;       there'll be strange bugs!!!
+     (list->hash-map (hash-fold (lambda (k v p) (cons k (cons (_eval v) p))) '() ht)))
     (else ast)))
 
-(define (eval_func ast env)
-  (define expr (eval_ast ast env))
-  (match expr
-    (((? procedure? proc) args ...)
-     (apply proc args))
-    (else (throw 'mal-error (format #f "'~a' not found" (car expr))))))
-
 (define (eval_seq ast env)
   (cond
    ((null? ast) nil)
@@ -51,13 +45,13 @@
     (eval_seq (cdr ast) env))))
 
 (define (EVAL ast env)
-  (define (->list kvs) ((if (vector? kvs) vector->list identity) kvs))
   (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)) 
+       ((null? (cdr next))
+        (throw 'mal-error (format #f "let*: Invalid binding form '~a'" kvs))) 
        (else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
   ;; 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
@@ -68,6 +62,7 @@
   ;;       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
+      ((? non-list?) (eval_ast ast env))
       (() ast)
       (('def! k v) ((env 'set) k (EVAL v env)))
       (('let* kvs body)
@@ -78,7 +73,8 @@
          (tco-loop body new-env)))
        (('do rest ...)
         (cond
-         ((null? rest) (throw 'mal-error "do: Invalid form!" rest))
+         ((null? rest)
+          (throw 'mal-error (format #f "do: Invalid form! '~a'" rest)))
          ((= 1 (length rest)) (tco-loop (car rest) env))
          (else
           (let ((mexpr (take rest (1- (length rest))))
@@ -89,22 +85,29 @@
         (cond
          ((and (not (null? els)) (not (null? (cdr els))))
           ;; Invalid `if' form
-          (throw 'mal-error "if: failed to match any pattern in form " ast))
+          (throw 'mal-error
+                 (format #f "if: failed to match any pattern in form '~a'" 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)))))
+       (make-func
+         (lambda args
+           (let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
+             (cond
+              ((null? body)
+               (throw 'mal-error (format #f "fn*: bad lambda in form '~a'" 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))))))))
+       (else
+         (let ((el (map (lambda (x) (EVAL x env)) ast)))
+           (callable-apply (car el) (cdr el)))))))
+
+(define (EVAL-string str)
+  (EVAL (read_str str) *toplevel*))
 
 (define (PRINT exp)
   (and (not (eof-object? exp))
@@ -115,12 +118,17 @@
 
 (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)))))))
+   (let ((line (_readline "user> ")))
+     (cond
+       ((eof-object? line) #f)
+       ((string=? line "") #t)
+       (else
+         (catch 'mal-error
+                (lambda () (PRINT (EVAL (READ line) *toplevel*)))
+                (lambda (k . e)
+                  (format #t "Error: ~a~%" (pr_str (car e) #t)))))))))
+
+(EVAL-string "(def! not (fn* (x) (if x false true)))")
 
 ;; NOTE: we have to reduce stack size to pass step5 test
 ((@ (system vm vm) call-with-stack-overflow-handler)