clisp/step5_tco.lisp

   1 (require "dependencies")
   2
   3 (defpackage :mal
   4   (:use :common-lisp
   5         :types
   6         :env
   7         :reader
   8         :printer
   9         :core))
  10
  11 (in-package :mal)
  12
  13 (defvar *repl-env* (make-instance 'env:mal-environment))
  14
  15 (dolist (binding core:ns)
  16   (env:set-env *repl-env*
  17                (car binding)
  18                (cdr binding)))
  19
  20 (defvar mal-def! (make-mal-symbol "def!"))
  21 (defvar mal-let* (make-mal-symbol "let*"))
  22 (defvar mal-do (make-mal-symbol "do"))
  23 (defvar mal-if (make-mal-symbol "if"))
  24 (defvar mal-fn* (make-mal-symbol "fn*"))
  25
  26 (defun eval-sequence (sequence env)
  27   (map 'list
  28        (lambda (ast) (mal-eval ast env))
  29        (mal-data-value sequence)))
  30
  31 (defun eval-hash-map (hash-map env)
  32   (let ((hash-map-value (mal-data-value hash-map))
  33         (new-hash-table (make-hash-table :test 'types:mal-value=)))
  34     (loop
  35        for key being the hash-keys of hash-map-value
  36        do (setf (gethash key new-hash-table)
  37                 (mal-eval (gethash key hash-map-value) env)))
  38     (make-mal-hash-map new-hash-table)))
  39
  40 (defun eval-ast (ast env)
  41   (switch-mal-type ast
  42     (types:symbol (env:get-env env ast))
  43     (types:list (eval-sequence ast env))
  44     (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
  45     (types:hash-map (eval-hash-map ast env))
  46     (types:any ast)))
  47
  48 (defun mal-read (string)
  49   (reader:read-str string))
  50
  51 (defun mal-eval (ast env)
  52   (loop
  53      do (cond
  54           ((null ast) (return types:mal-nil))
  55           ((not (types:mal-list-p ast)) (return (eval-ast ast env)))
  56           ((zerop (length (mal-data-value ast))) (return ast))
  57           (t (let ((forms (mal-data-value ast)))
  58                (cond
  59                  ((mal-value= mal-def! (first forms))
  60                   (return (env:set-env env (second forms) (mal-eval (third forms) env))))
  61
  62                  ((mal-value= mal-let* (first forms))
  63                   (let ((new-env (make-instance 'env:mal-environment
  64                                                 :parent env))
  65                         ;; Convert a potential vector to a list
  66                         (bindings (map 'list
  67                                        #'identity
  68                                        (mal-data-value (second forms)))))
  69
  70                     (mapcar (lambda (binding)
  71                               (env:set-env new-env
  72                                            (car binding)
  73                                            (mal-eval (or (cdr binding)
  74                                                          types:mal-nil)
  75                                                      new-env)))
  76                             (loop
  77                                for (symbol value) on bindings
  78                                by #'cddr
  79                                collect (cons symbol value)))
  80                     (setf ast (third forms)
  81                           env new-env)))
  82
  83                  ((mal-value= mal-do (first forms))
  84                   (mapc (lambda (form) (mal-eval form env))
  85                         (butlast (cdr forms)))
  86                   (setf ast (car (last forms))))
  87
  88                  ((mal-value= mal-if (first forms))
  89                   (let ((predicate (mal-eval (second forms) env)))
  90                     (setf ast (if (or (mal-value= predicate types:mal-nil)
  91                                       (mal-value= predicate types:mal-false))
  92                                   (fourth forms)
  93                                   (third forms)))))
  94
  95                  ((mal-value= mal-fn* (first forms))
  96                   (return (let ((arglist (second forms))
  97                                 (body (third forms)))
  98                             (types:make-mal-fn (lambda (&rest args)
  99                                                  (mal-eval body (make-instance 'env:mal-environment
 100                                                                                :parent env
 101                                                                                :binds (map 'list
 102                                                                                            #'identity
 103                                                                                            (mal-data-value arglist))
 104                                                                                :exprs args)))
 105                                                :attrs (list (cons 'params arglist)
 106                                                             (cons 'ast body)
 107                                                             (cons 'env env))))))
 108
 109                  (t (let* ((evaluated-list (eval-ast ast env))
 110                            (function (car evaluated-list)))
 111                       ;; If first element is a mal function unwrap it
 112                       (if (not (types:mal-fn-p function))
 113                           (return (apply (mal-data-value function)
 114                                          (cdr evaluated-list)))
 115                           (let* ((attrs (types:mal-data-attrs function)))
 116                             (setf ast (cdr (assoc 'ast attrs))
 117                                   env (make-instance 'env:mal-environment
 118                                                      :parent (cdr (assoc 'env attrs))
 119                                                      :binds (map 'list
 120                                                                  #'identity
 121                                                                  (mal-data-value (cdr (assoc 'params attrs))))
 122                                                      :exprs (cdr evaluated-list)))))))))))))
 123
 124 (defun mal-print (expression)
 125   (printer:pr-str expression))
 126
 127 (defun rep (string)
 128   (handler-case
 129       (mal-print (mal-eval (mal-read string)
 130                            *repl-env*))
 131     (reader:eof (condition)
 132       (format nil
 133               "~a"
 134               condition))
 135     (env:undefined-symbol (condition)
 136       (format nil
 137               "~a"
 138               condition))
 139     (error (condition)
 140       (format nil
 141               "~a"
 142               condition))))
 143
 144 (rep "(def! not (fn* (a) (if a false true)))")
 145
 146 (defun readline (prompt &optional (in-stream *standard-input*) (out-stream *standard-output*))
 147   (format out-stream prompt)
 148   (force-output out-stream)
 149   (read-line in-stream nil))
 150
 151 (defun writeline (string)
 152   (when string
 153     (write-line string)))
 154
 155 (defun main ()
 156   (loop do (let ((line (readline "user> ")))
 157              (if line (writeline (rep line)) (return)))))
 158
 159 (main)