common-lisp/src/step9_try.lisp

   1 (defpackage :mal
   2   (:use :common-lisp
   3         :types
   4         :env
   5         :reader
   6         :printer
   7         :core)
   8   (:import-from :cl-readline
   9                 :readline
  10                 :register-function)
  11   (:import-from :genhash
  12                 :hashref
  13                 :hashmap)
  14   (:import-from :utils
  15                 :listify
  16                 :getenv
  17                 :common-prefix)
  18   (:export :main))
  19
  20 (in-package :mal)
  21
  22 (define-condition invalid-function (mal-runtime-exception)
  23   ((form :initarg :form :reader form)
  24    (context :initarg :context :reader context))
  25   (:report (lambda (condition stream)
  26              (format stream
  27                      "Invalid function '~a' provided while ~a"
  28                      (printer:pr-str (form condition))
  29                      (if (string= (context condition) "apply")
  30                          "applying"
  31                          "defining macro")))))
  32
  33
  34 (defvar *repl-env* (env:create-mal-env))
  35
  36 (dolist (binding core:ns)
  37   (env:set-env *repl-env* (car binding) (cdr binding)))
  38
  39 (defvar mal-def! (make-mal-symbol "def!"))
  40 (defvar mal-let* (make-mal-symbol "let*"))
  41 (defvar mal-do (make-mal-symbol "do"))
  42 (defvar mal-if (make-mal-symbol "if"))
  43 (defvar mal-fn* (make-mal-symbol "fn*"))
  44 (defvar mal-quote (make-mal-symbol "quote"))
  45 (defvar mal-quasiquote (make-mal-symbol "quasiquote"))
  46 (defvar mal-unquote (make-mal-symbol "unquote"))
  47 (defvar mal-splice-unquote (make-mal-symbol "splice-unquote"))
  48 (defvar mal-cons (make-mal-symbol "cons"))
  49 (defvar mal-concat (make-mal-symbol "concat"))
  50 (defvar mal-defmacro! (make-mal-symbol "defmacro!"))
  51 (defvar mal-macroexpand (make-mal-symbol "macroexpand"))
  52 (defvar mal-try* (make-mal-symbol "try*"))
  53 (defvar mal-catch* (make-mal-symbol "catch*"))
  54 (defvar mal-throw (make-mal-symbol "throw"))
  55
  56 (defun eval-sequence (sequence env)
  57   (map 'list
  58        (lambda (ast) (mal-eval ast env))
  59        (mal-data-value sequence)))
  60
  61 (defun eval-hash-map (hash-map env)
  62   (let ((hash-map-value (mal-data-value hash-map))
  63         (new-hash-table (make-mal-value-hash-table)))
  64     (genhash:hashmap (lambda (key value)
  65                        (setf (genhash:hashref (mal-eval key env) new-hash-table)
  66                              (mal-eval value env)))
  67                      hash-map-value)
  68     (make-mal-hash-map new-hash-table)))
  69
  70 (defun eval-ast (ast env)
  71   (switch-mal-type ast
  72     (types:symbol (env:get-env env ast))
  73     (types:list (eval-sequence ast env))
  74     (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
  75     (types:hash-map (eval-hash-map ast env))
  76     (types:any ast)))
  77
  78 (defun is-pair (value)
  79   (and (or (mal-list-p value)
  80            (mal-vector-p value))
  81        (< 0 (length (mal-data-value value)))))
  82
  83 (defun quasiquote (ast)
  84   (if (not (is-pair ast))
  85       (make-mal-list (list mal-quote ast))
  86       (let ((forms (map 'list #'identity (mal-data-value ast))))
  87         (cond
  88           ((mal-data-value= mal-unquote (first forms))
  89            (second forms))
  90
  91           ((and (is-pair (first forms))
  92                 (mal-data-value= mal-splice-unquote
  93                                  (first (mal-data-value (first forms)))))
  94            (make-mal-list (list mal-concat
  95                                 (second (mal-data-value (first forms)))
  96                                 (quasiquote (make-mal-list (cdr forms))))))
  97
  98           (t (make-mal-list (list mal-cons
  99                                   (quasiquote (first forms))
 100                                   (quasiquote (make-mal-list (cdr forms))))))))))
 101
 102 (defun is-macro-call (ast env)
 103   (when (mal-list-p ast)
 104     (let* ((func-symbol (first (mal-data-value ast)))
 105            (func (when (mal-symbol-p func-symbol)
 106                    (env:find-env env func-symbol))))
 107       (and func
 108            (mal-fn-p func)
 109            (cdr (assoc :is-macro (mal-data-attrs func)))))))
 110
 111 (defun mal-macroexpand (ast env)
 112   (loop
 113      while (is-macro-call ast env)
 114      do (let* ((forms (mal-data-value ast))
 115                (func (env:get-env env (first forms))))
 116           (setf ast (apply (mal-data-value func)
 117                            (cdr forms)))))
 118   ast)
 119
 120 (defun mal-read (string)
 121   (reader:read-str string))
 122
 123 (defun mal-eval (ast env)
 124   (loop
 125      do (setf ast (mal-macroexpand ast env))
 126      do (cond
 127           ((null ast) (return mal-nil))
 128           ((not (mal-list-p ast)) (return (eval-ast ast env)))
 129           ((zerop (length (mal-data-value ast))) (return ast))
 130           (t (let ((forms (mal-data-value ast)))
 131                (cond
 132                  ((mal-data-value= mal-quote (first forms))
 133                   (return (second forms)))
 134
 135                  ((mal-data-value= mal-quasiquote (first forms))
 136                   (setf ast (quasiquote (second forms))))
 137
 138                  ((mal-data-value= mal-macroexpand (first forms))
 139                   (return (mal-macroexpand (second forms) env)))
 140
 141                  ((mal-data-value= mal-def! (first forms))
 142                   (return (env:set-env env (second forms) (mal-eval (third forms) env))))
 143
 144                  ((mal-data-value= mal-defmacro! (first forms))
 145                   (let ((value (mal-eval (third forms) env)))
 146                     (return (if (mal-fn-p value)
 147                                 (env:set-env env
 148                                              (second forms)
 149                                              (progn
 150                                                (setf (cdr (assoc :is-macro (mal-data-attrs value))) t)
 151                                                value))
 152                                 (error 'invalid-function
 153                                        :form value
 154                                        :context "macro")))))
 155
 156                  ((mal-data-value= mal-let* (first forms))
 157                   (let ((new-env (env:create-mal-env :parent env))
 158                         (bindings (utils:listify (mal-data-value (second forms)))))
 159
 160                     (mapcar (lambda (binding)
 161                               (env:set-env new-env
 162                                            (car binding)
 163                                            (mal-eval (or (cdr binding)
 164                                                          mal-nil)
 165                                                      new-env)))
 166                             (loop
 167                                for (symbol value) on bindings
 168                                by #'cddr
 169                                collect (cons symbol value)))
 170                     (setf ast (third forms)
 171                           env new-env)))
 172
 173                  ((mal-data-value= mal-do (first forms))
 174                   (mapc (lambda (form) (mal-eval form env))
 175                         (butlast (cdr forms)))
 176                   (setf ast (car (last forms))))
 177
 178                  ((mal-data-value= mal-if (first forms))
 179                   (let ((predicate (mal-eval (second forms) env)))
 180                     (setf ast (if (or (mal-data-value= predicate mal-nil)
 181                                       (mal-data-value= predicate mal-false))
 182                                   (fourth forms)
 183                                   (third forms)))))
 184
 185                  ((mal-data-value= mal-fn* (first forms))
 186                   (return (let ((arglist (second forms))
 187                                 (body (third forms)))
 188                             (make-mal-fn (lambda (&rest args)
 189                                            (mal-eval body (env:create-mal-env :parent env
 190                                                                               :binds (listify (mal-data-value arglist))
 191                                                                               :exprs args)))
 192                                          :attrs (list (cons :params arglist)
 193                                                       (cons :ast body)
 194                                                       (cons :env env)
 195                                                       (cons :is-macro nil))))))
 196
 197                  ((mal-data-value= mal-try* (first forms))
 198                   (if (not (third forms))
 199                     (return (mal-eval (second forms) env))
 200                     (handler-case
 201                         (return (mal-eval (second forms) env))
 202                       (error (condition)
 203                         (let ((catch-forms (mal-data-value (third forms))))
 204                           (when (mal-data-value= mal-catch*
 205                                                  (first catch-forms))
 206                             (return (mal-eval (third catch-forms)
 207                                               (env:create-mal-env :parent env
 208                                                                   :binds (list (second catch-forms))
 209                                                                   :exprs (list (if (typep condition 'mal-user-exception)
 210                                                                                    (mal-exception-data condition)
 211                                                                                    (make-mal-string (format nil "~a" condition)))))))))))))
 212
 213                  (t (let* ((evaluated-list (eval-ast ast env))
 214                            (function (car evaluated-list)))
 215                       ;; If first element is a mal function unwrap it
 216                       (cond ((mal-fn-p function)
 217                              (let* ((attrs (mal-data-attrs function)))
 218                                (setf ast (cdr (assoc :ast attrs))
 219                                      env (env:create-mal-env :parent (cdr (assoc :env attrs))
 220                                                              :binds (map 'list
 221                                                                          #'identity
 222                                                                          (mal-data-value (cdr (assoc :params attrs))))
 223                                                              :exprs (cdr evaluated-list)))))
 224                             ((mal-builtin-fn-p function)
 225                              (return (apply (mal-data-value function)
 226                                             (cdr evaluated-list))))
 227                             (t (error 'invalid-function
 228                                       :form function
 229                                       :context "apply")))))))))))
 230
 231 (defun mal-print (expression)
 232   (printer:pr-str expression))
 233
 234 (defun rep (string)
 235   (handler-case
 236       (mal-print (mal-eval (mal-read string) *repl-env*))
 237     (mal-error (condition)
 238       (format nil "Error: ~a" condition))
 239     (mal-runtime-exception (condition)
 240       (format nil "Exception: ~a" condition))
 241     (mal-user-exception (condition)
 242       (format nil "Exception: ~a" (pr-str (mal-exception-data condition))))
 243     (error (condition)
 244       (format nil "Internal error: ~a" condition))))
 245
 246 (env:set-env *repl-env*
 247              (make-mal-symbol "eval")
 248              (make-mal-builtin-fn (lambda (ast)
 249                                     (mal-eval ast *repl-env*))))
 250
 251 (rep "(def! not (fn* (a) (if a false true)))")
 252 (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 253 (rep "(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw \"odd number of forms to cond\")) (cons 'cond (rest (rest xs)))))))")
 254 (rep "(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))")
 255
 256 (defvar *use-readline-p* nil)
 257
 258 (defun complete-toplevel-symbols (input &rest ignored)
 259   (declare (ignorable ignored))
 260
 261   (let (candidates)
 262     (loop for key being the hash-keys of (env:mal-env-bindings *repl-env*)
 263        when (let ((pos (search input key))) (and pos (zerop pos)))
 264        do (push key candidates))
 265
 266     (if (= 1 (length candidates))
 267         (cons (car candidates) candidates)
 268         (cons (apply #'utils:common-prefix candidates) candidates))))
 269
 270 (defun raw-input (prompt)
 271   (format *standard-output* prompt)
 272   (force-output *standard-output*)
 273   (read-line *standard-input* nil))
 274
 275 (defun mal-readline (prompt)
 276   (if *use-readline-p*
 277       (rl:readline :prompt prompt :add-history t :novelty-check #'string/=)
 278       (raw-input prompt)))
 279
 280 (defun mal-writeline (string)
 281   (when string
 282     (write-line string)
 283     (force-output *standard-output*)))
 284
 285 (defun repl ()
 286   (loop do (let ((line (mal-readline "user> ")))
 287              (if line
 288                  (mal-writeline (rep line))
 289                  (return)))))
 290
 291 (defun run-file (file)
 292   (rep (format nil "(load-file \"~a\")" file)))
 293
 294 (defun main (&optional (argv nil argv-provided-p))
 295
 296   (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false")
 297                                   (string= (uiop:getenv "TERM") "dumb"))))
 298
 299   ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort
 300   ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment
 301   ;; variable which the test runner sets causing `read-line' on *standard-input*
 302   ;; to fail with an empty stream error. The following reinitializes the
 303   ;; standard streams
 304   ;;
 305   ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html
 306   #+clisp (setf *standard-input* (ext:make-stream :input)
 307                 *standard-output* (ext:make-stream :output :buffered t)
 308                 *error-output* (ext:make-stream :error :buffered t))
 309
 310   ;; CCL fails with a error while registering completion function
 311   ;; See also https://github.com/mrkkrp/cl-readline/issues/5
 312   #-ccl (rl:register-function :complete #'complete-toplevel-symbols)
 313
 314
 315   (let ((args (if argv-provided-p
 316                   argv
 317                   (cdr (utils:raw-command-line-arguments)))))
 318     (env:set-env *repl-env*
 319                  (make-mal-symbol "*ARGV*")
 320                  (make-mal-list (mapcar #'make-mal-string (cdr args))))
 321     (if (null args)
 322         (repl)
 323         (run-file (car args)))))
 324
 325 ;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an
 326 ;;; image containing foreign libraries is restored. The extra messages cause the
 327 ;;; MAL testcases to fail.
 328
 329 #+cmucl (progn
 330           (defvar *old-standard-output* *standard-output*
 331             "Keep track of current value standard output, this is restored after image restore completes")
 332
 333           (defun muffle-output ()
 334             (setf *standard-output* (make-broadcast-stream)))
 335
 336           (defun restore-output ()
 337             (setf *standard-output* *old-standard-output*))
 338
 339           (pushnew #'muffle-output ext:*after-save-initializations*)
 340           (setf ext:*after-save-initializations*
 341                 (append ext:*after-save-initializations* (list #'restore-output))))