racket/stepA_mal.rkt

   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))
  58         ast
  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)))))))")
 144 (rep "(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))))))))")
 145
 146 )
 147
 148 (define (repl-loop)
 149   (let ([line (readline "user> ")])
 150     (when (not (eq? nil line))
 151       (with-handlers
 152         ([string? (lambda (exc) (printf "Error: ~a~n" exc))]
 153          [mal-exn? (lambda (exc) (printf "Error: ~a~n"
 154                                          (pr_str (mal-exn-val exc) true)))]
 155          [blank-exn? (lambda (exc) null)])
 156         (printf "~a~n" (rep line)))
 157       (repl-loop))))
 158 (let ([args (current-command-line-arguments)])
 159   (if (> (vector-length args) 0)
 160     (for () (rep (string-append "(load-file \"" (vector-ref args 0) "\")")))
 161     (begin
 162       (rep "(println (str \"Mal [\" *host-language* \"]\"))")
 163       (repl-loop))))