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

;;  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)
Commit	Line	Data
98cd78e4 NG	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 (lambda (x) (make-callable #f x)) e))))
	22
	23	(define (READ)
	24	(read_str (readline "user> ")))
	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	(hash-for-each (lambda (k v) (hash-set! ht k (_eval v))) ht)
	35	ht)
	36	(else ast)))
	37
	38	(define (eval_func ast env)
	39	(define (_eval o) (EVAL o env))
	40	(define (func? x) (and=> (env-check x env) is-func?))
	41	;;(format #t "AAA: ~a~%" (func? (car ast)))
	42	(cond
	43	((func? (car ast))
	44	=> (lambda (c)
	45	(callable-apply c (map _eval (cdr ast)))))
	46	(else (throw 'mal-error (format #f "'~a' not found" (car ast))))))
	47
	48	(define (eval_seq ast env)
	49	(cond
	50	((null? ast) nil)
	51	((null? (cdr ast)) (EVAL (car ast) env))
	52	(else
	53	(EVAL (car ast) env)
	54	(eval_seq (cdr ast) env))))
	55
	56	(define (is_macro_call ast env)
	57	(and (list? ast)
	58	(and=> (env-check (car ast) env) is-macro?)))
	59
	60	(define (_macroexpand ast env)
	61	(cond
	62	((is_macro_call ast env)
	63	=> (lambda (c)
	64	;;(format #t "AAA: ~a, ~a~%" ast (_macroexpand (callable-apply c (cdr ast)) env))
65	;;(format #t "BBB: ~a~%" (_macroexpand (callable-apply c (cdr ast)) env))
66	;; NOTE: Macros are normal-order, so we shouldn't eval args here.
67	;; Or it's applicable-order.
68	(_macroexpand (callable-apply c (cdr ast)) env)))
69	(else ast)))
70
71	(define (EVAL ast env)
72	(define (%unzip2 kvs)
73	(let lp((next kvs) (k '()) (v '()))
74	(cond
75	;; NOTE: reverse is very important here!
76	((null? next) (values (reverse k) (reverse v)))
77	((null? (cdr next)) (throw 'mal-error "let*: Invalid binding form" kvs))
78	(else (lp (cddr next) (cons (car next) k) (cons (cadr next) v))))))
79	(define (_quasiquote obj)
80	(match obj
81	((('unquote unq) rest ...) `(cons ,unq ,(_quasiquote rest)))
82	(('unquote unq) unq)
83	((('splice-unquote unqsp) rest ...) `(concat ,unqsp ,(_quasiquote rest)))
84	((head rest ...) (list 'cons (_quasiquote head) (_quasiquote rest)))
85	(else `(quote ,obj))))
86	;; NOTE: I wish I can use (while #t ...) for that, but this is not Lispy, which means
87	;; it'll bring some trouble in control flow. We have to use continuations to return
88	;; and use non-standard `break' feature. In a word, not elegant at all.
89	;; The named let loop is natural for Scheme, but it looks a bit cheating. But NO!
90	;; Such kind of loop is actually `while loop' in Scheme, I don't take advantage of
91	;; TCO in Scheme to implement TCO, but it's the same principle with normal loop.
92	;; If you're Lispy enough, there's no recursive at all while you saw named let loop.
93	(let tco-loop((ast ast) (env env)) ; expand as possible
94	;;(format #t "CCC: ~a === ~a~%" ast (_macroexpand ast env))
95	(let ((ast (_macroexpand ast env)))
96	(match ast
97	((? non-list?) (eval_ast ast env))
98	(('defmacro! k v)
99	(let ((c (EVAL v env)))
100	(callable-is_macro-set! c #t)
101	((env 'set) k c)))
102	(('macroexpand obj) (_macroexpand obj env))
103	(('quote obj) obj)
104	(('quasiquote obj) (EVAL (_quasiquote (->list obj)) env))
105	(('def! k v) ((env 'set) k (EVAL v env)))
106	(('let* kvs body)
107	(let* ((new-env (make-Env #:outer env))
108	(setter (lambda (k v) ((new-env 'set) k (EVAL v new-env)))))
109	(receive (keys vals) (%unzip2 (->list kvs))
110	(for-each setter keys vals))
111	(tco-loop body new-env)))
112	(('do rest ...)
113	(cond
114	((null? rest) (throw 'mal-error "do: Invalid form!" rest))
115	((= 1 (length rest)) (tco-loop (car rest) env))
116	(else
117	(let ((mexpr (take rest (1- (length rest))))
118	(tail-call (car (take-right rest 1))))
119	(eval_seq mexpr env)
120	(tco-loop tail-call env)))))
121	(('if cnd thn els ...)
122	(cond
123	((and (not (null? els)) (not (null? (cdr els))))
124	;; Invalid `if' form
125	(throw 'mal-error "if: failed to match any pattern in form " ast))
126	((cond-true? (EVAL cnd env)) (tco-loop thn env))
127	(else (if (null? els) nil (tco-loop (car els) env)))))
128	(('fn* params body ...) ; function definition
129	(make-func
130	(lambda args
131	(let ((nenv (make-Env #:outer env #:binds (->list params) #:exprs args)))
132	(cond
133	((null? body) (throw 'mal-error "fn*: bad lambda in form " ast))
134	((= 1 (length body)) (tco-loop (car body) nenv))
135	(else
136	(let ((mexpr (take body (1- (length body))))
137	(tail-call (car (take-right body 1))))
138	(eval_seq mexpr nenv)
139	(tco-loop tail-call nenv))))))))
140	(('try* A ('catch* B C))
141	(catch
142	#t
143	(lambda () (EVAL A env))
144	(lambda e
145	(let ((nenv (make-Env #:outer env #:binds (list B) #:exprs (cdr e))))
146	(EVAL C nenv)))))
147	(else (eval_func ast env))))))
148
149	(define (EVAL-string str)
150	(EVAL (read_str str) toplevel))
151
152	(define (PRINT exp)
153	(and (not (eof-object? exp))
154	;;(add-history str)
155	(format #t "~a~%" (pr_str exp #t))))
156
157	(define (LOOP continue?)
158	(and continue? (REPL)))
159
160	(define (REPL)
161	(LOOP
162	(catch 'mal-error
163	(lambda () (PRINT (EVAL (READ) toplevel)))
164	(lambda (k . e)
165	(if (string=? (car e) "blank line")
166	(display "")
167	(format #t "Error: ~a~%" (car e)))))))
168
169	;; initialization
170	((toplevel 'set) 'eval (make-func (lambda (ast) (EVAL ast toplevel))))
171	((toplevel 'set) 'throw (make-func (lambda (val) (throw 'mal-error val))))
172	((toplevel 'set) 'ARGV '())
173	(EVAL-string "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
174	(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)))))))")
175	(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))))))))")
176	(REPL)