diff options
| author | Matthias Andreas Benkard <code@mail.matthias.benkard.de> | 2013-07-16 07:52:07 +0200 |
|---|---|---|
| committer | Matthias Andreas Benkard <code@mail.matthias.benkard.de> | 2013-07-16 07:56:28 +0200 |
| commit | eb72deb959925a92509fdcaff5389afe41135b0b (patch) | |
| tree | 3584b5a2473e7ec6835290470f71f1fc7310f833 | |
| parent | bfd7693d1f379d4d112b378199452d86dcc62b38 (diff) | |
PREPARE-GLOBAL-CALL: Deal with redefinition by using FDEFINITION-OBJECTs.
Conflicts:
sb-eval2.lisp
| -rw-r--r-- | sb-eval2.lisp | 33 |
1 files changed, 12 insertions, 21 deletions
diff --git a/sb-eval2.lisp b/sb-eval2.lisp index 771922c..1af91ff 100644 --- a/sb-eval2.lisp +++ b/sb-eval2.lisp @@ -195,7 +195,8 @@ (declaim (ftype (function ((or symbol list) list context) eval-closure) prepare-global-call)) (defun prepare-global-call (f args context) - (let ((args* (mapcar (lambda (form) (prepare-form form context)) args))) + (let ((args* (mapcar (lambda (form) (prepare-form form context)) args)) + (f* (sb-c::fdefinition-object f t))) (if (< (length args) 20) (specialize m% (length args) (loop for i from 0 below 20 collect i) (let ((argvars (loop for i from 0 below m% @@ -203,26 +204,16 @@ `(let ,(loop for var in argvars for i from 0 below m% collect `(,var (nth ,i args*))) - (if (fboundp f) - (let ((f* (fdefinition f))) - (lambda (env) - (declare (ignorable env)) - (funcall f* - ,@(loop for var in argvars - collect `(funcall (the eval-closure ,var) env))))) - (lambda (env) - (declare (ignorable env)) - (funcall (fdefinition f) - ,@(loop for var in argvars - collect `(funcall (the eval-closure ,var) env)))))))) - (if (fboundp f) - (let ((f* (fdefinition f))) - (lambda (env) - (apply f* - (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*)))) - (lambda (env) - (apply (fdefinition f) - (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*))))))) + (lambda (env) + (declare (ignorable env)) + (funcall (or (sb-c::fdefn-fun f*) + (error 'undefined-function :name f)) + ,@(loop for var in argvars + collect `(funcall (the eval-closure ,var) env))))))) + (lambda (env) + (apply (or (sb-c::fdefn-fun f*) + (error 'undefined-function :name f)) + (mapcar (lambda (x) (funcall (the eval-closure x) env)) args*)))))) (declaim (ftype (function (eval-closure list context) eval-closure) prepare-direct-call)) (defun prepare-direct-call (f args context) |