scheme/step4_if_fn_do.scm

   1 (import (scheme base))
   2 (import (scheme write))
   3
   4 (import (lib util))
   5 (import (lib reader))
   6 (import (lib printer))
   7 (import (lib types))
   8 (import (lib env))
   9 (import (lib core))
  10
  11 (define (READ input)
  12   (read-str input))
  13
  14 (define (eval-ast ast env)
  15   (let ((type (and (mal-object? ast) (mal-type ast)))
  16         (value (and (mal-object? ast) (mal-value ast))))
  17     (case type
  18       ((symbol) (env-get env value))
  19       ((list) (mal-list (map (lambda (item) (EVAL item env)) value)))
  20       ((vector) (mal-vector (vector-map (lambda (item) (EVAL item env)) value)))
  21       ((map) (mal-map (alist-map (lambda (key value) (cons key (EVAL value env))) value)))
  22       (else ast))))
  23
  24 (define (EVAL ast env)
  25   (let ((type (and (mal-object? ast) (mal-type ast))))
  26     (if (not (eq? type 'list))
  27         (eval-ast ast env)
  28         (let ((items (mal-value ast)))
  29           (if (null? items)
  30               ast
  31               (case (mal-value (car items))
  32                 ((def!)
  33                  (let ((symbol (mal-value (cadr items)))
  34                        (value (EVAL (list-ref items 2) env)))
  35                    (env-set env symbol value)
  36                    value))
  37                 ((let*)
  38                  (let ((env* (make-env env))
  39                        (binds (->list (mal-value (cadr items))))
  40                        (form (list-ref items 2)))
  41                    (let loop ((binds binds))
  42                      (when (pair? binds)
  43                        (let ((key (mal-value (car binds))))
  44                          (when (null? (cdr binds))
  45                            (error "unbalanced list"))
  46                          (let ((value (EVAL (cadr binds) env*)))
  47                            (env-set env* key value)
  48                            (loop (cddr binds))))))
  49                    (EVAL form env*)))
  50                 ((do)
  51                  (let ((forms (cdr items)))
  52                    (if (null? forms)
  53                        mal-nil
  54                        ;; the evaluation order of map is unspecified
  55                        (let loop ((forms forms))
  56                          (let ((form (car forms))
  57                                (tail (cdr forms)))
  58                            (if (null? tail)
  59                                (EVAL form env)
  60                                (begin
  61                                  (EVAL form env)
  62                                  (loop tail))))))))
  63                 ((if)
  64                  (let* ((condition (EVAL (cadr items) env))
  65                         (type (and (mal-object? condition)
  66                                    (mal-type condition))))
  67                    (if (memq type '(false nil))
  68                        (if (< (length items) 4)
  69                            mal-nil
  70                            (EVAL (list-ref items 3) env))
  71                        (EVAL (list-ref items 2) env))))
  72                 ((fn*)
  73                  (let* ((binds (->list (mal-value (cadr items))))
  74                         (binds (map mal-value binds))
  75                         (body (list-ref items 2)))
  76                    (lambda args
  77                      (let ((env* (make-env env binds args)))
  78                        (EVAL body env*)))))
  79                 (else
  80                  (let* ((items (mal-value (eval-ast ast env)))
  81                         (op (car items))
  82                         (ops (cdr items)))
  83                    (apply op ops)))))))))
  84
  85 (define (PRINT ast)
  86   (pr-str ast #t))
  87
  88 (define repl-env (make-env #f))
  89 (for-each (lambda (kv) (env-set repl-env (car kv) (cdr kv))) ns)
  90
  91 (define (rep input)
  92   (PRINT (EVAL (READ input) repl-env)))
  93
  94 (rep "(def! not (fn* (a) (if a false true)))")
  95
  96 (define (main)
  97   (let loop ()
  98     (let ((input (readline "user> ")))
  99       (when input
 100         (guard
 101          (ex ((error-object? ex)
 102               (when (not (memv 'empty-input (error-object-irritants ex)))
 103                 (display "[error] ")
 104                 (display (error-object-message ex))
 105                 (newline)))
 106              ((and (pair? ex) (eq? (car ex) 'user-error))
 107               (display "[error] ")
 108               (display (pr-str (cdr ex) #t))
 109               (newline)))
 110          (display (rep input))
 111          (newline))
 112         (loop))))
 113   (newline))
 114
 115 (main)