scheme/step9_try.scm

   1 (import (scheme base))
   2 (import (scheme write))
   3 (import (scheme process-context))
   4
   5 (import (lib util))
   6 (import (lib reader))
   7 (import (lib printer))
   8 (import (lib types))
   9 (import (lib env))
  10 (import (lib core))
  11
  12 (define (READ input)
  13   (read-str input))
  14
  15 (define (eval-ast ast env)
  16   (let ((type (and (mal-object? ast) (mal-type ast)))
  17         (value (and (mal-object? ast) (mal-value ast))))
  18     (case type
  19       ((symbol) (env-get env value))
  20       ((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
  21       ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
  22       ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
  23       (else ast))))
  24
  25 (define (is-pair? ast)
  26   (let ((type (and (mal-object? ast) (mal-type ast))))
  27     (if (memq type '(list vector))
  28         (pair? (->list (mal-value ast)))
  29         #f)))
  30
  31 (define (QUASIQUOTE ast)
  32   (if (not (is-pair? ast))
  33       (mal-list (list (mal-symbol 'quote) ast))
  34       (let* ((items (->list (mal-value ast)))
  35              (a0 (car items)))
  36         (if (and (mal-object? a0)
  37                  (eq? (mal-type a0) 'symbol)
  38                  (eq? (mal-value a0) 'unquote))
  39             (cadr items)
  40             (if (and (is-pair? a0)
  41                      (mal-object? (car (mal-value a0)))
  42                      (eq? (mal-type (car (mal-value a0))) 'symbol)
  43                      (eq? (mal-value (car (mal-value a0))) 'splice-unquote))
  44                 (mal-list (list (mal-symbol 'concat)
  45                                 (cadr (mal-value a0))
  46                                 (QUASIQUOTE (mal-list (cdr items)))))
  47                 (mal-list (list (mal-symbol 'cons)
  48                                 (QUASIQUOTE a0)
  49                                 (QUASIQUOTE (mal-list (cdr items))))))))))
  50
  51 (define (is-macro-call? ast env)
  52   (if (mal-instance-of? ast 'list)
  53       (let ((op (car-safe (mal-value ast))))
  54         (if (mal-instance-of? op 'symbol)
  55             (let ((x (env-find env (mal-value op))))
  56               (if x
  57                   (if (and (func? x) (func-macro? x))
  58                       #t
  59                       #f)
  60                   #f))
  61             #f))
  62       #f))
  63
  64 (define (macroexpand ast env)
  65   (let loop ((ast ast))
  66     (if (is-macro-call? ast env)
  67         (let* ((items (mal-value ast))
  68                (op (car items))
  69                (ops (cdr items))
  70                (fn (func-fn (env-get env (mal-value op)))))
  71           (loop (apply fn ops)))
  72         ast)))
  73
  74 (define (EVAL ast env)
  75   (define (handle-catch value handler)
  76     (let* ((symbol (mal-value (cadr handler)))
  77            (form (list-ref handler 2))
  78            (env* (make-env env (list symbol) (list value))))
  79       (EVAL form env*)))
  80   (let ((type (and (mal-object? ast) (mal-type ast))))
  81     (if (not (eq? type 'list))
  82         (eval-ast ast env)
  83         (if (null? (mal-value ast))
  84             ast
  85             (let* ((ast (macroexpand ast env))
  86                    (items (mal-value ast)))
  87               (if (not (mal-instance-of? ast 'list))
  88                   (eval-ast ast env)
  89                   (let ((a0 (car items)))
  90                     (case (and (mal-object? a0) (mal-value a0))
  91                       ((def!)
  92                        (let ((symbol (mal-value (cadr items)))
  93                              (value (EVAL (list-ref items 2) env)))
  94                          (env-set env symbol value)
  95                          value))
  96                       ((defmacro!)
  97                        (let ((symbol (mal-value (cadr items)))
  98                              (value (EVAL (list-ref items 2) env)))
  99                          (when (func? value)
 100                            (func-macro?-set! value #t))
 101                          (env-set env symbol value)
 102                          value))
 103                       ((macroexpand)
 104                        (macroexpand (cadr items) env))
 105                       ((try*)
 106                        (if (< (length items) 3)
 107                          (EVAL (cadr items) env)
 108                          (let* ((form (cadr items))
 109                                 (handler (mal-value (list-ref items 2))))
 110                            (guard
 111                             (ex ((error-object? ex)
 112                                  (handle-catch
 113                                   (mal-string (error-object-message ex))
 114                                   handler))
 115                                 ((and (pair? ex) (eq? (car ex) 'user-error))
 116                                  (handle-catch (cdr ex) handler)))
 117                             (EVAL form env)))))
 118                       ((let*)
 119                        (let ((env* (make-env env))
 120                              (binds (->list (mal-value (cadr items))))
 121                              (form (list-ref items 2)))
 122                          (let loop ((binds binds))
 123                            (when (pair? binds)
 124                              (let ((key (mal-value (car binds))))
 125                                (when (null? (cdr binds))
 126                                  (error "unbalanced list"))
 127                                (let ((value (EVAL (cadr binds) env*)))
 128                                  (env-set env* key value)
 129                                  (loop (cddr binds))))))
 130                          (EVAL form env*))) ; TCO
 131                       ((do)
 132                        (let ((forms (cdr items)))
 133                          (if (null? forms)
 134                              mal-nil
 135                              ;; the evaluation order of map is unspecified
 136                              (let loop ((forms forms))
 137                                (let ((form (car forms))
 138                                      (tail (cdr forms)))
 139                                  (if (null? tail)
 140                                      (EVAL form env) ; TCO
 141                                      (begin
 142                                        (EVAL form env)
 143                                        (loop tail))))))))
 144                       ((if)
 145                        (let* ((condition (EVAL (cadr items) env))
 146                               (type (and (mal-object? condition)
 147                                          (mal-type condition))))
 148                          (if (memq type '(false nil))
 149                              (if (< (length items) 4)
 150                                  mal-nil
 151                                  (EVAL (list-ref items 3) env)) ; TCO
 152                              (EVAL (list-ref items 2) env)))) ; TCO
 153                       ((quote)
 154                        (cadr items))
 155                       ((quasiquote)
 156                        (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO
 157                       ((fn*)
 158                        (let* ((binds (->list (mal-value (cadr items))))
 159                               (binds (map mal-value binds))
 160                               (body (list-ref items 2))
 161                               (fn (lambda args
 162                                     (let ((env* (make-env env binds args)))
 163                                       (EVAL body env*)))))
 164                          (make-func body binds env fn)))
 165                       (else
 166                        (let* ((items (mal-value (eval-ast ast env)))
 167                               (op (car items))
 168                               (ops (cdr items)))
 169                          (if (func? op)
 170                              (let* ((outer (func-env op))
 171                                     (binds (func-params op))
 172                                     (env* (make-env outer binds ops)))
 173                                (EVAL (func-ast op) env*)) ; TCO
 174                              (apply op ops))))))))))))
 175
 176 (define (PRINT ast)
 177   (pr-str ast #t))
 178
 179 (define repl-env (make-env #f))
 180 (for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)
 181
 182 (define (rep input)
 183   (PRINT (EVAL (READ input) repl-env)))
 184
 185 (define args (cdr (command-line)))
 186
 187 (env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env)))
 188 (env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args))))
 189
 190 (rep "(def! not (fn* (a) (if a false true)))")
 191 (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 192
 193 (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)))))))")
 194 (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))))))))")
 195
 196
 197 (define (main)
 198   (let loop ()
 199     (let ((input (readline "user> ")))
 200       (when input
 201         (guard
 202          (ex ((error-object? ex)
 203               (when (not (memv 'empty-input (error-object-irritants ex)))
 204                 (display "[error] ")
 205                 (display (error-object-message ex))
 206                 (newline)))
 207              ((and (pair? ex) (eq? (car ex) 'user-error))
 208               (display "[error] ")
 209               (display (pr-str (cdr ex) #t))
 210               (newline)))
 211          (display (rep input))
 212          (newline))
 213         (loop))))
 214   (newline))
 215
 216 (if (null? args)
 217     (main)
 218     (rep (string-append "(load-file \"" (car args) "\")")))