Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30049/src/compiler

Modified Files:
	ir1-translators.lisp ir1util.lisp locall.lisp 
Log Message:
0.8.16.41:
        * Partial workaround for the bug 262: inline expansion of a
          local function is canceled by conversion of RETURN-FROM,
          referring a deleted CTRAN. (Fixes bug reported by Peter
          Denno on sbcl-devel.)


Index: ir1-translators.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1-translators.lisp,v
retrieving revision 1.63
retrieving revision 1.64
diff -u -d -r1.63 -r1.64
--- ir1-translators.lisp	8 Nov 2004 15:27:54 -0000	1.63
+++ ir1-translators.lisp	16 Nov 2004 18:47:47 -0000	1.64
@@ -109,11 +109,14 @@
   (ctran-starts-block next)
   (let* ((found (or (lexenv-find name blocks)
 		    (compiler-error "return for unknown block: ~S" name)))
+         (exit-ctran (second found))
 	 (value-ctran (make-ctran))
          (value-lvar (make-lvar))
 	 (entry (first found))
 	 (exit (make-exit :entry entry
 			  :value value-lvar)))
+    (when (ctran-deleted-p exit-ctran)
+      (throw 'locall-already-let-converted exit-ctran))
     (push exit (entry-exits entry))
     (setf (lvar-dest value-lvar) exit)
     (ir1-convert start value-ctran value-lvar value)
@@ -121,7 +124,7 @@
     (let ((home-lambda (ctran-home-lambda-or-null start)))
       (when home-lambda
 	(push entry (lambda-calls-or-closes home-lambda))))
-    (use-continuation exit (second found) (third found))))
+    (use-continuation exit exit-ctran (third found))))
 
 ;;; Return a list of the segments of a TAGBODY. Each segment looks
 ;;; like (<tag> <form>* (go <next tag>)). That is, we break up the

Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.99
retrieving revision 1.100
diff -u -d -r1.99 -r1.100
--- ir1util.lisp	6 Nov 2004 07:11:25 -0000	1.99
+++ ir1util.lisp	16 Nov 2004 18:47:47 -0000	1.100
@@ -1330,15 +1330,21 @@
 	       (setf (node-prev node) nil)
 	       t)))))))
 
+;;; Return true if CTRAN has been deleted, false if it is still a valid
+;;; part of IR1.
+(defun ctran-deleted-p (ctran)
+  (declare (type ctran ctran))
+  (let ((block (ctran-block ctran)))
+    (or (not (block-component block))
+        (block-delete-p block))))
+
 ;;; Return true if NODE has been deleted, false if it is still a valid
 ;;; part of IR1.
 (defun node-deleted (node)
   (declare (type node node))
   (let ((prev (node-prev node)))
-    (not (and prev
-	      (let ((block (ctran-block prev)))
-		(and (block-component block)
-		     (not (block-delete-p block))))))))
+    (or (not prev)
+        (ctran-deleted-p prev))))
 
 ;;; Delete all the blocks and functions in COMPONENT. We scan first
 ;;; marking the blocks as DELETE-P to prevent weird stuff from being

Index: locall.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/locall.lisp,v
retrieving revision 1.68
retrieving revision 1.69
diff -u -d -r1.68 -r1.69
--- locall.lisp	6 Nov 2004 07:11:26 -0000	1.68
+++ locall.lisp	16 Nov 2004 18:47:48 -0000	1.69
@@ -378,7 +378,7 @@
 	   (inline-expansion-ok call))
       (let* ((end (component-last-block (node-component call)))
              (pred (block-prev end)))
-        (multiple-value-bind (losing-local-functional converted-lambda)
+        (multiple-value-bind (losing-local-object converted-lambda)
             (catch 'locall-already-let-converted
               (with-ir1-environment-from-node call
                 (let ((*lexenv* (functional-lexenv original-functional)))
@@ -389,12 +389,18 @@
                                         "local inline "
                                         (leaf-debug-name
                                          original-functional)))))))
-          (cond (losing-local-functional
-                 (let ((*compiler-error-context* call))
-                   (compiler-notify "couldn't inline expand because expansion ~
-                                     calls this LET-converted local function:~
-                                     ~%  ~S"
-                                    (leaf-debug-name losing-local-functional)))
+          (cond (losing-local-object
+                 (if (functional-p losing-local-object)
+                     (let ((*compiler-error-context* call))
+                       (compiler-notify "couldn't inline expand because expansion ~
+                                         calls this LET-converted local function:~
+                                         ~%  ~S"
+                                        (leaf-debug-name losing-local-object)))
+                     (let ((*compiler-error-context* call))
+                       (compiler-notify "implementation limitation: couldn't inline ~
+                                         expand because expansion refers to ~
+                                         the optimized away object ~S."
+                                        losing-local-object)))
                  (loop for block = (block-next pred) then (block-next block)
                        until (eq block end)
                        do (setf (block-delete-p block) t))

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30049/tests

Modified Files:
	compiler.impure-cload.lisp 
Log Message:
0.8.16.41:
        * Partial workaround for the bug 262: inline expansion of a
          local function is canceled by conversion of RETURN-FROM,
          referring a deleted CTRAN. (Fixes bug reported by Peter
          Denno on sbcl-devel.)


Index: compiler.impure-cload.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.impure-cload.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- compiler.impure-cload.lisp	29 Jun 2004 08:51:02 -0000	1.20
+++ compiler.impure-cload.lisp	16 Nov 2004 18:47:48 -0000	1.21
@@ -382,5 +382,14 @@
    (defvar caar))
 (defun srctran-lisp1-2 (caar) (funcall (sb-ext:truly-the function caar) 1))
 (assert (eql (funcall (eval #'srctran-lisp1-2) #'identity) 1))
+
+;;; partial bug 262: reference of deleted CTRAN (in RETURN-FROM)
+;;; during inline expansion. Bug report by Peter Denno, simplified
+;;; test case by David Wragg.
+(defun bug262-return-from (x &aux (y nil))
+  (labels ((foo-a (z) (return-from bug262-return-from z))
+           (foo-b (z) (foo-a z)))
+    (declare (inline foo-a))
+    (foo-a x)))
 
 (sb-ext:quit :unix-status 104)

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv30049

Modified Files:
	BUGS NEWS version.lisp-expr 
Log Message:
0.8.16.41:
        * Partial workaround for the bug 262: inline expansion of a
          local function is canceled by conversion of RETURN-FROM,
          referring a deleted CTRAN. (Fixes bug reported by Peter
          Denno on sbcl-devel.)


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.426
retrieving revision 1.427
diff -u -d -r1.426 -r1.427
--- BUGS	8 Nov 2004 15:27:52 -0000	1.426
+++ BUGS	16 Nov 2004 18:47:46 -0000	1.427
@@ -861,26 +861,12 @@
   b. The same for CSUBTYPEP.
 
 262: "yet another bug in inline expansion of local functions"
-  Compiler fails on
-
-    (defun foo (x y)
-      (declare (integer x y))
-      (+ (block nil
-            (flet ((xyz (u)
-                     (declare (integer u))
-                     (if (> (1+ (the unsigned-byte u)) 0)
-                         (+ 1 u)
-                         (return (+ 38 (cos (/ u 78)))))))
-              (declare (inline xyz))
-              (return-from foo
-                (* (funcall (eval #'xyz) x)
-                   (if (> x 30)
-                       (funcall (if (> x 5) #'xyz #'identity)
-                                (+ x 13))
-                       38)))))
-         (sin (* x y))))
-
-  Urgh... It's time to write IR1-copier.
+  During inline expansion of a local function Python can try to
+  reference optimized away objects (functions, variables, CTRANs from
+  tags and blocks), which later may lead to problems. Some of the
+  cases are worked around by forbidding expansion in such cases, but
+  the better way would be to reimplement inline expansion by copying
+  IR1 structures.
 
 266:
   David Lichteblau provided (sbcl-devel 2003-06-01) a patch to fix

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.662
retrieving revision 1.663
diff -u -d -r1.662 -r1.663
--- NEWS	16 Nov 2004 16:40:30 -0000	1.662
+++ NEWS	16 Nov 2004 18:47:46 -0000	1.663
@@ -48,6 +48,10 @@
     specialized array element types.
   * FORMAT compile-time argument count checking has been enhanced.
     (report from Bruno Haible for CMUCL)
+  * a partial workaround for the bug 262: the compiler does not try to
+    inline-expand a local function doing RETURN-FROM from a deleted
+    BLOCK. (thanks to Peter Denno for the bug report and to David
+    Wragg for the simple test case)
   * fixed some bugs revealed by Paul Dietz' test suite:
     ** RENAME-PACKAGE allows all package designators as new package
        names.

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.1903
retrieving revision 1.1904
diff -u -d -r1.1903 -r1.1904
--- version.lisp-expr	16 Nov 2004 16:40:30 -0000	1.1903
+++ version.lisp-expr	16 Nov 2004 18:47:46 -0000	1.1904
@@ -17,4 +17,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".)
-"0.8.16.40"
+"0.8.16.41"

Update of /cvsroot/sbcl/sbcl/tests
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv436/tests

Modified Files:
	print.impure.lisp 
Log Message:
0.8.16.40:
	Fix for "~VR" nil 5 problem (from PFD ansi-tests)


Index: print.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/print.impure.lisp,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- print.impure.lisp	15 Nov 2004 19:25:48 -0000	1.26
+++ print.impure.lisp	16 Nov 2004 16:40:32 -0000	1.27
@@ -309,5 +309,9 @@
                             (funcall (eval `(formatter ,format)) s arg))
                           result)))
 
+;;; NIL first parameter for ~R is equivalent to no parameter.
+(assert (string= (format nil "~VR" nil 5) "five"))
+(assert (string= (format nil (formatter "~VR") nil 6) "six"))
+
 ;;; success
 (quit :unix-status 104)

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv436/src/code

Modified Files:
	late-format.lisp target-format.lisp 
Log Message:
0.8.16.40:
	Fix for "~VR" nil 5 problem (from PFD ansi-tests)


Index: late-format.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/late-format.lisp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- late-format.lisp	15 Nov 2004 19:25:48 -0000	1.29
+++ late-format.lisp	16 Nov 2004 16:40:32 -0000	1.30
@@ -493,21 +493,23 @@
   (expand-format-integer 16 colonp atsignp params))
 
 (def-format-directive #\R (colonp atsignp params)
-  (if params
-      (expand-bind-defaults
-	  ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
-	   (commainterval 3))
-	  params
-	`(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp
-			       ,base ,mincol
-			       ,padchar ,commachar ,commainterval))
-      (if atsignp
-	  (if colonp
-	      `(format-print-old-roman stream ,(expand-next-arg))
-	      `(format-print-roman stream ,(expand-next-arg)))
-	  (if colonp
-	      `(format-print-ordinal stream ,(expand-next-arg))
-	      `(format-print-cardinal stream ,(expand-next-arg))))))
+  (expand-bind-defaults
+      ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
+       (commainterval 3))
+      params
+    (let ((n-arg (gensym))) 
+      `(let ((,n-arg ,(expand-next-arg)))
+         (if ,base
+             (format-print-integer stream ,n-arg ,colonp ,atsignp
+      	   	                   ,base ,mincol
+      		                   ,padchar ,commachar ,commainterval)
+             ,(if atsignp
+                  (if colonp
+                      `(format-print-old-roman stream ,n-arg)
+                      `(format-print-roman stream ,n-arg))
+                  (if colonp
+                      `(format-print-ordinal stream ,n-arg)
+	              `(format-print-cardinal stream ,n-arg))))))))
 
 ;;;; format directive for pluralization
 

Index: target-format.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-format.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- target-format.lisp	15 Nov 2004 19:25:48 -0000	1.25
+++ target-format.lisp	16 Nov 2004 16:40:32 -0000	1.26
@@ -302,20 +302,21 @@
   (interpret-format-integer 16))
 
 (def-format-interpreter #\R (colonp atsignp params)
-  (if params
-      (interpret-bind-defaults
-	  ((base 10) (mincol 0) (padchar #\space) (commachar #\,)
-	   (commainterval 3))
-	  params
-	(format-print-integer stream (next-arg) colonp atsignp base mincol
-			      padchar commachar commainterval))
-      (if atsignp
-	  (if colonp
-	      (format-print-old-roman stream (next-arg))
-	      (format-print-roman stream (next-arg)))
-	  (if colonp
-	      (format-print-ordinal stream (next-arg))
-	      (format-print-cardinal stream (next-arg))))))
+  (interpret-bind-defaults
+      ((base nil) (mincol 0) (padchar #\space) (commachar #\,)
+       (commainterval 3))
+      params
+    (let ((arg (next-arg)))
+      (if base
+          (format-print-integer stream arg colonp atsignp base mincol
+                                padchar commachar commainterval)
+          (if atsignp
+              (if colonp
+                  (format-print-old-roman stream arg)
+                  (format-print-roman stream arg))
+              (if colonp
+                  (format-print-ordinal stream arg)
+                  (format-print-cardinal stream arg)))))))
 
 (defparameter *cardinal-ones*
   #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))

Update of /cvsroot/sbcl/sbcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv436

Modified Files:
	NEWS version.lisp-expr 
Log Message:
0.8.16.40:
	Fix for "~VR" nil 5 problem (from PFD ansi-tests)


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.661
retrieving revision 1.662
diff -u -d -r1.661 -r1.662
--- NEWS	15 Nov 2004 19:25:47 -0000	1.661
+++ NEWS	16 Nov 2004 16:40:30 -0000	1.662
@@ -65,6 +65,7 @@
        references to global functions.
     ** NIL parameter to the FORMAT directive ~^ means `unsupplied
        parameter'.
+    ** FORMAT ~R treats a nil value for its first parameter correctly.
 
 changes in sbcl-0.8.16 relative to sbcl-0.8.15:
   * enhancement: saving cores with foreign code loaded is now

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.1902
retrieving revision 1.1903
diff -u -d -r1.1902 -r1.1903
--- version.lisp-expr	15 Nov 2004 19:25:48 -0000	1.1902
+++ version.lisp-expr	16 Nov 2004 16:40:30 -0000	1.1903
@@ -17,4 +17,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".)
-"0.8.16.39"
+"0.8.16.40"