2016-08-28 18:13:15 +03:00
|
|
|
(require "dependencies")
|
2016-08-17 21:32:43 +03:00
|
|
|
|
|
|
|
(defpackage :mal
|
2016-08-18 16:28:58 +03:00
|
|
|
(:use :common-lisp
|
|
|
|
:types
|
|
|
|
:env
|
|
|
|
:reader
|
|
|
|
:printer
|
|
|
|
:core))
|
2016-08-17 21:32:43 +03:00
|
|
|
|
|
|
|
(in-package :mal)
|
|
|
|
|
|
|
|
(defvar *repl-env* (make-instance 'env:mal-environment))
|
|
|
|
|
2016-08-18 16:28:58 +03:00
|
|
|
(dolist (binding core:ns)
|
|
|
|
(env:set-env *repl-env*
|
|
|
|
(car binding)
|
|
|
|
(cdr binding)))
|
2016-08-17 21:32:43 +03:00
|
|
|
|
|
|
|
(defun eval-sequence (sequence env)
|
|
|
|
(map 'list
|
|
|
|
(lambda (ast) (mal-eval ast env))
|
2016-08-28 15:28:06 +03:00
|
|
|
(mal-data-value sequence)))
|
2016-08-17 21:32:43 +03:00
|
|
|
|
|
|
|
(defun eval-hash-map (hash-map env)
|
2016-08-28 15:28:06 +03:00
|
|
|
(let ((hash-map-value (mal-data-value hash-map))
|
2016-08-17 21:32:43 +03:00
|
|
|
(new-hash-table (make-hash-table :test 'types:mal-value=)))
|
|
|
|
(loop
|
|
|
|
for key being the hash-keys of hash-map-value
|
|
|
|
do (setf (gethash key new-hash-table)
|
|
|
|
(mal-eval (gethash key hash-map-value) env)))
|
|
|
|
(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 eval-let* (forms env)
|
|
|
|
(let ((new-env (make-instance 'env:mal-environment
|
|
|
|
:parent env))
|
|
|
|
;; Convert a potential vector to a list
|
|
|
|
(bindings (map 'list
|
|
|
|
#'identity
|
2016-08-28 15:28:06 +03:00
|
|
|
(mal-data-value (second forms)))))
|
2016-08-17 21:32:43 +03:00
|
|
|
|
|
|
|
(mapcar (lambda (binding)
|
|
|
|
(env:set-env new-env
|
|
|
|
(car binding)
|
|
|
|
(mal-eval (or (cdr binding)
|
|
|
|
(types:make-mal-nil nil))
|
|
|
|
new-env)))
|
|
|
|
(loop
|
|
|
|
for (symbol value) on bindings
|
|
|
|
by #'cddr
|
|
|
|
collect (cons symbol value)))
|
|
|
|
|
|
|
|
(mal-eval (third forms) new-env)))
|
|
|
|
|
|
|
|
(defun eval-list (ast env)
|
2016-08-28 15:28:06 +03:00
|
|
|
(let ((forms (mal-data-value ast)))
|
2016-08-17 21:32:43 +03:00
|
|
|
(cond
|
2016-08-28 17:02:11 +03:00
|
|
|
((mal-value= (make-mal-symbol "def!") (first forms))
|
2016-08-17 21:32:43 +03:00
|
|
|
(env:set-env env (second forms) (mal-eval (third forms) env)))
|
2016-08-28 17:02:11 +03:00
|
|
|
((mal-value= (make-mal-symbol "let*") (first forms))
|
2016-08-17 21:32:43 +03:00
|
|
|
(eval-let* forms env))
|
2016-08-28 17:02:11 +03:00
|
|
|
((mal-value= (make-mal-symbol "do") (first forms))
|
2016-08-17 21:32:43 +03:00
|
|
|
(car (last (mapcar (lambda (form) (mal-eval form env))
|
|
|
|
(cdr forms)))))
|
2016-08-28 17:02:11 +03:00
|
|
|
((mal-value= (make-mal-symbol "if") (first forms))
|
2016-08-17 21:32:43 +03:00
|
|
|
(let ((predicate (mal-eval (second forms) env)))
|
|
|
|
(mal-eval (if (or (mal-value= predicate (types:make-mal-nil nil))
|
|
|
|
(mal-value= predicate (types:make-mal-boolean nil)))
|
|
|
|
(fourth forms)
|
|
|
|
(third forms))
|
|
|
|
env)))
|
2016-08-28 17:02:11 +03:00
|
|
|
((mal-value= (make-mal-symbol "fn*") (first forms))
|
2016-08-17 21:32:43 +03:00
|
|
|
(types:make-mal-fn (let ((arglist (second forms))
|
|
|
|
(body (third forms)))
|
|
|
|
(lambda (&rest args)
|
|
|
|
(mal-eval body (make-instance 'env:mal-environment
|
|
|
|
:parent env
|
|
|
|
:binds (map 'list
|
|
|
|
#'identity
|
2016-08-28 15:28:06 +03:00
|
|
|
(mal-data-value arglist))
|
2016-08-17 21:32:43 +03:00
|
|
|
:exprs args))))))
|
|
|
|
(t (let* ((evaluated-list (eval-ast ast env))
|
|
|
|
(function (car evaluated-list)))
|
|
|
|
;; If first element is a mal function unwrap it
|
2016-08-28 15:28:06 +03:00
|
|
|
(apply (mal-data-value function)
|
2016-08-17 21:32:43 +03:00
|
|
|
(cdr evaluated-list)))))))
|
|
|
|
|
|
|
|
(defun mal-read (string)
|
|
|
|
(reader:read-str string))
|
|
|
|
|
|
|
|
(defun mal-eval (ast env)
|
|
|
|
(cond
|
|
|
|
((null ast) (make-mal-nil nil))
|
|
|
|
((not (types:mal-list-p ast)) (eval-ast ast env))
|
2016-08-28 15:28:06 +03:00
|
|
|
((zerop (length (mal-data-value ast))) ast)
|
2016-08-17 21:32:43 +03:00
|
|
|
(t (eval-list ast env))))
|
|
|
|
|
|
|
|
(defun mal-print (expression)
|
|
|
|
(printer:pr-str expression))
|
|
|
|
|
|
|
|
(defun rep (string)
|
|
|
|
(handler-case
|
|
|
|
(mal-print (mal-eval (mal-read string)
|
|
|
|
*repl-env*))
|
|
|
|
(reader:eof (condition)
|
|
|
|
(format nil
|
|
|
|
"~a"
|
|
|
|
condition))
|
|
|
|
(env:undefined-symbol (condition)
|
2016-08-18 19:42:01 +03:00
|
|
|
(format nil
|
|
|
|
"~a"
|
|
|
|
condition))
|
|
|
|
(error (condition)
|
2016-08-17 21:32:43 +03:00
|
|
|
(format nil
|
|
|
|
"~a"
|
|
|
|
condition))))
|
|
|
|
|
2016-08-18 22:00:02 +03:00
|
|
|
(rep "(def! not (fn* (a) (if a false true)))")
|
|
|
|
|
2016-08-17 21:32:43 +03:00
|
|
|
(defun readline (prompt &optional (in-stream *standard-input*) (out-stream *standard-output*))
|
|
|
|
(format out-stream prompt)
|
|
|
|
(force-output out-stream)
|
|
|
|
(read-line in-stream nil))
|
|
|
|
|
|
|
|
(defun writeline (string)
|
|
|
|
(when string
|
|
|
|
(write-line string)))
|
|
|
|
|
|
|
|
(defun main ()
|
|
|
|
(loop do (let ((line (readline "user> ")))
|
|
|
|
(if line (writeline (rep line)) (return)))))
|
|
|
|
|
2016-08-18 19:42:01 +03:00
|
|
|
(main)
|