scheme/step8_macros.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   (let ((type (and (mal-object? ast) (mal-type ast))))
  76     (if (not (eq? type 'list))
  77         (eval-ast ast env)
  78         (if (null? (mal-value ast))
  79             ast
  80             (let* ((ast (macroexpand ast env))
  81                    (items (mal-value ast)))
  82               (if (not (mal-instance-of? ast 'list))
  83                   (eval-ast ast env)
  84                   (let ((a0 (car items)))
  85                     (case (and (mal-object? a0) (mal-value a0))
  86                       ((def!)
  87                        (let ((symbol (mal-value (cadr items)))
  88                              (value (EVAL (list-ref items 2) env)))
  89                          (env-set env symbol value)
  90                          value))
  91                       ((defmacro!)
  92                        (let ((symbol (mal-value (cadr items)))
  93                              (value (EVAL (list-ref items 2) env)))
  94                          (when (func? value)
  95                            (func-macro?-set! value #t))
  96                          (env-set env symbol value)
  97                          value))
  98                       ((macroexpand)
  99                        (macroexpand (cadr items) env))
 100                       ((let*)
 101                        (let ((env* (make-env env))
 102                              (binds (->list (mal-value (cadr items))))
 103                              (form (list-ref items 2)))
 104                          (let loop ((binds binds))
 105                            (when (pair? binds)
 106                              (let ((key (mal-value (car binds))))
 107                                (when (null? (cdr binds))
 108                                  (error "unbalanced list"))
 109                                (let ((value (EVAL (cadr binds) env*)))
 110                                  (env-set env* key value)
 111                                  (loop (cddr binds))))))
 112                          (EVAL form env*))) ; TCO
 113                       ((do)
 114                        (let ((forms (cdr items)))
 115                          (if (null? forms)
 116                              mal-nil
 117                              ;; the evaluation order of map is unspecified
 118                              (let loop ((forms forms))
 119                                (let ((form (car forms))
 120                                      (tail (cdr forms)))
 121                                  (if (null? tail)
 122                                      (EVAL form env) ; TCO
 123                                      (begin
 124                                        (EVAL form env)
 125                                        (loop tail))))))))
 126                       ((if)
 127                        (let* ((condition (EVAL (cadr items) env))
 128                               (type (and (mal-object? condition)
 129                                          (mal-type condition))))
 130                          (if (memq type '(false nil))
 131                              (if (< (length items) 4)
 132                                  mal-nil
 133                                  (EVAL (list-ref items 3) env)) ; TCO
 134                              (EVAL (list-ref items 2) env)))) ; TCO
 135                       ((quote)
 136                        (cadr items))
 137                       ((quasiquote)
 138                        (EVAL (QUASIQUOTE (cadr items)) env)) ; TCO
 139                       ((fn*)
 140                        (let* ((binds (->list (mal-value (cadr items))))
 141                               (binds (map mal-value binds))
 142                               (body (list-ref items 2))
 143                               (fn (lambda args
 144                                     (let ((env* (make-env env binds args)))
 145                                       (EVAL body env*)))))
 146                          (make-func body binds env fn)))
 147                       (else
 148                        (let* ((items (mal-value (eval-ast ast env)))
 149                               (op (car items))
 150                               (ops (cdr items)))
 151                          (if (func? op)
 152                              (let* ((outer (func-env op))
 153                                     (binds (func-params op))
 154                                     (env* (make-env outer binds ops)))
 155                                (EVAL (func-ast op) env*)) ; TCO
 156                              (apply op ops))))))))))))
 157
 158 (define (PRINT ast)
 159   (pr-str ast #t))
 160
 161 (define repl-env (make-env #f))
 162 (for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)
 163
 164 (define (rep input)
 165   (PRINT (EVAL (READ input) repl-env)))
 166
 167 (define args (cdr (command-line)))
 168
 169 (env-set repl-env 'eval (lambda (ast) (EVAL ast repl-env)))
 170 (env-set repl-env '*ARGV* (mal-list (map mal-string (cdr-safe args))))
 171
 172 (rep "(def! not (fn* (a) (if a false true)))")
 173 (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 174
 175 (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)))))))")
 176 (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))))))))")
 177
 178
 179 (define (main)
 180   (let loop ()
 181     (let ((input (readline "user> ")))
 182       (when input
 183         (guard
 184          (ex ((error-object? ex)
 185               (when (not (memv 'empty-input (error-object-irritants ex)))
 186                 (display "[error] ")
 187                 (display (error-object-message ex))
 188                 (newline))))
 189          (display (rep input))
 190          (newline))
 191         (loop))))
 192   (newline))
 193
 194 (if (null? args)
 195     (main)
 196     (rep (string-append "(load-file \"" (car args) "\")")))