[jackhill/mal.git] / racket / stepA_mal.rkt

#!/usr/bin/env racket
#lang racket

(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt"
         "env.rkt" "core.rkt")

;; read
(define (READ str)
  (read_str str))

;; eval
(define (is-pair x)
  (and (_sequential? x) (> (_count x) 0)))

(define (quasiquote ast)
  (cond
    [(not (is-pair ast))
     (list 'quote ast)]

    [(equal? 'unquote (_nth ast 0))
     (_nth ast 1)]

    [(and (is-pair (_nth ast 0))
          (equal? 'splice-unquote (_nth (_nth ast 0) 0)))
     (list 'concat (_nth (_nth ast 0) 1) (quasiquote (_rest ast)))]

    [else
     (list 'cons (quasiquote (_nth ast 0)) (quasiquote (_rest ast)))]))

(define (macro? ast env)
  (and (list? ast)
       (symbol? (first ast))
       (not (equal? null (send env find (first ast))))
       (let ([fn (send env get (first ast))])
         (and (malfunc? fn) (malfunc-macro? fn)))))

(define (macroexpand ast env)
  (if (macro? ast env)
    (let ([mac (malfunc-fn (send env get (first ast)))])
      (macroexpand (apply mac (rest ast)) env))
    ast))

(define (eval-ast ast env)
  (cond
    [(symbol? ast) (send env get ast)]
    [(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)]
    [(hash? ast) (make-hash
                  (dict-map ast (lambda (k v) (cons k (EVAL v env)))))]
    [else ast]))

(define (EVAL ast env)
  ;(printf "~a~n" (pr_str ast true))
  (if (not (list? ast))
    (eval-ast ast env)

    (let ([ast (macroexpand ast env)])
      (if (not (list? ast))
        (eval-ast ast env)
        (let ([a0 (_nth ast 0)])
          (cond
            [(eq? 'def! a0)
             (send env set (_nth ast 1) (EVAL (_nth ast 2) env))]
            [(eq? 'let* a0)
             (let ([let-env (new Env% [outer env] [binds null] [exprs null])])
               (_map (lambda (b_e)
                       (send let-env set (_first b_e)
                             (EVAL (_nth b_e 1) let-env)))
                    (_partition 2 (_to_list (_nth ast 1))))
               (EVAL (_nth ast 2) let-env))]
            [(eq? 'quote a0)
             (_nth ast 1)]
            [(eq? 'quasiquote a0)
             (EVAL (quasiquote (_nth ast 1)) env)]
            [(eq? 'defmacro! a0)
             (let* ([func (EVAL (_nth ast 2) env)]
                    [mac (struct-copy malfunc func [macro? #t])])
               (send env set (_nth ast 1) mac))]
            [(eq? 'macroexpand a0)
             (macroexpand (_nth ast 1) env)]
            [(eq? 'try* a0)
             (if (eq? 'catch* (_nth (_nth ast 2) 0))
               (let ([efn (lambda (exc)
                            (EVAL (_nth (_nth ast 2) 2)
                                  (new Env%
                                       [outer env]
                                       [binds (list (_nth (_nth ast 2) 1))]
                                       [exprs (list exc)])))])
                 (with-handlers
                   ([mal-exn?  (lambda (exc) (efn (mal-exn-val exc)))]
                    [string?   (lambda (exc) (efn exc))]
                    [exn:fail? (lambda (exc) (efn (format "~a" exc)))])
                   (EVAL (_nth ast 1) env)))
               (EVAL (_nth ast 1)))]
            [(eq? 'do a0)
             (eval-ast (drop (drop-right ast 1) 1) env)
             (EVAL (last ast) env)]
            [(eq? 'if a0)
             (let ([cnd (EVAL (_nth ast 1) env)])
               (if (or (eq? cnd nil) (eq? cnd #f))
                 (if (> (length ast) 3)
                   (EVAL (_nth ast 3) env)
                   nil)
                 (EVAL (_nth ast 2) env)))]
            [(eq? 'fn* a0)
             (malfunc
               (lambda args (EVAL (_nth ast 2)
                                  (new Env% [outer env]
                                            [binds (_nth ast 1)]
                                            [exprs args])))
               (_nth ast 2) env (_nth ast 1) #f nil)]
            [else (let* ([el (eval-ast ast env)]
                         [f (first el)]
                         [args (rest el)])
                    (if (malfunc? f)
                      (EVAL (malfunc-ast f)
                            (new Env%
                                 [outer (malfunc-env f)]
                                 [binds (malfunc-params f)]
                                 [exprs args]))
                      (apply f args)))]))))))

;; print
(define (PRINT exp)
  (pr_str exp true))

;; repl
(define repl-env
  (new Env% [outer null] [binds null] [exprs null]))
(define (rep str)
  (PRINT (EVAL (READ str) repl-env)))

(for ()  ;; ignore return values

;; core.rkt: defined using Racket
(hash-for-each core_ns (lambda (k v) (send repl-env set k v)))
(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env)))
(send repl-env set '*ARGV* (list))

;; core.mal: defined using the language itself
(rep "(def! *host-language* \"racket\")")
(rep "(def! not (fn* (a) (if a false true)))")
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
(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)))))))")
(rep "(def! *gensym-counter* (atom 0))")
(rep "(def! gensym (fn* [] (symbol (str \"G__\" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))")
(rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))")

)

(define (repl-loop)
  (let ([line (readline "user> ")])
    (when (not (eq? nil line))
      (with-handlers
        ([string? (lambda (exc) (printf "Error: ~a~n" exc))]
         [mal-exn? (lambda (exc) (printf "Error: ~a~n"
                                         (pr_str (mal-exn-val exc) true)))]
         [blank-exn? (lambda (exc) null)])
        (printf "~a~n" (rep line)))
      (repl-loop))))
(let ([args (current-command-line-arguments)])
  (if (> (vector-length args) 0)
    (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")")))
    (begin
      (rep "(println (str \"Mal [\" *host-language* \"]\"))")
      (repl-loop))))
Commit	Line	Data
f5223195 JM	1	#!/usr/bin/env racket
	2	#lang racket
	3
	4	(require "readline.rkt" "types.rkt" "reader.rkt" "printer.rkt"
	5	"env.rkt" "core.rkt")
	6
	7	;; read
	8	(define (READ str)
	9	(read_str str))
	10
	11	;; eval
	12	(define (is-pair x)
	13	(and (_sequential? x) (> (_count x) 0)))
	14
	15	(define (quasiquote ast)
	16	(cond
	17	[(not (is-pair ast))
	18	(list 'quote ast)]
	19
	20	[(equal? 'unquote (_nth ast 0))
	21	(_nth ast 1)]
	22
	23	[(and (is-pair (_nth ast 0))
	24	(equal? 'splice-unquote (_nth (_nth ast 0) 0)))
	25	(list 'concat (_nth (_nth ast 0) 1) (quasiquote (_rest ast)))]
	26
	27	[else
	28	(list 'cons (quasiquote (_nth ast 0)) (quasiquote (_rest ast)))]))
	29
	30	(define (macro? ast env)
	31	(and (list? ast)
	32	(symbol? (first ast))
	33	(not (equal? null (send env find (first ast))))
	34	(let ([fn (send env get (first ast))])
	35	(and (malfunc? fn) (malfunc-macro? fn)))))
	36
	37	(define (macroexpand ast env)
	38	(if (macro? ast env)
	39	(let ([mac (malfunc-fn (send env get (first ast)))])
	40	(macroexpand (apply mac (rest ast)) env))
	41	ast))
	42
	43	(define (eval-ast ast env)
	44	(cond
	45	[(symbol? ast) (send env get ast)]
	46	[(_sequential? ast) (_map (lambda (x) (EVAL x env)) ast)]
	47	[(hash? ast) (make-hash
	48	(dict-map ast (lambda (k v) (cons k (EVAL v env)))))]
	49	[else ast]))
	50
	51	(define (EVAL ast env)
	52	;(printf "~a~n" (pr_str ast true))
	53	(if (not (list? ast))
	54	(eval-ast ast env)
	55
	56	(let ([ast (macroexpand ast env)])
	57	(if (not (list? ast))
0d629719	58	(eval-ast ast env)
f5223195 JM	59	(let ([a0 (_nth ast 0)])
	60	(cond
	61	[(eq? 'def! a0)
	62	(send env set (_nth ast 1) (EVAL (_nth ast 2) env))]
	63	[(eq? 'let* a0)
	64	(let ([let-env (new Env% [outer env] [binds null] [exprs null])])
	65	(_map (lambda (b_e)
	66	(send let-env set (_first b_e)
	67	(EVAL (_nth b_e 1) let-env)))
	68	(_partition 2 (_to_list (_nth ast 1))))
	69	(EVAL (_nth ast 2) let-env))]
	70	[(eq? 'quote a0)
	71	(_nth ast 1)]
	72	[(eq? 'quasiquote a0)
	73	(EVAL (quasiquote (_nth ast 1)) env)]
	74	[(eq? 'defmacro! a0)
	75	(let* ([func (EVAL (_nth ast 2) env)]
	76	[mac (struct-copy malfunc func [macro? #t])])
	77	(send env set (_nth ast 1) mac))]
	78	[(eq? 'macroexpand a0)
	79	(macroexpand (_nth ast 1) env)]
	80	[(eq? 'try* a0)
	81	(if (eq? 'catch* (_nth (_nth ast 2) 0))
	82	(let ([efn (lambda (exc)
	83	(EVAL (_nth (_nth ast 2) 2)
	84	(new Env%
	85	[outer env]
	86	[binds (list (_nth (_nth ast 2) 1))]
	87	[exprs (list exc)])))])
	88	(with-handlers
	89	([mal-exn? (lambda (exc) (efn (mal-exn-val exc)))]
	90	[string? (lambda (exc) (efn exc))]
	91	[exn:fail? (lambda (exc) (efn (format "~a" exc)))])
	92	(EVAL (_nth ast 1) env)))
	93	(EVAL (_nth ast 1)))]
	94	[(eq? 'do a0)
	95	(eval-ast (drop (drop-right ast 1) 1) env)
	96	(EVAL (last ast) env)]
	97	[(eq? 'if a0)
	98	(let ([cnd (EVAL (_nth ast 1) env)])
	99	(if (or (eq? cnd nil) (eq? cnd #f))
	100	(if (> (length ast) 3)
	101	(EVAL (_nth ast 3) env)
	102	nil)
	103	(EVAL (_nth ast 2) env)))]
	104	[(eq? 'fn* a0)
	105	(malfunc
	106	(lambda args (EVAL (_nth ast 2)
	107	(new Env% [outer env]
	108	[binds (_nth ast 1)]
	109	[exprs args])))
	110	(_nth ast 2) env (_nth ast 1) #f nil)]
	111	[else (let* ([el (eval-ast ast env)]
	112	[f (first el)]
	113	[args (rest el)])
	114	(if (malfunc? f)
	115	(EVAL (malfunc-ast f)
	116	(new Env%
	117	[outer (malfunc-env f)]
	118	[binds (malfunc-params f)]
	119	[exprs args]))
	120	(apply f args)))]))))))
	121
	122	;; print
123	(define (PRINT exp)
124	(pr_str exp true))
125
126	;; repl
127	(define repl-env
128	(new Env% [outer null] [binds null] [exprs null]))
129	(define (rep str)
130	(PRINT (EVAL (READ str) repl-env)))
131
132	(for () ;; ignore return values
133
134	;; core.rkt: defined using Racket
135	(hash-for-each core_ns (lambda (k v) (send repl-env set k v)))
136	(send repl-env set 'eval (lambda [ast] (EVAL ast repl-env)))
137	(send repl-env set 'ARGV (list))
138
139	;; core.mal: defined using the language itself
140	(rep "(def! host-language \"racket\")")
141	(rep "(def! not (fn* (a) (if a false true)))")
142	(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
143	(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)))))))")
48572759 DM	144	(rep "(def! gensym-counter (atom 0))")
	145	(rep "(def! gensym (fn* [] (symbol (str \"G__\" (swap! gensym-counter (fn* [x] (+ 1 x)))))))")
	146	(rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(rest xs)))))))))")
f5223195 JM	147
	148	)
	149
	150	(define (repl-loop)
	151	(let ([line (readline "user> ")])
	152	(when (not (eq? nil line))
	153	(with-handlers
	154	([string? (lambda (exc) (printf "Error: ~a~n" exc))]
	155	[mal-exn? (lambda (exc) (printf "Error: ~a~n"
	156	(pr_str (mal-exn-val exc) true)))]
	157	[blank-exn? (lambda (exc) null)])
	158	(printf "~a~n" (rep line)))
	159	(repl-loop))))
	160	(let ([args (current-command-line-arguments)])
	161	(if (> (vector-length args) 0)
	162	(for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")")))
	163	(begin
	164	(rep "(println (str \"Mal [\" host-language \"]\"))")
	165	(repl-loop))))