summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMatthias Andreas Benkard <code@mail.matthias.benkard.de>2013-07-09 17:25:35 +0200
committerMatthias Andreas Benkard <code@mail.matthias.benkard.de>2013-07-09 17:25:35 +0200
commit735d4c03e305dc4a962231cc01cbd7736c954434 (patch)
treeb30efcd5af98ebe3aaa6223107176ac0a817c638
Initial version of a Feeley-style interpreter.
-rw-r--r--TODO.org51
-rw-r--r--sb-eval2.lisp410
2 files changed, 461 insertions, 0 deletions
diff --git a/TODO.org b/TODO.org
new file mode 100644
index 0000000..c9e7799
--- /dev/null
+++ b/TODO.org
@@ -0,0 +1,51 @@
+* TODO Feeley interpreter
+** TODO special forms
+*** DONE =block=
+*** DONE =catch=
+*** DONE =eval-when=
+*** DONE =flet=
+*** DONE =function=
+*** DONE =if=
+*** DONE =labels=
+*** DONE =lambda=
+*** DONE =let=
+*** DONE =let*=
+*** DONE =multiple-value-call=
+*** DONE =multiple-value-prog1=
+*** DONE =multiple-value-setq=
+*** DONE =multiple-value-bind=
+*** DONE =progn=
+*** DONE =progv=
+*** DONE =quote=
+*** DONE =return-from=
+*** DONE =setq=
+*** DONE =the=
+*** DONE =throw=
+*** DONE =unwind-protect=
+*** DONE =sb!ext:truly-the=
+*** DONE =named-lambda= (/more or less done/)
+*** Batch 2:
+*** DONE =symbol-macrolet=
+*** DONE =go=
+*** DONE =tagbody=
+*** DONE =macrolet=
+*** TODO XXX =declare=
+*** TODO (=locally=)
+** TODO Declaration parsing
+** TODO variables/local functions
+*** TODO specials
+*** DONE lexicals
+*** DONE functions
+** TODO macro expansion
+*** TODO local
+**** Need to fix lambda lists.
+**** Hmm. Does the environment stuff work?
+*** TODO global
+**** Need to transform PREPARE-FORM contexts into native environments.
+** TODO definition?
+*** =defun=
+*** =defmacro=
+*** =defvar=
+*** =defparameter=
+*** =defconstant=
+** TODO partial evaluation
diff --git a/sb-eval2.lisp b/sb-eval2.lisp
new file mode 100644
index 0000000..0925998
--- /dev/null
+++ b/sb-eval2.lisp
@@ -0,0 +1,410 @@
+(defpackage "SB-EVAL2"
+ (:use "COMMON-LISP"))
+
+(in-package "SB-EVAL2")
+
+#+(or)
+(setq SB-EXT:*EVALUATOR-MODE* :interpret)
+
+(defvar *lexicals* nil)
+
+(defstruct lexical type offset)
+(defstruct ref value)
+
+(defstruct (environment (:constructor %make-environment))
+ variables
+ functions)
+(defun make-null-environment ()
+ (%make-environment :variables nil :functions nil))
+(defun make-environment (parent-environment)
+ (with-slots (variables functions)
+ parent-environment
+ (%make-environment :variables variables :functions functions)))
+
+(defstruct (context (:constructor %make-context))
+ block-tags
+ go-tags
+ symbol-macros
+ macros)
+(defun make-null-context ()
+ (%make-context :block-tags nil))
+(defun make-context (parent-context)
+ (with-slots (block-tags)
+ parent-context
+ (%make-context :block-tags block-tags)))
+(defun context-add-block-tag (context block tag)
+ (let ((new-context (make-context context)))
+ (with-slots (block-tags)
+ new-context
+ (setq block-tags (acons block tag block-tags)))
+ new-context))
+(defun context-block-tag (context block)
+ (let ((tag (cdr (assoc block (context-block-tags context)))))
+ (assert tag)
+ tag))
+(defun context-add-go-tags (context new-go-tags catch-tag)
+ (let ((new-context (make-context context)))
+ (with-slots (go-tags)
+ new-context
+ (dolist (new-go-tag new-go-tags)
+ (setq go-tags (acons new-go-tag catch-tag go-tags))))
+ new-context))
+(defun context-find-go-tag (context go-tag)
+ (cdr (assoc go-tag (context-go-tags context))))
+(defun context-add-symbol-macros (context bindings)
+ (let ((new-context (make-context context)))
+ (with-slots (symbol-macros)
+ new-context
+ (setq symbol-macros (append bindings symbol-macros)))
+ new-context))
+(defun context-add-macros (context bindings)
+ (let ((new-context (make-context context)))
+ (with-slots (macros)
+ new-context
+ (setq macros (append bindings macros)))
+ new-context))
+(defun parse-tagbody-tags-and-bodies (forms)
+ (let ((next-form (gensym))
+ (finishp nil))
+ (loop until finishp
+ collect
+ (let ((tag next-form)
+ (forms (loop until (symbolp (setq next-form (pop forms)))
+ collect next-form)))
+ (unless forms
+ (setq finishp t))
+ (cons tag forms)))))
+
+(defun prepare-ref (var context)
+ (declare (ignore context))
+ (lambda (env) (cdr (assoc var (environment-variables env) :test #'eq))))
+
+(defun prepare-function-ref (f context)
+ (declare (ignore context))
+ (lambda (env)
+ (let ((local-function-record (assoc f (environment-functions env) :test #'equal)))
+ (if local-function-record
+ (cdr local-function-record)
+ ;; Global functions can be called through their function names.
+ f))))
+
+(defun prepare-nil ()
+ (lambda (env) (declare (ignore env))))
+
+(defun prepare-function-call (f args context)
+ (let ((args* (mapcar (lambda (form) (prepare-form form context)) args)))
+ (lambda (env)
+ (apply (funcall f env)
+ (mapcar (lambda (x) (funcall x env)) args*)))))
+
+(defun prepare-progn (forms context)
+ (let ((body* (mapcar (lambda (form) (prepare-form form context)) forms)))
+ (lambda (env)
+ (let (result)
+ (dolist (form* body* result)
+ (setq result (funcall form* env)))))))
+
+(defun prepare-lambda (lambda-form context)
+ (destructuring-bind (lambda-list &rest body) lambda-form
+ ;; FIXME: SPECIAL declarations!
+ (let ((body* (prepare-progn body context)))
+ (lambda (env)
+ (lambda (&rest args)
+ ;; FIXME: non-simple lambda-lists
+ (let ((new-env (make-environment env)))
+ (loop for val in args
+ for var in lambda-list
+ do (push `(,var . ,val) (environment-variables new-env)))
+ (funcall body* new-env)))))))
+
+(defun context->native-environment (context)
+ ;;FIXME
+ context)
+
+(defun prepare-form (form &optional (context (make-null-context)))
+ ;;(declare (optimize speed (safety 0) (space 1) (debug 0)))
+ ;;(print form)
+ (values
+ (cond
+ ((sb-int:self-evaluating-p form)
+ (lambda (env) (declare (ignore env)) form))
+ (t
+ (etypecase form
+ (symbol
+ (let ((macro? (assoc form (context-symbol-macros context))))
+ (if macro?
+ (funcall (cdr macro?))
+ (prepare-ref form context))))
+ (cons
+ (case (first form)
+ ((if)
+ (destructuring-bind (a b c) (rest form)
+ (let ((a* (prepare-form a context))
+ (b* (prepare-form b context))
+ (c* (prepare-form c context)))
+ (lambda (env) (if (funcall a* env) (funcall b* env) (funcall c* env))))))
+ ((function)
+ (let ((fun-form (second form)))
+ (etypecase fun-form
+ (symbol
+ (prepare-function-ref fun-form context))
+ (cons
+ (ecase (first fun-form)
+ ((lambda)
+ (prepare-lambda (rest fun-form) context))
+ ((setf
+ (prepare-function-ref fun-form context))))))))
+ ((lambda)
+ (prepare-lambda (rest form) context))
+ ((setq)
+ (let ((binding-forms (rest form)))
+ (let ((bindings
+ (loop for (var valform) on binding-forms by #'cddr
+ collect var
+ collect (prepare-form valform context))))
+ (lambda (env)
+ (loop with env-vars = (environment-variables env)
+ for (var val*) on bindings by #'cddr
+ for result = (setf (cdr (assoc var env-vars)) (funcall val* env))
+ finally (return result))))))
+ ((catch)
+ (destructuring-bind (tag &body body) (rest form)
+ (let ((k (prepare-progn body context)))
+ (lambda (env)
+ (catch tag
+ (funcall k env))))))
+ ((block)
+ (destructuring-bind (name &body body) (rest form)
+ (let* ((tag (gensym (concatenate 'string "BLOCK-" (symbol-name name))))
+ (body* (prepare-progn body (context-add-block-tag context name tag))))
+ (lambda (env)
+ (catch tag
+ (funcall body* env))))))
+ ((declare)
+ ;;FIXME
+ (lambda (env) (declare (ignore env)) nil))
+ ((eval-when)
+ (destructuring-bind ((&rest times) &body body) (rest form)
+ (if (or (member :load-toplevel times)
+ (member :execute times)
+ (member 'load times)
+ (member 'eval times))
+ (prepare-progn body context)
+ (prepare-nil))))
+ ((flet)
+ (destructuring-bind (bindings &rest body) (rest form)
+ (let ((body* (prepare-progn body context))
+ (bindings* (mapcar (lambda (form)
+ (if (listp form)
+ (cons (first form)
+ (prepare-lambda (rest form) context))
+ (cons form (prepare-nil))))
+ bindings)))
+ (lambda (env)
+ (let ((new-env (make-environment env)))
+ (loop for (var . val) in bindings*
+ do (push `(,var . ,(funcall val env))
+ (environment-functions new-env)))
+ (funcall body* new-env))))))
+ ((labels)
+ (destructuring-bind (bindings &rest body) (rest form)
+ (let ((body* (prepare-progn body context))
+ (bindings* (mapcar (lambda (form)
+ (if (listp form)
+ (cons (first form)
+ (prepare-lambda (rest form) context))
+ (cons form (prepare-nil))))
+ bindings)))
+ (lambda (env)
+ (let ((new-env (make-environment env)))
+ (loop for (var . val) in bindings*
+ do (push `(,var . ,(funcall val new-env))
+ (environment-functions new-env)))
+ (funcall body* new-env))))))
+ ((let)
+ ;; FIXME: SPECIAL declarations!
+ (destructuring-bind (bindings &rest body) (rest form)
+ (let ((body* (prepare-progn body context))
+ (bindings* (mapcar (lambda (form)
+ (if (listp form)
+ (cons (first form)
+ (prepare-form (second form) context))
+ (cons form (prepare-nil))))
+ bindings)))
+ (lambda (env)
+ (let ((new-env (make-environment env)))
+ (loop for (var . val) in bindings*
+ do (push `(,var . ,(funcall val env))
+ (environment-variables new-env)))
+ (funcall body* new-env))))))
+ ((let*)
+ ;; FIXME: SPECIAL declarations!
+ (destructuring-bind (bindings &rest body) (rest form)
+ (labels ((prepare-let* (bindings context)
+ (if (endp bindings)
+ (prepare-progn body context)
+ (destructuring-bind (binding . rest-bindings) bindings
+ (let* ((var (if (listp binding) (first binding) binding))
+ (val (if (listp binding) (prepare-form (second binding) context) (prepare-nil)))
+ (new-context context)
+ (more (prepare-let* rest-bindings new-context)))
+ (lambda (env)
+ (let ((new-env (make-environment env)))
+ (push `(,var . ,val) (environment-variables new-env))
+ (funcall more new-env))))))))
+ (prepare-let* bindings context))))
+ ((locally))
+ ((multiple-value-call)
+ (destructuring-bind (f &rest argforms) (rest form)
+ (let ((f* (prepare-form f context))
+ (argforms* (mapcar (lambda (x) (prepare-form x context)) argforms)))
+ (lambda (env)
+ (apply f* (mapcan (lambda (arg) (multiple-value-list (funcall arg env))) argforms*))))))
+ ((multiple-value-prog1)
+ (destructuring-bind (values-form &body body) (rest form)
+ (let ((values-form* (prepare-form values-form context))
+ (body* (prepare-progn body context)))
+ (lambda (env)
+ (multiple-value-prog1
+ (funcall values-form* env)
+ (funcall body*))))))
+ ((multiple-value-setq)
+ (destructuring-bind (vars values-form) (rest form)
+ (let ((values-form* (prepare-form values-form context)))
+ (lambda (env)
+ (let* ((values (multiple-value-list (funcall values-form* env)))
+ (primary-value (first values))
+ (env-vars (environment-variables env)))
+ (dolist (var vars)
+ (setf (cdr (assoc var env-vars)) (pop values)))
+ primary-value)))))
+ ((multiple-value-bind)
+ ;; FIXME: SPECIAL declarations!
+ (destructuring-bind (vars value-form &body body) (rest form)
+ (let ((value-form* (prepare-form value-form context))
+ (body* (prepare-progn body context)))
+ (lambda (env)
+ (let* ((new-env (make-environment env))
+ (values (multiple-value-list (funcall value-form* env))))
+ (dolist (var vars)
+ (push `(,var . ,(pop values)) (environment-variables new-env)))
+ (funcall body* new-env))))))
+ ((progn)
+ (prepare-progn (rest form) context))
+ ((progv)
+ (destructuring-bind (vals vars &body body) (rest form)
+ (let ((vals* (prepare-form vals context))
+ (vars* (prepare-form vars context))
+ (body* (prepare-progn body context)))
+ (lambda (env)
+ (progv (funcall vals* env) (funcall vars* env)
+ (funcall body* env))))))
+ ((quote)
+ (let ((quoted-object (cadr form)))
+ (lambda (env)
+ (declare (ignore env))
+ quoted-object)))
+ ((return-from)
+ (destructuring-bind (name &optional value) (rest form)
+ (let ((value* (prepare-form value context))
+ (tag (context-block-tag context name)))
+ (lambda (env)
+ (throw tag (funcall value* env))))))
+ ((the)
+ (prepare-form (third form) context))
+ ((throw)
+ (destructuring-bind (tag result) (rest form)
+ (let ((tag* (prepare-form tag context))
+ (result* (prepare-form result context)))
+ (lambda (env)
+ (throw (funcall tag* env) (funcall result* env))))))
+ ((unwind-protect)
+ (destructuring-bind (protected &body body) (rest form)
+ (let ((protected* (prepare-form protected context))
+ (body* (prepare-progn body context)))
+ (lambda (env)
+ (unwind-protect (funcall protected* env)
+ (funcall body* env))))))
+ ((sb-ext:truly-the)
+ (prepare-form (third form) context))
+ ((sb-int:named-lambda)
+ (prepare-lambda (rest form) context))
+ ((symbol-macrolet)
+ (destructuring-bind (bindings &rest body) (rest form)
+ (let ((bindings (mapcar (lambda (form)
+ (cons (first form) (second form)))
+ bindings)))
+ (prepare-progn body (context-add-symbol-macros context bindings)))))
+ ((macrolet)
+ ;; FIXME: This doesn't actually work because we disregard
+ ;; the lambda list when calling the macro.
+ (destructuring-bind (bindings &rest body) (rest form)
+ (let ((bindings (mapcar (lambda (form)
+ (cons (first form)
+ (funcall
+ (prepare-lambda (rest form) context)
+ (make-null-environment))))
+ bindings)))
+ (prepare-progn body (context-add-macros context bindings)))))
+ ((go)
+ (let* ((go-tag (second form))
+ (catch-tag (context-find-go-tag context go-tag)))
+ (lambda (env)
+ (declare (ignore env))
+ (throw catch-tag go-tag))))
+ ((tagbody)
+ ;; 1. set up catch handler
+ ;; 2. save go-tag -> tagbody-catch-tag mapping
+ (let* ((jump (gensym "JUMP"))
+ (tags-and-bodies (parse-tagbody-tags-and-bodies (rest form)))
+ (new-context (context-add-go-tags context (mapcar #'car tags-and-bodies) jump))
+ (tags-and-bodies* (mapcar (lambda (x)
+ (destructuring-bind (tag . body) x
+ (cons tag (prepare-progn body new-context))))
+ tags-and-bodies)))
+ (lambda (env)
+ (block tagbody-loop
+ (let ((code tags-and-bodies*))
+ (loop
+ (setq code
+ (member (catch jump
+ (dolist (tag-and-body* code)
+ (funcall (cdr tag-and-body*) env))
+ (return-from tagbody-loop))
+ tags-and-bodies*
+ :key #'car))
+ (unless code
+ (return-from tagbody-loop)))))
+ nil)))
+ (otherwise
+ ;; FIXME: Handle SETF expanders?
+ (destructuring-bind (f . args) form
+ (let ((local-macro? (assoc f (context-macros context)))
+ (global-macro? (macro-function f)))
+ (cond
+ (local-macro?
+ (let ((macro-function (cdr local-macro?)))
+ (prepare-form (funcall macro-function form (context->native-environment context)) context)))
+ (global-macro?
+ (prepare-form (funcall global-macro? form (context->native-environment context)) context))
+ ((and (listp f)
+ (listp (first f))
+ (eq 'lambda (first (first f))))
+ (let ((lambda-fn (prepare-lambda (rest (first f)) context)))
+ (prepare-function-call lambda-fn args context)))
+ (t
+ (prepare-function-call (prepare-function-ref f context) args context)))))))))))
+ t))
+
+
+#+(or)
+(funcall (prepare-form '(funcall
+ (funcall
+ (lambda (x)
+ (lambda (y z)
+ (setq x (+ x (* y z)))
+ x))
+ 3)
+ 5 7)
+ (make-null-context))
+ (make-null-environment))