From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 8 Apr 2011 15:38:26 +0000 (+0000)
Subject: 1.0.47.18: less verbose source forms for functions from EVAL
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=3dfa5e8575abd1ba5d4f5dfa75213a63d290ed26;p=sbcl.git

1.0.47.18: less verbose source forms for functions from EVAL

  Fixes lp#747485.

  When generating debug information, exclude the outer lambda
  introduced by %SIMPLE-EVAL from the source form.
---

diff --git a/NEWS b/NEWS
index c524c5d..7ccf2ef 100644
--- a/NEWS
+++ b/NEWS
@@ -15,6 +15,7 @@ changes relative to sbcl-1.0.47:
     a compile-time error. (lp#720382)
   * bug fix: forms such as (FUNCALL (FUNCTION NAME OOPS) ...) were compiled
     without complaints.
+  * bug fix: less verbose source forms for functions from EVAL. (lp#747485)
 
 changes in sbcl-1.0.47 relative to sbcl-1.0.46:
   * bug fix: fix mach port rights leaks in mach exception handling code on
diff --git a/src/code/eval.lisp b/src/code/eval.lisp
index 8528a03..7f5c4f5 100644
--- a/src/code/eval.lisp
+++ b/src/code/eval.lisp
@@ -22,6 +22,32 @@
 
 (defvar *eval-source-context* nil)
 
+(defun make-eval-lambda (expr)
+  `(named-lambda
+       ;; This name is used to communicate the original context
+       ;; for the compiler, and identifies the lambda for use of
+       ;; EVAL-LAMBDA-SOURCE-LAMBDA below.
+       (eval ,(sb!c::source-form-context *eval-source-context*)) ()
+     (declare (muffle-conditions compiler-note))
+     ;; why PROGN?  So that attempts to eval free declarations
+     ;; signal errors rather than return NIL.  -- CSR, 2007-05-01
+     (progn ,expr)))
+
+(defun eval-lambda-p (form)
+  (when (and (consp form) (eq 'named-lambda (first form)))
+    (let ((name (second form)))
+      (when (and (consp name) (eq 'eval (first name)))
+        t))))
+
+(defun eval-lambda-source-lambda (eval-lambda)
+  (if (eval-lambda-p eval-lambda)
+      (destructuring-bind (named-lambda name lambda-list decl (progn expr))
+          eval-lambda
+        (declare (ignore named-lambda name lambda-list decl progn))
+        (when (and (consp expr) (member (car expr) '(lambda named-lambda)))
+          expr))
+      eval-lambda))
+
 ;;; general case of EVAL (except in that it can't handle toplevel
 ;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
 (defun %simple-eval (expr lexenv)
@@ -34,11 +60,7 @@
   ;;
   ;; As of 1.0.21.6 we muffle compiler notes lexically here, which seems
   ;; always safe. --NS
-  (let* (;; why PROGN?  So that attempts to eval free declarations
-         ;; signal errors rather than return NIL.  -- CSR, 2007-05-01
-         (lambda `(named-lambda (eval ,(sb!c::source-form-context *eval-source-context*)) ()
-                    (declare (muffle-conditions compiler-note))
-                    (progn ,expr)))
+  (let* ((lambda (make-eval-lambda expr))
          (fun (sb!c:compile-in-lexenv nil lambda lexenv)))
     (funcall fun)))
 
diff --git a/src/compiler/debug-dump.lisp b/src/compiler/debug-dump.lisp
index 93dc016..f2b5c31 100644
--- a/src/compiler/debug-dump.lisp
+++ b/src/compiler/debug-dump.lisp
@@ -266,8 +266,11 @@
                        (file-info-positions file-info))
 
      :form (let ((direct-file-info (source-info-file-info info)))
-             (if (eq :lisp (file-info-name direct-file-info))
-                 (elt (file-info-forms direct-file-info) 0)))
+             (when (eq :lisp (file-info-name direct-file-info))
+               (let ((form (elt (file-info-forms direct-file-info) 0)))
+                 ;; The form COMPILE saves may include gunk
+                 ;; from %SIMPLE-EVAL -- this gets rid of that.
+                 (sb!impl::eval-lambda-source-lambda form))))
      :function function)))
 
 ;;; Given an arbitrary sequence, coerce it to an unsigned vector if
diff --git a/version.lisp-expr b/version.lisp-expr
index b2b3147..a2ad1f8 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -20,4 +20,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.47.17"
+"1.0.47.18"