clisp/step5_tco.lisp

   1 (require "dependencies")
   2
   3 (defpackage :mal
   4   (:use :common-lisp
   5         :readline
   6         :types
   7         :env
   8         :reader
   9         :printer
  10         :core))
  11
  12 (in-package :mal)
  13
  14 (defvar *repl-env* (env:create-mal-env))
  15
  16 (dolist (binding core:ns)
  17   (env:set-env *repl-env*
  18                (car binding)
  19                (cdr binding)))
  20
  21 (defvar mal-def! (make-mal-symbol "def!"))
  22 (defvar mal-let* (make-mal-symbol "let*"))
  23 (defvar mal-do (make-mal-symbol "do"))
  24 (defvar mal-if (make-mal-symbol "if"))
  25 (defvar mal-fn* (make-mal-symbol "fn*"))
  26
  27 (defun eval-sequence (sequence env)
  28   (map 'list
  29        (lambda (ast) (mal-eval ast env))
  30        (mal-data-value sequence)))
  31
  32 (defun eval-hash-map (hash-map env)
  33   (let ((hash-map-value (mal-data-value hash-map))
  34         (new-hash-table (make-hash-table :test 'types:mal-value=)))
  35     (loop
  36        for key being the hash-keys of hash-map-value
  37        do (setf (gethash key new-hash-table)
  38                 (mal-eval (gethash key hash-map-value) env)))
  39     (make-mal-hash-map new-hash-table)))
  40
  41 (defun eval-ast (ast env)
  42   (switch-mal-type ast
  43     (types:symbol (env:get-env env ast))
  44     (types:list (eval-sequence ast env))
  45     (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
  46     (types:hash-map (eval-hash-map ast env))
  47     (types:any ast)))
  48
  49 (defun mal-read (string)
  50   (reader:read-str string))
  51
  52 (defun mal-eval (ast env)
  53   (loop
  54      do (cond
  55           ((null ast) (return types:mal-nil))
  56           ((not (types:mal-list-p ast)) (return (eval-ast ast env)))
  57           ((zerop (length (mal-data-value ast))) (return ast))
  58           (t (let ((forms (mal-data-value ast)))
  59                (cond
  60                  ((mal-value= mal-def! (first forms))
  61                   (return (env:set-env env (second forms) (mal-eval (third forms) env))))
  62
  63                  ((mal-value= mal-let* (first forms))
  64                   (let ((new-env (env:create-mal-env :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 (env:create-mal-env :parent env
 100                                                                                     :binds (map 'list
 101                                                                                                 #'identity
 102                                                                                                 (mal-data-value arglist))
 103                                                                                     :exprs args)))
 104                                                :attrs (list (cons 'params arglist)
 105                                                             (cons 'ast body)
 106                                                             (cons 'env env))))))
 107
 108                  (t (let* ((evaluated-list (eval-ast ast env))
 109                            (function (car evaluated-list)))
 110                       ;; If first element is a mal function unwrap it
 111                       (if (not (types:mal-fn-p function))
 112                           (return (apply (mal-data-value function)
 113                                          (cdr evaluated-list)))
 114                           (let* ((attrs (types:mal-data-attrs function)))
 115                             (setf ast (cdr (assoc 'ast attrs))
 116                                   env (env:create-mal-env :parent (cdr (assoc 'env attrs))
 117                                                           :binds (map 'list
 118                                                                       #'identity
 119                                                                       (mal-data-value (cdr (assoc 'params attrs))))
 120                                                           :exprs (cdr evaluated-list)))))))))))))
 121
 122 (defun mal-print (expression)
 123   (printer:pr-str expression))
 124
 125 (defun rep (string)
 126   (handler-case
 127       (mal-print (mal-eval (mal-read string)
 128                            *repl-env*))
 129     (reader:eof (condition)
 130       (format nil
 131               "~a"
 132               condition))
 133     (env:undefined-symbol (condition)
 134       (format nil
 135               "~a"
 136               condition))
 137     (error (condition)
 138       (format nil
 139               "~a"
 140               condition))))
 141
 142 (rep "(def! not (fn* (a) (if a false true)))")
 143
 144 ;; Readline setup
 145 ;;; The test runner sets this environment variable, in which case we do
 146 ;;; use readline since tests do not work with the readline interface
 147 (defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
 148
 149 (defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
 150                                                          ".mal-clisp-history")))
 151
 152 (defun load-history ()
 153   (readline:read-history *history-file*))
 154
 155 (defun save-history ()
 156   (readline:write-history *history-file*))
 157
 158 ;; Setup history
 159 (when use-readline-p
 160   (load-history))
 161
 162 (defun raw-input (prompt)
 163   (format *standard-output* prompt)
 164   (force-output *standard-output*)
 165   (read-line *standard-input* nil))
 166
 167 (defun mal-readline (prompt)
 168   (let ((input (if use-readline-p
 169                    (readline:readline prompt)
 170                    (raw-input prompt))))
 171     (when (and use-readline-p
 172                input
 173                (not (zerop (length input))))
 174       (readline:add-history input))
 175     input))
 176
 177 (defun mal-writeline (string)
 178   (when string
 179     (write-line string)))
 180
 181 (defun main ()
 182   (loop do (let ((line (mal-readline "user> ")))
 183              (if line
 184                  (mal-writeline (rep line))
 185                  (return))))
 186   (when use-readline-p
 187     (save-history)))
 188
 189 ;; Do not start REPL inside Emacs
 190 (unless (member :swank *features*)
 191   (main))