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