[jackhill/mal.git] / common-lisp / step8_macros.lisp

(defpackage :mal
  (:use :common-lisp
        :types
        :env
        :reader
        :printer
        :core
        :utils)
  (:export :main))

(in-package :mal)

(define-condition invalid-function (types:mal-runtime-exception)
  ((form :initarg :form :reader form)
   (context :initarg :context :reader context))
  (:report (lambda (condition stream)
             (format stream
                     "Invalid function '~a' provided while ~a"
                     (printer:pr-str (form condition))
                     (if (string= (context condition) "apply")
                         "applying"
                         "defining macro")))))


(defvar *repl-env* (env:create-mal-env))

(dolist (binding core:ns)
  (env:set-env *repl-env*
               (car binding)
               (cdr binding)))

(defvar mal-def! (make-mal-symbol "def!"))
(defvar mal-let* (make-mal-symbol "let*"))
(defvar mal-do (make-mal-symbol "do"))
(defvar mal-if (make-mal-symbol "if"))
(defvar mal-fn* (make-mal-symbol "fn*"))
(defvar mal-quote (make-mal-symbol "quote"))
(defvar mal-quasiquote (make-mal-symbol "quasiquote"))
(defvar mal-unquote (make-mal-symbol "unquote"))
(defvar mal-splice-unquote (make-mal-symbol "splice-unquote"))
(defvar mal-cons (make-mal-symbol "cons"))
(defvar mal-concat (make-mal-symbol "concat"))
(defvar mal-defmacro! (make-mal-symbol "defmacro!"))
(defvar mal-macroexpand (make-mal-symbol "macroexpand"))

(defun eval-sequence (sequence env)
  (map 'list
       (lambda (ast) (mal-eval ast env))
       (types:mal-data-value sequence)))

(defun eval-hash-map (hash-map env)
  (let ((hash-map-value (types:mal-data-value hash-map))
        (new-hash-table (types:make-mal-value-hash-table)))
    (genhash:hashmap (lambda (key value)
                       (setf (genhash:hashref (mal-eval key env) new-hash-table)
                             (mal-eval value env)))
                     hash-map-value)
    (types:make-mal-hash-map new-hash-table)))

(defun eval-ast (ast env)
  (switch-mal-type ast
    (types:symbol (env:get-env env ast))
    (types:list (eval-sequence ast env))
    (types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
    (types:hash-map (eval-hash-map ast env))
    (types:any ast)))

(defun is-pair (value)
  (and (or (mal-list-p value)
           (mal-vector-p value))
       (< 0 (length (types:mal-data-value value)))))

(defun quasiquote (ast)
  (if (not (is-pair ast))
      (types:make-mal-list (list mal-quote ast))
      (let ((forms (map 'list #'identity (types:mal-data-value ast))))
        (cond
          ((types:mal-data-value= mal-unquote (first forms))
           (second forms))

          ((and (is-pair (first forms))
                (types:mal-data-value= mal-splice-unquote
                            (first (types:mal-data-value (first forms)))))
           (types:make-mal-list (list mal-concat
                                      (second (types:mal-data-value (first forms)))
                                      (quasiquote (make-mal-list (cdr forms))))))

          (t (types:make-mal-list (list mal-cons
                                        (quasiquote (first forms))
                                        (quasiquote (make-mal-list (cdr forms))))))))))

(defun is-macro-call (ast env)
  (when (types:mal-list-p ast)
    (let* ((func-symbol (first (types:mal-data-value ast)))
           (func (when (types:mal-symbol-p func-symbol)
                   (env:find-env env func-symbol))))
      (and func
           (types:mal-fn-p func)
           (cdr (assoc 'is-macro (types:mal-data-attrs func)))))))

(defun mal-macroexpand (ast env)
  (loop
     while (is-macro-call ast env)
     do (let* ((forms (types:mal-data-value ast))
               (func (env:get-env env (first forms))))
          (setf ast (apply (types:mal-data-value func)
                           (cdr forms)))))
  ast)

(defun mal-read (string)
  (reader:read-str string))

(defun mal-eval (ast env)
  (loop
     do (setf ast (mal-macroexpand ast env))
     do (cond
          ((null ast) (return types:mal-nil))
          ((not (types:mal-list-p ast)) (return (eval-ast ast env)))
          ((zerop (length (types:mal-data-value ast))) (return ast))
          (t (let ((forms (types:mal-data-value ast)))
               (cond
                 ((types:mal-data-value= mal-quote (first forms))
                  (return (second forms)))

                 ((types:mal-data-value= mal-quasiquote (first forms))
                  (setf ast (quasiquote (second forms))))

                 ((types:mal-data-value= mal-macroexpand (first forms))
                  (return (mal-macroexpand (second forms) env)))

                 ((types:mal-data-value= mal-def! (first forms))
                  (return (env:set-env env (second forms) (mal-eval (third forms) env))))

                 ((types:mal-data-value= mal-defmacro! (first forms))
                  (let ((value (mal-eval (third forms) env)))
                    (return (if (types:mal-fn-p value)
                                (env:set-env env
                                             (second forms)
                                             (progn
                                               (setf (cdr (assoc 'is-macro (types:mal-data-attrs value))) t)
                                               value))
                                (error 'invalid-function
                                       :form value
                                       :context "macro")))))

                 ((types:mal-data-value= mal-let* (first forms))
                  (let ((new-env (env:create-mal-env :parent env))
                        ;; Convert a potential vector to a list
                        (bindings (map 'list
                                       #'identity
                                       (types:mal-data-value (second forms)))))

                    (mapcar (lambda (binding)
                              (env:set-env new-env
                                           (car binding)
                                           (mal-eval (or (cdr binding)
                                                         types:mal-nil)
                                                     new-env)))
                            (loop
                               for (symbol value) on bindings
                               by #'cddr
                               collect (cons symbol value)))
                    (setf ast (third forms)
                          env new-env)))

                 ((types:mal-data-value= mal-do (first forms))
                  (mapc (lambda (form) (mal-eval form env))
                        (butlast (cdr forms)))
                  (setf ast (car (last forms))))

                 ((types:mal-data-value= mal-if (first forms))
                  (let ((predicate (mal-eval (second forms) env)))
                    (setf ast (if (or (types:mal-data-value= predicate types:mal-nil)
                                      (types:mal-data-value= predicate types:mal-false))
                                  (fourth forms)
                                  (third forms)))))

                 ((types:mal-data-value= mal-fn* (first forms))
                  (return (let ((arglist (second forms))
                                (body (third forms)))
                            (types:make-mal-fn (lambda (&rest args)
                                                 (mal-eval body (env:create-mal-env :parent env
                                                                                    :binds (map 'list
                                                                                                #'identity
                                                                                                (types:mal-data-value arglist))
                                                                                    :exprs args)))
                                               :attrs (list (cons 'params arglist)
                                                            (cons 'ast body)
                                                            (cons 'env env)
                                                            (cons 'is-macro nil))))))

                 (t (let* ((evaluated-list (eval-ast ast env))
                           (function (car evaluated-list)))
                      ;; If first element is a mal function unwrap it
                      (cond ((types:mal-fn-p function)
                             (let* ((attrs (types:mal-data-attrs function)))
                               (setf ast (cdr (assoc 'ast attrs))
                                     env (env:create-mal-env :parent (cdr (assoc 'env attrs))
                                                             :binds (map 'list
                                                                         #'identity
                                                                         (types:mal-data-value (cdr (assoc 'params attrs))))
                                                             :exprs (cdr evaluated-list)))))
                            ((types:mal-builtin-fn-p function)
                             (return (apply (types:mal-data-value function)
                                            (cdr evaluated-list))))
                            (t (error 'invalid-function
                                      :form function
                                      :context "apply")))))))))))

(defun mal-print (expression)
  (printer:pr-str expression))

(defun rep (string)
  (handler-case
      (mal-print (mal-eval (mal-read string)
                           *repl-env*))
    (types:mal-error (condition)
      (format nil
              "~a"
              condition))
    (error (condition)
      (format nil
              "Internal error: ~a"
              condition))))

(env:set-env *repl-env*
             (types:make-mal-symbol "eval")
             (types:make-mal-builtin-fn (lambda (ast)
                                          (mal-eval ast *repl-env*))))

(rep "(def! not (fn* (a) (if a false true)))")
(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
(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)))))))")
(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))))))))")

(defvar *use-readline-p* nil)

(defun raw-input (prompt)
  (format *standard-output* prompt)
  (force-output *standard-output*)
  (read-line *standard-input* nil))

(defun mal-readline (prompt)
  (if *use-readline-p*
      (cl-readline:readline :prompt prompt
                            :add-history t
                            :novelty-check (lambda (old new)
                                             (not (string= old new))))
      (raw-input prompt)))

(defun mal-writeline (string)
  (when string
    (write-line string)
    (force-output *standard-output*)))

(defun repl ()
  (loop do (let ((line (mal-readline "user> ")))
             (if line
                 (mal-writeline (rep line))
                 (return)))))

(defun run-file (file)
  (rep (format nil "(load-file \"~a\")" file)))

(defun main (&optional (argv nil argv-provided-p))

  (setf *use-readline-p* (not (or (string= (uiop:getenv "PERL_RL") "false")
                                  (string= (uiop:getenv "TERM") "dumb"))))

  ;; In GNU CLISP's batch mode the standard-input seems to be set to some sort
  ;; of input string-stream, this interacts wierdly with the PERL_RL enviroment
  ;; variable which the test runner sets causing `read-line' on *standard-input*
  ;; to fail with an empty stream error. The following reinitializes the
  ;; standard streams
  ;;
  ;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html
  #+clisp (setf *standard-input* (ext:make-stream :input)
                *standard-output* (ext:make-stream :output :buffered t)
                *error-output* (ext:make-stream :error :buffered t))

  (let ((args (if argv-provided-p
                  argv
                  (cdr (utils:raw-command-line-arguments)))))
    (env:set-env *repl-env*
                 (types:make-mal-symbol "*ARGV*")
                 (types:wrap-value (cdr args) :listp t))
    (if (null args)
        (repl)
        (run-file (car args)))))

;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an
;;; image containing foreign libraries is restored. The extra messages cause the
;;; MAL testcases to fail

#+cmucl (progn
          (defvar *old-standard-output* *standard-output*
            "Keep track of current value standard output, this is restored after image restore completes")

          (defun muffle-output ()
            (setf *standard-output* (make-broadcast-stream)))

          (defun restore-output ()
            (setf *standard-output* *old-standard-output*))

          (pushnew #'muffle-output ext:*after-save-initializations*)
          (setf ext:*after-save-initializations*
                (append ext:*after-save-initializations* (list #'restore-output))))
Commit	Line	Data
c8ac1eda IA	1	(defpackage :mal
	2	(:use :common-lisp
	3	:types
	4	:env
	5	:reader
	6	:printer
	7	:core
	8	:utils)
	9	(:export :main))
	10
	11	(in-package :mal)
	12
	13	(define-condition invalid-function (types:mal-runtime-exception)
	14	((form :initarg :form :reader form)
	15	(context :initarg :context :reader context))
	16	(:report (lambda (condition stream)
	17	(format stream
	18	"Invalid function '~a' provided while ~a"
	19	(printer:pr-str (form condition))
	20	(if (string= (context condition) "apply")
	21	"applying"
	22	"defining macro")))))
	23
	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-def! (make-mal-symbol "def!"))
	33	(defvar mal-let* (make-mal-symbol "let*"))
	34	(defvar mal-do (make-mal-symbol "do"))
	35	(defvar mal-if (make-mal-symbol "if"))
	36	(defvar mal-fn* (make-mal-symbol "fn*"))
	37	(defvar mal-quote (make-mal-symbol "quote"))
	38	(defvar mal-quasiquote (make-mal-symbol "quasiquote"))
	39	(defvar mal-unquote (make-mal-symbol "unquote"))
	40	(defvar mal-splice-unquote (make-mal-symbol "splice-unquote"))
	41	(defvar mal-cons (make-mal-symbol "cons"))
	42	(defvar mal-concat (make-mal-symbol "concat"))
	43	(defvar mal-defmacro! (make-mal-symbol "defmacro!"))
	44	(defvar mal-macroexpand (make-mal-symbol "macroexpand"))
	45
	46	(defun eval-sequence (sequence env)
	47	(map 'list
	48	(lambda (ast) (mal-eval ast env))
	49	(types:mal-data-value sequence)))
	50
	51	(defun eval-hash-map (hash-map env)
	52	(let ((hash-map-value (types:mal-data-value hash-map))
	53	(new-hash-table (types:make-mal-value-hash-table)))
	54	(genhash:hashmap (lambda (key value)
	55	(setf (genhash:hashref (mal-eval key env) new-hash-table)
	56	(mal-eval value env)))
	57	hash-map-value)
	58	(types:make-mal-hash-map new-hash-table)))
	59
	60	(defun eval-ast (ast env)
	61	(switch-mal-type ast
	62	(types:symbol (env:get-env env ast))
	63	(types:list (eval-sequence ast env))
	64	(types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
65	(types:hash-map (eval-hash-map ast env))
66	(types:any ast)))
67
68	(defun is-pair (value)
69	(and (or (mal-list-p value)
70	(mal-vector-p value))
71	(< 0 (length (types:mal-data-value value)))))
72
73	(defun quasiquote (ast)
74	(if (not (is-pair ast))
75	(types:make-mal-list (list mal-quote ast))
76	(let ((forms (map 'list #'identity (types:mal-data-value ast))))
77	(cond
78	((types:mal-data-value= mal-unquote (first forms))
79	(second forms))
80
81	((and (is-pair (first forms))
82	(types:mal-data-value= mal-splice-unquote
83	(first (types:mal-data-value (first forms)))))
84	(types:make-mal-list (list mal-concat
85	(second (types:mal-data-value (first forms)))
86	(quasiquote (make-mal-list (cdr forms))))))
87
88	(t (types:make-mal-list (list mal-cons
89	(quasiquote (first forms))
90	(quasiquote (make-mal-list (cdr forms))))))))))
91
92	(defun is-macro-call (ast env)
93	(when (types:mal-list-p ast)
94	(let* ((func-symbol (first (types:mal-data-value ast)))
95	(func (when (types:mal-symbol-p func-symbol)
96	(env:find-env env func-symbol))))
97	(and func
98	(types:mal-fn-p func)
99	(cdr (assoc 'is-macro (types:mal-data-attrs func)))))))
100
101	(defun mal-macroexpand (ast env)
102	(loop
103	while (is-macro-call ast env)
104	do (let* ((forms (types:mal-data-value ast))
105	(func (env:get-env env (first forms))))
106	(setf ast (apply (types:mal-data-value func)
107	(cdr forms)))))
108	ast)
109
110	(defun mal-read (string)
111	(reader:read-str string))
112
113	(defun mal-eval (ast env)
114	(loop
115	do (setf ast (mal-macroexpand ast env))
116	do (cond
117	((null ast) (return types:mal-nil))
118	((not (types:mal-list-p ast)) (return (eval-ast ast env)))
119	((zerop (length (types:mal-data-value ast))) (return ast))
120	(t (let ((forms (types:mal-data-value ast)))
121	(cond
122	((types:mal-data-value= mal-quote (first forms))
123	(return (second forms)))
124
125	((types:mal-data-value= mal-quasiquote (first forms))
126	(setf ast (quasiquote (second forms))))
127
128	((types:mal-data-value= mal-macroexpand (first forms))
129	(return (mal-macroexpand (second forms) env)))
130
131	((types:mal-data-value= mal-def! (first forms))
132	(return (env:set-env env (second forms) (mal-eval (third forms) env))))
133
134	((types:mal-data-value= mal-defmacro! (first forms))
135	(let ((value (mal-eval (third forms) env)))
136	(return (if (types:mal-fn-p value)
137	(env:set-env env
138	(second forms)
139	(progn
140	(setf (cdr (assoc 'is-macro (types:mal-data-attrs value))) t)
141	value))
142	(error 'invalid-function
143	:form value
144	:context "macro")))))
145
146	((types:mal-data-value= mal-let* (first forms))
147	(let ((new-env (env:create-mal-env :parent env))
148	;; Convert a potential vector to a list
149	(bindings (map 'list
150	#'identity
151	(types:mal-data-value (second forms)))))
152
153	(mapcar (lambda (binding)
154	(env:set-env new-env
155	(car binding)
156	(mal-eval (or (cdr binding)
157	types:mal-nil)
158	new-env)))
159	(loop
160	for (symbol value) on bindings
161	by #'cddr
162	collect (cons symbol value)))
163	(setf ast (third forms)
164	env new-env)))
165
166	((types:mal-data-value= mal-do (first forms))
167	(mapc (lambda (form) (mal-eval form env))
168	(butlast (cdr forms)))
169	(setf ast (car (last forms))))
170
171	((types:mal-data-value= mal-if (first forms))
172	(let ((predicate (mal-eval (second forms) env)))
173	(setf ast (if (or (types:mal-data-value= predicate types:mal-nil)
174	(types:mal-data-value= predicate types:mal-false))
175	(fourth forms)
176	(third forms)))))
177
178	((types:mal-data-value= mal-fn* (first forms))
179	(return (let ((arglist (second forms))
180	(body (third forms)))
181	(types:make-mal-fn (lambda (&rest args)
182	(mal-eval body (env:create-mal-env :parent env
183	:binds (map 'list
184	#'identity
185	(types:mal-data-value arglist))
186	:exprs args)))
187	:attrs (list (cons 'params arglist)
188	(cons 'ast body)
189	(cons 'env env)
190	(cons 'is-macro nil))))))
191
192	(t (let* ((evaluated-list (eval-ast ast env))
193	(function (car evaluated-list)))
194	;; If first element is a mal function unwrap it
195	(cond ((types:mal-fn-p function)
196	(let* ((attrs (types:mal-data-attrs function)))
197	(setf ast (cdr (assoc 'ast attrs))
198	env (env:create-mal-env :parent (cdr (assoc 'env attrs))
199	:binds (map 'list
200	#'identity
201	(types:mal-data-value (cdr (assoc 'params attrs))))
202	:exprs (cdr evaluated-list)))))
203	((types:mal-builtin-fn-p function)
204	(return (apply (types:mal-data-value function)
205	(cdr evaluated-list))))
206	(t (error 'invalid-function
207	:form function
208	:context "apply")))))))))))
209
210	(defun mal-print (expression)
211	(printer:pr-str expression))
212
213	(defun rep (string)
214	(handler-case
215	(mal-print (mal-eval (mal-read string)
216	repl-env))
217	(types:mal-error (condition)
218	(format nil
219	"~a"
220	condition))
221	(error (condition)
222	(format nil
223	"Internal error: ~a"
224	condition))))
225
226	(env:set-env repl-env
227	(types:make-mal-symbol "eval")
228	(types:make-mal-builtin-fn (lambda (ast)
229	(mal-eval ast repl-env))))
230
231	(rep "(def! not (fn* (a) (if a false true)))")
232	(rep "(def! load-file (fn* (f) (eval (read-string (str \"(do \" (slurp f) \")\")))))")
233	(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)))))))")
234	(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))))))))")
235
236	(defvar use-readline-p nil)
237
238	(defun raw-input (prompt)
239	(format standard-output prompt)
240	(force-output standard-output)
241	(read-line standard-input nil))
242
243	(defun mal-readline (prompt)
244	(if use-readline-p
245	(cl-readline:readline :prompt prompt
246	:add-history t
247	:novelty-check (lambda (old new)
248	(not (string= old new))))
249	(raw-input prompt)))
250
251	(defun mal-writeline (string)
252	(when string
253	(write-line string)
254	(force-output standard-output)))
255
256	(defun repl ()
257	(loop do (let ((line (mal-readline "user> ")))
258	(if line
259	(mal-writeline (rep line))
260	(return)))))
261
262	(defun run-file (file)
263	(rep (format nil "(load-file \"~a\")" file)))
264
265	(defun main (&optional (argv nil argv-provided-p))
89676a9f	266
c8ac1eda IA	267	(setf use-readline-p (not (or (string= (uiop:getenv "PERL_RL") "false")
	268	(string= (uiop:getenv "TERM") "dumb"))))
	269
89676a9f IA	270	;; In GNU CLISP's batch mode the standard-input seems to be set to some sort
	271	;; of input string-stream, this interacts wierdly with the PERL_RL enviroment
	272	;; variable which the test runner sets causing `read-line' on standard-input
	273	;; to fail with an empty stream error. The following reinitializes the
	274	;; standard streams
	275	;;
	276	;; See http://www.gnu.org/software/clisp/impnotes/streams-interactive.html
	277	#+clisp (setf standard-input (ext:make-stream :input)
	278	standard-output (ext:make-stream :output :buffered t)
	279	error-output (ext:make-stream :error :buffered t))
	280
c8ac1eda IA	281	(let ((args (if argv-provided-p
	282	argv
	283	(cdr (utils:raw-command-line-arguments)))))
	284	(env:set-env repl-env
	285	(types:make-mal-symbol "ARGV")
	286	(types:wrap-value (cdr args) :listp t))
	287	(if (null args)
	288	(repl)
	289	(run-file (car args)))))
033f64c4 IA	290
	291	;;; Workaround for CMUCL's printing of "Reloaded library ... " messages when an
	292	;;; image containing foreign libraries is restored. The extra messages cause the
	293	;;; MAL testcases to fail
	294
	295	#+cmucl (progn
	296	(defvar old-standard-output standard-output
	297	"Keep track of current value standard output, this is restored after image restore completes")
	298
	299	(defun muffle-output ()
	300	(setf standard-output (make-broadcast-stream)))
	301
	302	(defun restore-output ()
	303	(setf standard-output old-standard-output))
	304
	305	(pushnew #'muffle-output ext:after-save-initializations)
	306	(setf ext:after-save-initializations
	307	(append ext:after-save-initializations (list #'restore-output))))