common-lisp/step4_if_fn_do.lisp

   1 (defpackage :mal
   2   (:use :common-lisp
   3         :types
   4         :env
   5         :reader
   6         :printer
   7         :core)
   8   (:import-from :genhash
   9                 :hashref
  10                 :hashmap)
  11   (:import-from :utils
  12                 :listify
  13                 :getenv)
  14   (:export :main))
  15
  16 (in-package :mal)
  17
  18 (defvar *repl-env* (env:create-mal-env))
  19
  20 (dolist (binding core:ns)
  21   (env:set-env *repl-env*
  22                (car binding)
  23                (cdr binding)))
  24
  25 (defvar mal-def! (make-mal-symbol "def!"))
  26 (defvar mal-let* (make-mal-symbol "let*"))
  27 (defvar mal-do (make-mal-symbol "do"))
  28 (defvar mal-if (make-mal-symbol "if"))
  29 (defvar mal-fn* (make-mal-symbol "fn*"))
  30
  31 (defun eval-sequence (sequence env)
  32   (map 'list
  33        (lambda (ast) (mal-eval ast env))
  34        (mal-data-value sequence)))
  35
  36 (defun eval-hash-map (hash-map env)
  37   (let ((hash-map-value (types:mal-data-value hash-map))
  38         (new-hash-table (types:make-mal-value-hash-table)))
  39     (genhash:hashmap (lambda (key value)
  40                        (setf (genhash:hashref (mal-eval key env) new-hash-table)
  41                              (mal-eval value env)))
  42                      hash-map-value)
  43     (types:make-mal-hash-map new-hash-table)))
  44
  45 (defun eval-ast (ast env)
  46   (switch-mal-type ast
  47     (types:symbol (env:get-env env ast))
  48     (types:list (eval-sequence ast env))
  49     (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
  50     (types:hash-map (eval-hash-map ast env))
  51     (types:any ast)))
  52
  53 (defun eval-let* (forms env)
  54   (let ((new-env (env:create-mal-env :parent env))
  55         (bindings (utils:listify (types:mal-data-value (second forms)))))
  56
  57     (mapcar (lambda (binding)
  58               (env:set-env new-env
  59                            (car binding)
  60                            (mal-eval (or (cdr binding)
  61                                          types:mal-nil)
  62                                      new-env)))
  63             (loop
  64                for (symbol value) on bindings
  65                by #'cddr
  66                collect (cons symbol value)))
  67
  68     (mal-eval (third forms) new-env)))
  69
  70 (defun eval-list (ast env)
  71   (let ((forms (mal-data-value ast)))
  72     (cond
  73       ((mal-data-value= mal-def! (first forms))
  74        (env:set-env env (second forms) (mal-eval (third forms) env)))
  75       ((mal-data-value= mal-let* (first forms))
  76        (eval-let* forms env))
  77       ((mal-data-value= mal-do (first forms))
  78        (car (last (mapcar (lambda (form) (mal-eval form env))
  79                           (cdr forms)))))
  80       ((mal-data-value= mal-if (first forms))
  81        (let ((predicate (mal-eval (second forms) env)))
  82          (mal-eval (if (or (mal-data-value= predicate types:mal-nil)
  83                            (mal-data-value= predicate types:mal-false))
  84                        (fourth forms)
  85                        (third forms))
  86                    env)))
  87       ((mal-data-value= mal-fn* (first forms))
  88        (types:make-mal-fn (let ((arglist (second forms))
  89                                 (body (third forms)))
  90                             (lambda (&rest args)
  91                               (mal-eval body (env:create-mal-env :parent env
  92                                                                  :binds (map 'list
  93                                                                              #'identity
  94                                                                              (mal-data-value arglist))
  95                                                                  :exprs args))))))
  96       (t (let* ((evaluated-list (eval-ast ast env))
  97                (function (car evaluated-list)))
  98          ;; If first element is a mal function unwrap it
  99          (apply (mal-data-value function)
 100                 (cdr evaluated-list)))))))
 101
 102 (defun mal-read (string)
 103   (reader:read-str string))
 104
 105 (defun mal-eval (ast env)
 106   (cond
 107     ((null ast) types:mal-nil)
 108     ((not (types:mal-list-p ast)) (eval-ast ast env))
 109     ((zerop (length (mal-data-value ast))) ast)
 110     (t (eval-list ast env))))
 111
 112 (defun mal-print (expression)
 113   (printer:pr-str expression))
 114
 115 (defun rep (string)
 116   (handler-case
 117       (mal-print (mal-eval (mal-read string)
 118                            *repl-env*))
 119     (error (condition)
 120       (format nil
 121               "~a"
 122               condition))))
 123
 124 (rep "(def! not (fn* (a) (if a false true)))")
 125
 126 (defvar *use-readline-p* nil)
 127
 128 (defun raw-input (prompt)
 129   (format *standard-output* prompt)
 130   (force-output *standard-output*)
 131   (read-line *standard-input* nil))
 132
 133 (defun mal-readline (prompt)
 134   (if *use-readline-p*
 135       (cl-readline:readline :prompt prompt
 136                             :add-history t
 137                             :novelty-check (lambda (old new)
 138                                              (not (string= old new))))
 139       (raw-input prompt)))
 140
 141 (defun mal-writeline (string)
 142   (when string
 143     (write-line string)
 144     (force-output *standard-output*)))
 145
 146 (defun main (&optional (argv nil argv-provided-p))
 147   (declare (ignorable argv argv-provided-p))
 148
 149   (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false")
 150                                   (string= (utils:getenv "TERM") "dumb"))))
 151
 152   ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort
 153   ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment
 154   ;; variable which the test runner sets causing `read-line' on *standard-input*
 155   ;; to fail with an empty stream error. The following reinitializes the
 156   ;; standard streams
 157   ;;
 158   ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html
 159   #+clisp (setf *standard-input* (ext:make-stream :input)
 160                 *standard-output* (ext:make-stream :output :buffered t)
 161                 *error-output* (ext:make-stream :error :buffered t))
 162
 163   (loop do (let ((line (mal-readline "user> ")))
 164              (if line (mal-writeline (rep line)) (return)))))
 165
 166 ;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an
 167 ;;; image containing foreign libraries is restored. The extra messages cause the
 168 ;;; MAL testcases to fail
 169
 170 #+cmucl (progn
 171           (defvar *old-standard-output* *standard-output*
 172             "Keep track of current value standard output, this is restored after image restore completes")
 173
 174           (defun muffle-output ()
 175             (setf *standard-output* (make-broadcast-stream)))
 176
 177           (defun restore-output ()
 178             (setf *standard-output* *old-standard-output*))
 179
 180           (pushnew #'muffle-output ext:*after-save-initializations*)
 181           (setf ext:*after-save-initializations*
 182                 (append ext:*after-save-initializations* (list #'restore-output))))