common-lisp/src/step7_quote.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 (defvar mal-quote (make-mal-symbol "quote"))
  31 (defvar mal-quasiquote (make-mal-symbol "quasiquote"))
  32 (defvar mal-unquote (make-mal-symbol "unquote"))
  33 (defvar mal-splice-unquote (make-mal-symbol "splice-unquote"))
  34 (defvar mal-cons (make-mal-symbol "cons"))
  35 (defvar mal-concat (make-mal-symbol "concat"))
  36
  37 (defun eval-sequence (sequence env)
  38   (map 'list
  39        (lambda (ast) (mal-eval ast env))
  40        (mal-data-value sequence)))
  41
  42 (defun eval-hash-map (hash-map env)
  43   (let ((hash-map-value (types:mal-data-value hash-map))
  44         (new-hash-table (types:make-mal-value-hash-table)))
  45     (genhash:hashmap (lambda (key value)
  46                        (setf (genhash:hashref (mal-eval key env) new-hash-table)
  47                              (mal-eval value env)))
  48                      hash-map-value)
  49     (types:make-mal-hash-map new-hash-table)))
  50
  51 (defun eval-ast (ast env)
  52   (switch-mal-type ast
  53     (types:symbol (env:get-env env ast))
  54     (types:list (eval-sequence ast env))
  55     (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
  56     (types:hash-map (eval-hash-map ast env))
  57     (types:any ast)))
  58
  59 (defun is-pair (value)
  60   (and (or (mal-list-p value)
  61            (mal-vector-p value))
  62        (< 0 (length (types:mal-data-value value)))))
  63
  64 (defun quasiquote (ast)
  65   (if (not (is-pair ast))
  66       (types:make-mal-list (list mal-quote ast))
  67       (let ((forms (map 'list #'identity (mal-data-value ast))))
  68         (cond
  69           ((mal-data-value= mal-unquote (first forms))
  70            (second forms))
  71
  72           ((and (is-pair (first forms))
  73                 (mal-data-value= mal-splice-unquote
  74                             (first (mal-data-value (first forms)))))
  75            (types:make-mal-list (list mal-concat
  76                                       (second (mal-data-value (first forms)))
  77                                       (quasiquote (make-mal-list (cdr forms))))))
  78
  79           (t (types:make-mal-list (list mal-cons
  80                                         (quasiquote (first forms))
  81                                         (quasiquote (make-mal-list (cdr forms))))))))))
  82
  83 (defun mal-read (string)
  84   (reader:read-str string))
  85
  86 (defun mal-eval (ast env)
  87   (loop
  88      do (cond
  89           ((null ast) (return types:mal-nil))
  90           ((not (types:mal-list-p ast)) (return (eval-ast ast env)))
  91           ((zerop (length (mal-data-value ast))) (return ast))
  92           (t (let ((forms (mal-data-value ast)))
  93                (cond
  94                  ((mal-data-value= mal-quote (first forms))
  95                   (return (second forms)))
  96
  97                  ((mal-data-value= mal-quasiquote (first forms))
  98                   (setf ast (quasiquote (second forms))))
  99
 100                  ((mal-data-value= mal-def! (first forms))
 101                   (return (env:set-env env (second forms) (mal-eval (third forms) env))))
 102
 103                  ((mal-data-value= mal-let* (first forms))
 104                   (let ((new-env (env:create-mal-env :parent env))
 105                         (bindings (utils:listify (types:mal-data-value (second forms)))))
 106
 107                     (mapcar (lambda (binding)
 108                               (env:set-env new-env
 109                                            (car binding)
 110                                            (mal-eval (or (cdr binding)
 111                                                          types:mal-nil)
 112                                                      new-env)))
 113                             (loop
 114                                for (symbol value) on bindings
 115                                by #'cddr
 116                                collect (cons symbol value)))
 117                     (setf ast (third forms)
 118                           env new-env)))
 119
 120                  ((mal-data-value= mal-do (first forms))
 121                   (mapc (lambda (form) (mal-eval form env))
 122                         (butlast (cdr forms)))
 123                   (setf ast (car (last forms))))
 124
 125                  ((mal-data-value= mal-if (first forms))
 126                   (let ((predicate (mal-eval (second forms) env)))
 127                     (setf ast (if (or (mal-data-value= predicate types:mal-nil)
 128                                       (mal-data-value= predicate types:mal-false))
 129                                   (fourth forms)
 130                                   (third forms)))))
 131
 132                  ((mal-data-value= mal-fn* (first forms))
 133                   (return (let ((arglist (second forms))
 134                                 (body (third forms)))
 135                             (types:make-mal-fn (lambda (&rest args)
 136                                                  (mal-eval body (env:create-mal-env :parent env
 137                                                                                     :binds (map 'list
 138                                                                                                 #'identity
 139                                                                                                 (mal-data-value arglist))
 140                                                                                     :exprs args)))
 141                                                :attrs (list (cons 'params arglist)
 142                                                             (cons 'ast body)
 143                                                             (cons 'env env))))))
 144
 145                  (t (let* ((evaluated-list (eval-ast ast env))
 146                            (function (car evaluated-list)))
 147                       ;; If first element is a mal function unwrap it
 148                       (if (not (types:mal-fn-p function))
 149                           (return (apply (mal-data-value function)
 150                                          (cdr evaluated-list)))
 151                           (let* ((attrs (types:mal-data-attrs function)))
 152                             (setf ast (cdr (assoc 'ast attrs))
 153                                   env (env:create-mal-env :parent (cdr (assoc 'env attrs))
 154                                                           :binds (map 'list
 155                                                                       #'identity
 156                                                                       (mal-data-value (cdr (assoc 'params attrs))))
 157                                                           :exprs (cdr evaluated-list)))))))))))))
 158
 159 (defun mal-print (expression)
 160   (printer:pr-str expression))
 161
 162 (defun rep (string)
 163   (handler-case
 164       (mal-print (mal-eval (mal-read string)
 165                            *repl-env*))
 166     (error (condition)
 167       (format nil
 168               "~a"
 169               condition))))
 170
 171 (env:set-env *repl-env*
 172              (types:make-mal-symbol "eval")
 173              (types:make-mal-builtin-fn (lambda (ast)
 174                                           (mal-eval ast *repl-env*))))
 175
 176 (rep "(def! not (fn* (a) (if a false true)))")
 177 (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 178
 179 (defvar *use-readline-p* nil)
 180
 181 (defun raw-input (prompt)
 182   (format *standard-output* prompt)
 183   (force-output *standard-output*)
 184   (read-line *standard-input* nil))
 185
 186 (defun mal-readline (prompt)
 187   (if *use-readline-p*
 188       (cl-readline:readline :prompt prompt
 189                             :add-history t
 190                             :novelty-check (lambda (old new)
 191                                              (not (string= old new))))
 192       (raw-input prompt)))
 193
 194 (defun mal-writeline (string)
 195   (when string
 196     (write-line string)
 197     (force-output *standard-output*)))
 198
 199 (defun repl ()
 200   (loop do (let ((line (mal-readline "user> ")))
 201              (if line
 202                  (mal-writeline (rep line))
 203                  (return)))))
 204
 205 (defun run-file (file)
 206   (rep (format nil "(load-file \"~a\")" file)))
 207
 208 (defun main (&optional (argv nil argv-provided-p))
 209
 210   (setf *use-readline-p* (not (or (string= (utils:getenv "PERL_RL") "false")
 211                                   (string= (utils:getenv "TERM") "dumb"))))
 212
 213   ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort
 214   ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment
 215   ;; variable which the test runner sets causing `read-line' on *standard-input*
 216   ;; to fail with an empty stream error. The following reinitializes the
 217   ;; standard streams
 218   ;;
 219   ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html
 220   #+clisp (setf *standard-input* (ext:make-stream :input)
 221                 *standard-output* (ext:make-stream :output :buffered t)
 222                 *error-output* (ext:make-stream :error :buffered t))
 223
 224   (let ((args (if argv-provided-p
 225                   argv
 226                   (cdr (utils:raw-command-line-arguments)))))
 227     (env:set-env *repl-env*
 228                  (types:make-mal-symbol "*ARGV*")
 229                  (types:wrap-value (cdr args) :listp t))
 230     (if (null args)
 231         (repl)
 232         (run-file (car args)))))
 233
 234 ;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an
 235 ;;; image containing foreign libraries is restored. The extra messages cause the
 236 ;;; MAL testcases to fail
 237
 238 #+cmucl (progn
 239           (defvar *old-standard-output* *standard-output*
 240             "Keep track of current value standard output, this is restored after image restore completes")
 241
 242           (defun muffle-output ()
 243             (setf *standard-output* (make-broadcast-stream)))
 244
 245           (defun restore-output ()
 246             (setf *standard-output* *old-standard-output*))
 247
 248           (pushnew #'muffle-output ext:*after-save-initializations*)
 249           (setf ext:*after-save-initializations*
 250                 (append ext:*after-save-initializations* (list #'restore-output))))