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* (make-instance 'env:mal-environment))
  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 (make-instance 'env:mal-environment
  65                                                 :parent env))
  66                         ;; Convert a potential vector to a list
  67                         (bindings (map 'list
  68                                        #'identity
  69                                        (mal-data-value (second forms)))))
  70
  71                     (mapcar (lambda (binding)
  72                               (env:set-env new-env
  73                                            (car binding)
  74                                            (mal-eval (or (cdr binding)
  75                                                          types:mal-nil)
  76                                                      new-env)))
  77                             (loop
  78                                for (symbol value) on bindings
  79                                by #'cddr
  80                                collect (cons symbol value)))
  81                     (setf ast (third forms)
  82                           env new-env)))
  83
  84                  ((mal-value= mal-do (first forms))
  85                   (mapc (lambda (form) (mal-eval form env))
  86                         (butlast (cdr forms)))
  87                   (setf ast (car (last forms))))
  88
  89                  ((mal-value= mal-if (first forms))
  90                   (let ((predicate (mal-eval (second forms) env)))
  91                     (setf ast (if (or (mal-value= predicate types:mal-nil)
  92                                       (mal-value= predicate types:mal-false))
  93                                   (fourth forms)
  94                                   (third forms)))))
  95
  96                  ((mal-value= mal-fn* (first forms))
  97                   (return (let ((arglist (second forms))
  98                                 (body (third forms)))
  99                             (types:make-mal-fn (lambda (&rest args)
 100                                                  (mal-eval body (make-instance 'env:mal-environment
 101                                                                                :parent env
 102                                                                                :binds (map 'list
 103                                                                                            #'identity
 104                                                                                            (mal-data-value arglist))
 105                                                                                :exprs args)))
 106                                                :attrs (list (cons 'params arglist)
 107                                                             (cons 'ast body)
 108                                                             (cons 'env env))))))
 109
 110                  (t (let* ((evaluated-list (eval-ast ast env))
 111                            (function (car evaluated-list)))
 112                       ;; If first element is a mal function unwrap it
 113                       (if (not (types:mal-fn-p function))
 114                           (return (apply (mal-data-value function)
 115                                          (cdr evaluated-list)))
 116                           (let* ((attrs (types:mal-data-attrs function)))
 117                             (setf ast (cdr (assoc 'ast attrs))
 118                                   env (make-instance 'env:mal-environment
 119                                                      :parent (cdr (assoc 'env attrs))
 120                                                      :binds (map 'list
 121                                                                  #'identity
 122                                                                  (mal-data-value (cdr (assoc 'params attrs))))
 123                                                      :exprs (cdr evaluated-list)))))))))))))
 124
 125 (defun mal-print (expression)
 126   (printer:pr-str expression))
 127
 128 (defun rep (string)
 129   (handler-case
 130       (mal-print (mal-eval (mal-read string)
 131                            *repl-env*))
 132     (reader:eof (condition)
 133       (format nil
 134               "~a"
 135               condition))
 136     (env:undefined-symbol (condition)
 137       (format nil
 138               "~a"
 139               condition))
 140     (error (condition)
 141       (format nil
 142               "~a"
 143               condition))))
 144
 145 (rep "(def! not (fn* (a) (if a false true)))")
 146
 147 ;; Readline setup
 148 ;;; The test runner sets this environment variable, in which case we do
 149 ;;; use readline since tests do not work with the readline interface
 150 (defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
 151
 152 (defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
 153                                                          ".mal-clisp-history")))
 154
 155 (defun load-history ()
 156   (readline:read-history *history-file*))
 157
 158 (defun save-history ()
 159   (readline:write-history *history-file*))
 160
 161 ;; Setup history
 162 (when use-readline-p
 163   (load-history))
 164
 165 (defun raw-input (prompt)
 166   (format *standard-output* prompt)
 167   (force-output *standard-output*)
 168   (read-line *standard-input* nil))
 169
 170 (defun mal-readline (prompt)
 171   (let ((input (if use-readline-p
 172                    (readline:readline prompt)
 173                    (raw-input prompt))))
 174     (when (and use-readline-p
 175                input
 176                (not (zerop (length input))))
 177       (readline:add-history input))
 178     input))
 179
 180 (defun mal-writeline (string)
 181   (when string
 182     (write-line string)))
 183
 184 (defun main ()
 185   (loop do (let ((line (mal-readline "user> ")))
 186              (if line
 187                  (mal-writeline (rep line))
 188                  (return))))
 189   (when use-readline-p
 190     (save-history)))
 191
 192 ;; Do not start REPL inside Emacs
 193 (unless (member :swank *features*)
 194   (main))