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