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