common_lisp/step8_macros.lisp

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