clisp/step8_macros.lisp

   1 (require "dependencies")
   2
   3 (defpackage :mal
   4   (:use :common-lisp
   5         :readline
   6         :types
   7         :env
   8         :reader
   9         :printer
  10         :core))
  11
  12 (in-package :mal)
  13
  14 (define-condition invalid-function (types:mal-error)
  15   ((form :initarg :form :reader form)
  16    (context :initarg :context :reader context))
  17   (:report (lambda (condition stream)
  18              (format stream
  19                      "Invalid function '~a' provided while ~a"
  20                      (printer:pr-str (form condition))
  21                      (if (string= (context condition) "apply")
  22                          "applying"
  23                          "defining macro")))))
  24
  25 (defvar *repl-env* (env:create-mal-env))
  26
  27 (dolist (binding core:ns)
  28   (env:set-env *repl-env*
  29                (car binding)
  30                (cdr binding)))
  31
  32 (defvar mal-quote (make-mal-symbol "quote"))
  33 (defvar mal-quasiquote (make-mal-symbol "quasiquote"))
  34 (defvar mal-unquote (make-mal-symbol "unquote"))
  35 (defvar mal-splice-unquote (make-mal-symbol "splice-unquote"))
  36 (defvar mal-cons (make-mal-symbol "cons"))
  37 (defvar mal-concat (make-mal-symbol "concat"))
  38 (defvar mal-macroexpand (make-mal-symbol "macroexpand"))
  39 (defvar mal-def! (make-mal-symbol "def!"))
  40 (defvar mal-defmacro! (make-mal-symbol "defmacro!"))
  41 (defvar mal-let* (make-mal-symbol "let*"))
  42 (defvar mal-do (make-mal-symbol "do"))
  43 (defvar mal-if (make-mal-symbol "if"))
  44 (defvar mal-fn* (make-mal-symbol "fn*"))
  45
  46 (env:set-env *repl-env*
  47              (types:make-mal-symbol "eval")
  48              (types:make-mal-builtin-fn (lambda (ast)
  49                                           (mal-eval ast *repl-env*))))
  50
  51 (defun eval-sequence (sequence env)
  52   (map 'list
  53        (lambda (ast) (mal-eval ast env))
  54        (mal-data-value sequence)))
  55
  56 (defun eval-hash-map (hash-map env)
  57   (let ((hash-map-value (mal-data-value hash-map))
  58         (new-hash-table (make-hash-table :test 'types:mal-value=)))
  59     (loop
  60        for key being the hash-keys of hash-map-value
  61        do (setf (gethash (mal-eval key env) new-hash-table)
  62                 (mal-eval (gethash key hash-map-value) env)))
  63     (make-mal-hash-map new-hash-table)))
  64
  65 (defun eval-ast (ast env)
  66   (switch-mal-type ast
  67     (types:symbol (env:get-env env ast))
  68     (types:list (eval-sequence ast env))
  69     (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
  70     (types:hash-map (eval-hash-map ast env))
  71     (types:any ast)))
  72
  73 (defun is-pair (value)
  74   (and (or (mal-list-p value)
  75            (mal-vector-p value))
  76        (not (zerop (length (mal-data-value value))))))
  77
  78 (defun quasiquote (ast)
  79   (if (not (is-pair ast))
  80       (types:make-mal-list (list mal-quote
  81                                  ast))
  82       (let ((forms (map 'list #'identity (mal-data-value ast))))
  83         (cond
  84           ((mal-value= mal-unquote (first forms))
  85            (second forms))
  86
  87           ((and (is-pair (first forms))
  88                 (mal-value= mal-splice-unquote
  89                             (first (mal-data-value (first forms)))))
  90            (types:make-mal-list (list mal-concat
  91                                       (second (mal-data-value (first forms)))
  92                                       (quasiquote (make-mal-list (cdr forms))))))
  93
  94           (t (types:make-mal-list (list mal-cons
  95                                         (quasiquote (first forms))
  96                                         (quasiquote (make-mal-list (cdr forms))))))))))
  97
  98 (defun is-macro-call (ast env)
  99   (when (and (types:mal-list-p ast)
 100              (not (zerop (length (mal-data-value ast)))))
 101     (let* ((func-symbol (first (mal-data-value ast)))
 102            (func (when (types:mal-symbol-p func-symbol)
 103                    (env:find-env env func-symbol))))
 104       (and func
 105            (types:mal-fn-p func)
 106            (cdr (assoc 'is-macro (types:mal-data-attrs func)))))))
 107
 108 (defun mal-macroexpand (ast env)
 109   (loop
 110      while (is-macro-call ast env)
 111      do (let* ((forms (types:mal-data-value ast))
 112                (func (env:get-env env (first forms))))
 113           (setf ast (apply (mal-data-value func)
 114                            (cdr forms)))))
 115   ast)
 116
 117 (defun mal-eval (ast env)
 118   (loop
 119      do (setf ast (mal-macroexpand ast env))
 120      do (cond
 121           ((null ast) (return types:mal-nil))
 122           ((not (types:mal-list-p ast)) (return (eval-ast ast env)))
 123           ((zerop (length (mal-data-value ast))) (return ast))
 124           (t (let ((forms (mal-data-value ast)))
 125                (cond
 126                  ((mal-value= mal-quote (first forms))
 127                   (return (second forms)))
 128
 129                  ((mal-value= mal-quasiquote (first forms))
 130                   (setf ast (quasiquote (second forms))))
 131
 132                  ((mal-value= mal-macroexpand (first forms))
 133                   (return (mal-macroexpand (second forms) env)))
 134
 135                  ((mal-value= mal-def! (first forms))
 136                   (return (env:set-env env (second forms) (mal-eval (third forms) env))))
 137
 138                  ((mal-value= mal-defmacro! (first forms))
 139                   (let ((value (mal-eval (third forms) env)))
 140                     (return (if (types:mal-fn-p value)
 141                                 (env:set-env env
 142                                              (second forms)
 143                                              (progn
 144                                                (setf (cdr (assoc 'is-macro (types:mal-data-attrs value))) t)
 145                                                value))
 146                                 (error 'invalid-function
 147                                        :form value
 148                                        :context "macro")))))
 149
 150                  ((mal-value= mal-let* (first forms))
 151                   (let ((new-env (env:create-mal-env :parent env))
 152                         ;; Convert a potential vector to a list
 153                         (bindings (map 'list
 154                                        #'identity
 155                                        (mal-data-value (second forms)))))
 156
 157                     (mapcar (lambda (binding)
 158                               (env:set-env new-env
 159                                            (car binding)
 160                                            (mal-eval (or (cdr binding)
 161                                                          types:mal-nil)
 162                                                      new-env)))
 163                             (loop
 164                                for (symbol value) on bindings
 165                                by #'cddr
 166                                collect (cons symbol value)))
 167                     (setf ast (third forms)
 168                           env new-env)))
 169
 170                  ((mal-value= mal-do (first forms))
 171                   (mapc (lambda (form) (mal-eval form env))
 172                         (butlast (cdr forms)))
 173                   (setf ast (car (last forms))))
 174
 175                  ((mal-value= mal-if (first forms))
 176                   (let ((predicate (mal-eval (second forms) env)))
 177                     (setf ast (if (or (mal-value= predicate types:mal-nil)
 178                                       (mal-value= predicate types:mal-false))
 179                                   (fourth forms)
 180                                   (third forms)))))
 181
 182                  ((mal-value= mal-fn* (first forms))
 183                   (return (let ((arglist (second forms))
 184                                 (body (third forms)))
 185                             (types:make-mal-fn (lambda (&rest args)
 186                                                  (mal-eval body (env:create-mal-env :parent env
 187                                                                                     :binds (map 'list
 188                                                                                                 #'identity
 189                                                                                                 (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                  (t (let* ((evaluated-list (eval-ast ast env))
 197                            (function (car evaluated-list)))
 198                       ;; If first element is a mal function unwrap it
 199                       (cond ((types:mal-fn-p function)
 200                              (let* ((attrs (types:mal-data-attrs function)))
 201                                (setf ast (cdr (assoc 'ast attrs))
 202                                      env (env:create-mal-env :parent (cdr (assoc 'env attrs))
 203                                                              :binds (map 'list
 204                                                                          #'identity
 205                                                                          (mal-data-value (cdr (assoc 'params attrs))))
 206                                                              :exprs (cdr evaluated-list)))))
 207                             ((types:mal-builtin-fn-p function)
 208                              (return (apply (mal-data-value function)
 209                                             (cdr evaluated-list))))
 210                             (t (error 'invalid-function
 211                                       :form function
 212                                       :context "apply")))))))))))
 213
 214 (defun mal-read (string)
 215   (reader:read-str string))
 216
 217 (defun mal-print (expression)
 218   (printer:pr-str expression))
 219
 220 (defun rep (string)
 221   (handler-case
 222       (mal-print (mal-eval (mal-read string)
 223                            *repl-env*))
 224     (types:mal-error (condition)
 225       (format nil
 226               "~a"
 227               condition))
 228     (error (condition)
 229       (format nil
 230               "Internal error: ~a"
 231               condition))))
 232
 233 (rep "(def! not (fn* (a) (if a false true)))")
 234 (rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
 235 (rep "(def! *ARGV* (list))")
 236 (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)))))))")
 237 (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))))))))")
 238
 239 (env:set-env *repl-env*
 240              (types:make-mal-symbol "*ARGV*")
 241              (types:wrap-value (cdr common-lisp-user::*args*)
 242                                :listp t))
 243
 244 ;; Readline setup
 245 ;;; The test runner sets this environment variable, in which case we do
 246 ;;; use readline since tests do not work with the readline interface
 247 (defvar use-readline-p (not (string= (ext:getenv "PERL_RL") "false")))
 248
 249 (defvar *history-file* (namestring (merge-pathnames (user-homedir-pathname)
 250                                                          ".mal-clisp-history")))
 251
 252 (defun load-history ()
 253   (readline:read-history *history-file*))
 254
 255 (defun save-history ()
 256   (readline:write-history *history-file*))
 257
 258 ;; Setup history
 259 (when use-readline-p
 260   (load-history))
 261
 262 (defun raw-input (prompt)
 263   (format *standard-output* prompt)
 264   (force-output *standard-output*)
 265   (read-line *standard-input* nil))
 266
 267 (defun mal-readline (prompt)
 268   (let ((input (if use-readline-p
 269                    (readline:readline prompt)
 270                    (raw-input prompt))))
 271     (when (and use-readline-p
 272                input
 273                (not (zerop (length input))))
 274       (readline:add-history input))
 275     input))
 276
 277 (defun mal-writeline (string)
 278   (when string
 279     (write-line string)))
 280
 281 (defun repl ()
 282   (loop do (let ((line (mal-readline "user> ")))
 283              (if line
 284                  (mal-writeline (rep line))
 285                  (return))))
 286   (when use-readline-p
 287     (save-history)))
 288
 289 (defun main ()
 290   (if (null common-lisp-user::*args*)
 291       ;; Do not start REPL inside Emacs
 292       (unless (member :swank *features*)
 293         (repl))
 294       (rep (format nil
 295                    "(load-file \"~a\")"
 296                    (car common-lisp-user::*args*)))))
 297
 298 (main)