[jackhill/mal.git] / picolisp / step9_try.l

(de load-relative (Path)
   (load (pack (car (file)) Path)) )

(load-relative "readline.l")
(load-relative "types.l")
(load-relative "reader.l")
(load-relative "printer.l")
(load-relative "env.l")
(load-relative "func.l")
(load-relative "core.l")

(de READ (String)
   (read-str String) )

(def '*ReplEnv (MAL-env NIL))
(for Bind *Ns (set> *ReplEnv (car Bind) (cdr Bind)))

(de is-pair (Ast)
   (and (memq (MAL-type Ast) '(list vector)) (MAL-value Ast) T) )

(de quasiquote (Ast)
   (if (not (is-pair Ast))
      (MAL-list (list (MAL-symbol 'quote) Ast))
      (let A (MAL-value Ast)
         (cond
            ((= (MAL-value (car A)) 'unquote)
             (cadr A) )
            ((and (is-pair (car A))
                (= (MAL-value (car (MAL-value (car A)))) 'splice-unquote) )
             (MAL-list (list (MAL-symbol 'concat)
                          (cadr (MAL-value (car A)))
                          (quasiquote (MAL-list (cdr A))) ) ) )
            (T
               (MAL-list (list (MAL-symbol 'cons)
                            (quasiquote (car A))
                            (quasiquote (MAL-list (cdr A))) ) ) ) ) ) ) )

(de is-macro-call (Ast Env)
   (when (= (MAL-type Ast) 'list)
      (let A0 (car (MAL-value Ast))
         (when (= (MAL-type A0) 'symbol)
            (let Value (find> Env (MAL-value A0))
               (and (isa '+Func Value) (get Value 'is-macro) T) ) ) ) ) )

(de macroexpand (Ast Env)
   (while (is-macro-call Ast Env)
      (let (Ast* (MAL-value Ast)
            Macro (get (find> Env (MAL-value (car Ast*))) 'fn)
            Args (cdr Ast*) )
         (setq Ast (apply (MAL-value Macro) Args)) ) )
   Ast )

(de EVAL (Ast Env)
   (catch 'done
      (while t
         (when (not (= (MAL-type Ast) 'list))
            (throw 'done (eval-ast Ast Env)) )
         (setq Ast (macroexpand Ast Env))
         (when (or (not (= (MAL-type Ast) 'list)) (not (MAL-value Ast)))
            (throw 'done (eval-ast Ast Env)) )
         (let (Ast* (MAL-value Ast)
               A0* (MAL-value (car Ast*))
               A1 (cadr Ast*)
               A1* (MAL-value A1)
               A2 (caddr Ast*)
               A3 (cadddr Ast*) )
            (cond
               ((= A0* 'def!)
                (throw 'done (set> Env A1* (EVAL A2 Env))) )
               ((= A0* 'quote)
                (throw 'done A1) )
               ((= A0* 'quasiquote)
                (setq Ast (quasiquote A1)) ) # TCO
               ((= A0* 'defmacro!)
                (let Form (EVAL A2 Env)
                   (put Form 'is-macro T)
                   (throw 'done (set> Env A1* Form)) ) )
               ((= A0* 'macroexpand)
                (throw 'done (macroexpand A1 Env)) )
               ((= A0* 'try*)
                (let Result (catch 'err (throw 'done (EVAL A1 Env)))
                   (if (isa '+MALError Result)
                      (let A (MAL-value A2)
                         (if (and (= (MAL-type A2) 'list)
                                (= (MAL-value (car A)) 'catch*) )
                            (let (Bind (MAL-value (cadr A))
                                  Exc (MAL-value Result)
                                  Form (caddr A)
                                  Env* (MAL-env Env (list Bind) (list Exc)) )
                               (throw 'done (EVAL Form Env*)) )
                            (throw 'err Result) ) )
                      (throw 'done Result) ) ) )
               ((= A0* 'let*)
                (let Env* (MAL-env Env)
                   (for (Bindings A1* Bindings)
                      (let (Key (MAL-value (pop 'Bindings))
                            Value (EVAL (pop 'Bindings) Env*) )
                         (set> Env* Key Value) ) )
                   (setq Env Env* Ast A2) ) ) # TCO
               ((= A0* 'do)
                (mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*)))
                (setq Ast (last Ast*)) ) # TCO
               ((= A0* 'if)
                (if (not (memq (MAL-type (EVAL A1 Env)) '(nil false)))
                   (setq Ast A2) # TCO
                   (if A3
                      (setq Ast A3) # TCO
                      (throw 'done *MAL-nil) ) ) )
               ((= A0* 'fn*)
                (let (Binds (mapcar MAL-value A1*)
                      Body A2
                      Fn (MAL-fn
                            (curry (Env Binds Body) @
                               (let Env* (MAL-env Env Binds (rest))
                                  (EVAL Body Env*) ) ) ) )
                   (throw 'done (MAL-func Env Body Binds Fn)) ) )
               (T
                  (let (Ast* (MAL-value (eval-ast Ast Env))
                        Fn (car Ast*)
                        Args (cdr Ast*) )
                     (if (isa '+MALFn Fn)
                        (throw 'done (apply (MAL-value Fn) Args))
                        (let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args)
                           (setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) ) ) )

(de eval-ast (Ast Env)
   (let Value (MAL-value Ast)
      (case (MAL-type Ast)
         (symbol (get> Env Value))
         (list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value)))
         (vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value)))
         (map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value)))
         (T Ast) ) ) )

(set> *ReplEnv 'eval (MAL-fn (curry (*ReplEnv) (Form) (EVAL Form *ReplEnv))))
(set> *ReplEnv '*ARGV* (MAL-list (mapcar MAL-string (cdr (argv)))))

(de PRINT (Ast)
   (pr-str Ast T) )

(de rep (String)
   (PRINT (EVAL (READ String) *ReplEnv)) )

(rep "(def! not (fn* (a) (if a false true)))")
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))")
(rep "(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)))))))")

(load-history ".mal_history")

(if (argv)
   (rep (pack "(load-file \"" (car (argv)) "\")"))
   (use Input
      (until (=0 (setq Input (readline "user> ")))
         (let Output (catch 'err (rep Input))
            (if (isa '+MALError Output)
               (let Message (MAL-value Output)
                  (unless (= (MAL-value Message) "end of token stream")
                     (prinl "[error] " (pr-str Message)) ) )
               (prinl Output) ) ) ) ) )

(prinl)
(bye)
Commit	Line	Data
cc494944 VS	1	(de load-relative (Path)
	2	(load (pack (car (file)) Path)) )
	3
	4	(load-relative "readline.l")
	5	(load-relative "types.l")
	6	(load-relative "reader.l")
	7	(load-relative "printer.l")
	8	(load-relative "env.l")
	9	(load-relative "func.l")
	10	(load-relative "core.l")
	11
	12	(de READ (String)
	13	(read-str String) )
	14
	15	(def '*ReplEnv (MAL-env NIL))
	16	(for Bind Ns (set> ReplEnv (car Bind) (cdr Bind)))
	17
	18	(de is-pair (Ast)
	19	(and (memq (MAL-type Ast) '(list vector)) (MAL-value Ast) T) )
	20
	21	(de quasiquote (Ast)
	22	(if (not (is-pair Ast))
	23	(MAL-list (list (MAL-symbol 'quote) Ast))
	24	(let A (MAL-value Ast)
	25	(cond
	26	((= (MAL-value (car A)) 'unquote)
	27	(cadr A) )
	28	((and (is-pair (car A))
	29	(= (MAL-value (car (MAL-value (car A)))) 'splice-unquote) )
	30	(MAL-list (list (MAL-symbol 'concat)
	31	(cadr (MAL-value (car A)))
	32	(quasiquote (MAL-list (cdr A))) ) ) )
	33	(T
	34	(MAL-list (list (MAL-symbol 'cons)
	35	(quasiquote (car A))
	36	(quasiquote (MAL-list (cdr A))) ) ) ) ) ) ) )
	37
	38	(de is-macro-call (Ast Env)
	39	(when (= (MAL-type Ast) 'list)
	40	(let A0 (car (MAL-value Ast))
	41	(when (= (MAL-type A0) 'symbol)
	42	(let Value (find> Env (MAL-value A0))
	43	(and (isa '+Func Value) (get Value 'is-macro) T) ) ) ) ) )
	44
	45	(de macroexpand (Ast Env)
	46	(while (is-macro-call Ast Env)
	47	(let (Ast* (MAL-value Ast)
	48	Macro (get (find> Env (MAL-value (car Ast*))) 'fn)
	49	Args (cdr Ast*) )
	50	(setq Ast (apply (MAL-value Macro) Args)) ) )
	51	Ast )
	52
	53	(de EVAL (Ast Env)
	54	(catch 'done
	55	(while t
	56	(when (not (= (MAL-type Ast) 'list))
	57	(throw 'done (eval-ast Ast Env)) )
	58	(setq Ast (macroexpand Ast Env))
	59	(when (or (not (= (MAL-type Ast) 'list)) (not (MAL-value Ast)))
	60	(throw 'done (eval-ast Ast Env)) )
	61	(let (Ast* (MAL-value Ast)
	62	A0* (MAL-value (car Ast*))
	63	A1 (cadr Ast*)
	64	A1* (MAL-value A1)
65	A2 (caddr Ast*)
66	A3 (cadddr Ast*) )
67	(cond
68	((= A0* 'def!)
69	(throw 'done (set> Env A1* (EVAL A2 Env))) )
70	((= A0* 'quote)
71	(throw 'done A1) )
72	((= A0* 'quasiquote)
73	(setq Ast (quasiquote A1)) ) # TCO
74	((= A0* 'defmacro!)
75	(let Form (EVAL A2 Env)
76	(put Form 'is-macro T)
77	(throw 'done (set> Env A1* Form)) ) )
78	((= A0* 'macroexpand)
79	(throw 'done (macroexpand A1 Env)) )
80	((= A0* 'try*)
81	(let Result (catch 'err (throw 'done (EVAL A1 Env)))
82	(if (isa '+MALError Result)
83	(let A (MAL-value A2)
84	(if (and (= (MAL-type A2) 'list)
85	(= (MAL-value (car A)) 'catch*) )
86	(let (Bind (MAL-value (cadr A))
87	Exc (MAL-value Result)
88	Form (caddr A)
89	Env* (MAL-env Env (list Bind) (list Exc)) )
90	(throw 'done (EVAL Form Env*)) )
91	(throw 'err Result) ) )
92	(throw 'done Result) ) ) )
93	((= A0* 'let*)
94	(let Env* (MAL-env Env)
95	(for (Bindings A1* Bindings)
96	(let (Key (MAL-value (pop 'Bindings))
97	Value (EVAL (pop 'Bindings) Env*) )
98	(set> Env* Key Value) ) )
99	(setq Env Env* Ast A2) ) ) # TCO
100	((= A0* 'do)
101	(mapc '((Form) (EVAL Form Env)) (head -1 (cdr Ast*)))
102	(setq Ast (last Ast*)) ) # TCO
103	((= A0* 'if)
104	(if (not (memq (MAL-type (EVAL A1 Env)) '(nil false)))
105	(setq Ast A2) # TCO
106	(if A3
107	(setq Ast A3) # TCO
108	(throw 'done *MAL-nil) ) ) )
109	((= A0* 'fn*)
110	(let (Binds (mapcar MAL-value A1*)
111	Body A2
112	Fn (MAL-fn
113	(curry (Env Binds Body) @
114	(let Env* (MAL-env Env Binds (rest))
115	(EVAL Body Env*) ) ) ) )
116	(throw 'done (MAL-func Env Body Binds Fn)) ) )
117	(T
118	(let (Ast* (MAL-value (eval-ast Ast Env))
119	Fn (car Ast*)
120	Args (cdr Ast*) )
121	(if (isa '+MALFn Fn)
122	(throw 'done (apply (MAL-value Fn) Args))
123	(let Env* (MAL-env (get Fn 'env) (get Fn 'params) Args)
124	(setq Ast (get Fn 'ast) Env Env*) ) ) ) ) ) ) ) ) )
125
126	(de eval-ast (Ast Env)
127	(let Value (MAL-value Ast)
128	(case (MAL-type Ast)
129	(symbol (get> Env Value))
130	(list (MAL-list (mapcar '((Form) (EVAL Form Env)) Value)))
131	(vector (MAL-vector (mapcar '((Form) (EVAL Form Env)) Value)))
132	(map (MAL-map (mapcar '((Form) (EVAL Form Env)) Value)))
133	(T Ast) ) ) )
134
135	(set> ReplEnv 'eval (MAL-fn (curry (ReplEnv) (Form) (EVAL Form *ReplEnv))))
fbe5bd7a	136	(set> ReplEnv 'ARGV* (MAL-list (mapcar MAL-string (cdr (argv)))))
cc494944 VS	137
	138	(de PRINT (Ast)
	139	(pr-str Ast T) )
	140
	141	(de rep (String)
	142	(PRINT (EVAL (READ String) *ReplEnv)) )
	143
	144	(rep "(def! not (fn* (a) (if a false true)))")
e6d41de4	145	(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \"\nnil)\")))))")
cc494944	146	(rep "(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)))))))")
cc494944 VS	147
	148	(load-history ".mal_history")
	149
	150	(if (argv)
fbe5bd7a	151	(rep (pack "(load-file \"" (car (argv)) "\")"))
cc494944 VS	152	(use Input
	153	(until (=0 (setq Input (readline "user> ")))
	154	(let Output (catch 'err (rep Input))
	155	(if (isa '+MALError Output)
	156	(let Message (MAL-value Output)
	157	(unless (= (MAL-value Message) "end of token stream")
	158	(prinl "[error] " (pr-str Message)) ) )
	159	(prinl Output) ) ) ) ) )
	160
	161	(prinl)
	162	(bye)