diff options
| -rw-r--r-- | sb-eval2.lisp | 74 |
1 files changed, 44 insertions, 30 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp index 1e93f2e..5d37de3 100644 --- a/sb-eval2.lisp +++ b/sb-eval2.lisp @@ -28,17 +28,19 @@ go-tags symbol-macros macros - lexicals) + lexicals + functions) (defun make-null-context () (%make-context :block-tags nil)) (defun make-context (parent-context) - (with-slots (block-tags go-tags symbol-macros macros lexicals) + (with-slots (block-tags go-tags symbol-macros macros lexicals functions) parent-context (%make-context :block-tags block-tags :go-tags go-tags :symbol-macros symbol-macros :macros macros - :lexicals lexicals))) + :lexicals lexicals + :functions functions))) (defun context-add-block-tag (context block tag) (let ((new-context (make-context context))) (with-slots (block-tags) @@ -91,6 +93,12 @@ new-context)) (defun context-add-lexical (context var) (context-add-lexicals context (list var))) +(defun context-add-functions (context fs) + (let ((new-context (make-context context))) + (with-slots (functions) + new-context + (setq functions (append fs functions))) + new-context)) (deftype eval-closure () `(function (environment) *)) @@ -103,24 +111,26 @@ (declare (ignore env)) (symbol-value var)))) -(declaim (ftype (function ((or symbol list) context) eval-closure) prepare-function-ref)) -(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) - (fdefinition f))))) +(declaim (ftype (function (context (or symbol list)) *) local-function-p)) +(defun local-function-p (context f) + (member f (context-functions context))) (declaim (ftype (function () eval-closure) prepare-nil)) (defun prepare-nil () (lambda (env) (declare (ignore env)))) -(declaim (ftype (function (eval-closure list context) eval-closure) prepare-function-call)) -(defun prepare-function-call (f args context) +(declaim (ftype (function ((or symbol list) list context) eval-closure) prepare-local-call)) +(defun prepare-local-call (f args context) (let ((args* (mapcar (lambda (form) (prepare-form form context)) args))) (lambda (env) - (apply (funcall f env) + (apply (the function (cdr (assoc f (environment-functions env) :test #'equal))) + (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))) + +(declaim (ftype (function (eval-closure list context) eval-closure) prepare-global-call)) +(defun prepare-direct-call (f args context) + (let ((args* (mapcar (lambda (form) (prepare-form form context)) args))) + (lambda (env) + (apply (the (or symbol function) (funcall (the eval-closure f) env)) (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))) (declaim (ftype (function (list context) eval-closure) prepare-progn)) @@ -237,13 +247,14 @@ (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))) + (let* ((bindings* (mapcar (lambda (form) + (if (listp form) + (cons (first form) + (prepare-lambda (rest form) context)) + (cons form (prepare-nil)))) + bindings)) + (new-context (context-add-functions context (mapcar #'first bindings*))) + (body* (prepare-progn body new-context))) (lambda (env) (let ((new-env (make-environment env))) (loop for (var . val) in bindings* @@ -252,13 +263,14 @@ (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))) + (let* ((new-context (context-add-functions context (mapcar #'first bindings))) + (bindings* (mapcar (lambda (form) + (if (listp form) + (cons (first form) + (prepare-lambda (rest form) new-context)) + (cons form (prepare-nil)))) + bindings)) + (body* (prepare-progn body new-context))) (lambda (env) (let ((new-env (make-environment env))) (loop for (var . val) in bindings* @@ -447,9 +459,11 @@ (listp (first f)) (eq 'lambda (first (first f)))) (let ((lambda-fn (prepare-lambda (rest (first f)) context))) - (prepare-function-call lambda-fn args context))) + (prepare-direct-call lambda-fn args context))) (t - (prepare-function-call (prepare-function-ref f context) args context))))))))))) + (if (local-function-p context f) + (prepare-local-call f args context) + (prepare-direct-call (prepare-function-ref f context) args context)))))))))))) t)) |