Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/src/code
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv32697/src/code

Modified Files:
	filesys.lisp 
Log Message:
1.0.23.70: Add a keyword to DIRECTORY to suppress symlink resolution.

* Contributed by TC-Rucho.


Index: filesys.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/filesys.lisp,v
retrieving revision 1.75
retrieving revision 1.76
diff -u -d -r1.75 -r1.76
--- filesys.lisp	24 Sep 2008 14:55:15 -0000	1.75
+++ filesys.lisp	26 Dec 2008 18:33:56 -0000	1.76
@@ -198,6 +198,10 @@
 
 (/show0 "filesys.lisp 498")
 
+;; TODO: the implementation !enumerate-matches is some hairy stuff
+;; that we mostly don't need.  Couldn't we use POSIX fts(3) to walk
+;; the file system and PATHNAME-MATCH-P to select matches, at least on
+;; Unices?
 (defmacro !enumerate-matches ((var pathname &optional result
                                    &key (verify-existence t)
                                    (follow-links t))
@@ -504,6 +508,14 @@
 ;;;   As realpath(3) is not atomic anyway, we only ever call it when
 ;;;   we think a file exists, so just be careful when rewriting this
 ;;;   routine.
+;;;
+;;; Given a pathname designator, some quality to query for, return one
+;;; of a pathname, a universal time, or a string (a file-author), or
+;;; NIL.  QUERY-FOR may be one of :TRUENAME, :EXISTENCE, :WRITE-DATE,
+;;; :AUTHOR.  If ERRORP is false, return NIL in case the file system
+;;; returns an error code; otherwise, signal an error.  Accepts
+;;; logical pathnames, too (but never returns LPNs).  For internal
+;;; use.
 (defun query-file-system (pathspec query-for &optional (errorp t))
   (let ((pathname (translate-logical-pathname
                    (merge-pathnames
@@ -526,6 +538,14 @@
           (declare (ignore ino nlink gid rdev size atime))
           (if existsp
               (case query-for
+                (:existence (nth-value
+                             0
+                             (parse-native-namestring
+                              filename
+                              (pathname-host pathname)
+                              (sane-default-pathname-defaults)
+                              :as-directory (eql (logand mode sb!unix:s-ifmt)
+                                                 sb!unix:s-ifdir))))
                 (:truename (nth-value
                             0
                             (parse-native-namestring
@@ -563,6 +583,11 @@
                              linkp)
                     (return-from query-file-system
                       (case query-for
+                        (:existence
+                         ;; We do this reparse so as to return a
+                         ;; normalized pathname.
+                         (parse-native-namestring
+                          filename (pathname-host pathname)))
                         (:truename
                          ;; So here's a trick: since lstat succeded,
                          ;; FILENAME exists, so its directory exists and
@@ -914,18 +939,19 @@
                                            (car one) (car two)) x))
                         (intersect-directory-helper (cdr one) (cdr two)))))))))
 
-(defun directory (pathname &key)
+(defun directory (pathname &key (resolve-symlinks t))
   #!+sb-doc
   "Return a list of PATHNAMEs, each the TRUENAME of a file that matched the
    given pathname. Note that the interaction between this ANSI-specified
    TRUENAMEing and the semantics of the Unix filesystem (symbolic links..)
    means this function can sometimes return files which don't have the same
-   directory as PATHNAME."
+   directory as PATHNAME.  If :RESOLVE-SYMLINKS is NIL, don't resolve
+   symbolic links in matching filenames."
   (let (;; We create one entry in this hash table for each truename,
         ;; as an asymptotically efficient way of removing duplicates
         ;; (which can arise when e.g. multiple symlinks map to the
         ;; same truename).
-        (truenames (make-hash-table :test #'equal))
+        (filenames (make-hash-table :test #'equal))
         ;; FIXME: Possibly this MERGE-PATHNAMES call should only
         ;; happen once we get a physical pathname.
         (merged-pathname (merge-pathnames pathname)))
@@ -940,10 +966,12 @@
                         ;; operation causes an error.  It's not clear
                         ;; what the right thing to do is, though.  --
                         ;; CSR, 2003-10-13
-                        (truename (probe-file match)))
-                   (when truename
-                     (setf (gethash (namestring truename) truenames)
-                           truename)))))
+                        (filename (if resolve-symlinks
+                                      (query-file-system match :truename nil)
+                                      (query-file-system match :existence nil))))
+                   (when filename
+                     (setf (gethash (namestring filename) filenames)
+                           filename)))))
              (do-directory (pathname)
                (if (logical-pathname-p pathname)
                    (let ((host (intern-logical-host (pathname-host pathname))))
@@ -960,9 +988,9 @@
             ;; into some canonical order seems good just on the
             ;; grounds that the implementation should have repeatable
             ;; behavior when possible.
-            (sort (loop for name being each hash-key in truenames
-                     using (hash-value truename)
-                     collect (cons name truename))
+            (sort (loop for name being each hash-key in filenames
+                     using (hash-value filename)
+                     collect (cons name filename))
                   #'string<
                   :key #'car))))
 

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv32697/src/compiler

Modified Files:
	fndb.lisp 
Log Message:
1.0.23.70: Add a keyword to DIRECTORY to suppress symlink resolution.

* Contributed by TC-Rucho.


Index: fndb.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/fndb.lisp,v
retrieving revision 1.150
retrieving revision 1.151
diff -u -d -r1.150 -r1.151
--- fndb.lisp	4 Dec 2008 16:50:15 -0000	1.150
+++ fndb.lisp	26 Dec 2008 18:33:57 -0000	1.151
@@ -1256,7 +1256,7 @@
    (:external-format keyword))
   t)
 
-(defknown directory (pathname-designator &key)
+(defknown directory (pathname-designator &key (resolve-symlinks t))
   list ())
 
 ;;;; from the "Conditions" chapter:

Update of /cvsroot/sbcl/sbcl
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv32697

Modified Files:
	version.lisp-expr 
Log Message:
1.0.23.70: Add a keyword to DIRECTORY to suppress symlink resolution.

* Contributed by TC-Rucho.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4234
retrieving revision 1.4235
diff -u -d -r1.4234 -r1.4235
--- version.lisp-expr	26 Dec 2008 15:43:25 -0000	1.4234
+++ version.lisp-expr	26 Dec 2008 18:33:57 -0000	1.4235
@@ -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".)
-"1.0.23.69"
+"1.0.23.70"

Update of /cvsroot/sbcl/sbcl/contrib/sb-bsd-sockets
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv19679/contrib/sb-bsd-sockets

Modified Files:
	sockets.lisp 
Log Message:
1.0.23.69: Add docstrings to SB-BSD-SOCKETS:SOCKET-MAKE-STREAM.

* Contributed by Robert Goldman.



Index: sockets.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-bsd-sockets/sockets.lisp,v
retrieving revision 1.25
retrieving revision 1.26
diff -u -d -r1.25 -r1.26
--- sockets.lisp	13 Mar 2008 11:35:21 -0000	1.25
+++ sockets.lisp	26 Dec 2008 15:43:25 -0000	1.26
@@ -347,22 +347,45 @@
                nil))))))
 
 
-(defgeneric socket-make-stream (socket &rest args)
+(defgeneric socket-make-stream (socket &key input output
+                                       element-type external-format
+                                       buffering
+                                       timeout)
   (:documentation "Find or create a STREAM that can be used for IO on
-SOCKET (which must be connected).  ARGS are passed onto
-SB-SYS:MAKE-FD-STREAM."))
+SOCKET \(which must be connected\).  Specify whether the stream is for
+INPUT, OUTPUT, or both \(it is an error to specify neither\).  ELEMENT-TYPE
+and EXTERNAL-FORMAT are as per OPEN.  TIMEOUT specifies a read timeout
+for the stream."))
 
-(defmethod socket-make-stream ((socket socket) &rest args)
+(defmethod socket-make-stream ((socket socket)
+                               &key input output
+                               (element-type 'character)
+                               (buffering :full)
+                               (external-format :default)
+                               timeout)
+  "Default method for SOCKET objects.  An ELEMENT-TYPE of :DEFAULT
+will construct a bivalent stream.  Acceptable values for BUFFERING
+are :FULL, :LINE and :NONE.  Streams will have no TIMEOUT
+by default.
+  The stream for SOCKET will be cached, and a second invocation of this
+method will return the same stream.  This may lead to oddities if this
+function is invoked with inconsistent arguments \(e.g., one might request
+an input stream and get an output stream in response\)."
   (let ((stream
          (and (slot-boundp socket 'stream) (slot-value socket 'stream))))
     (unless stream
-      (setf stream (apply #'sb-sys:make-fd-stream
-                          (socket-file-descriptor socket)
-                          :name "a socket"
-                          :dual-channel-p t
-                          args))
+      (setf stream (sb-sys:make-fd-stream
+                    (socket-file-descriptor socket)
+                    :name "a socket"
+                    :dual-channel-p t
+                    :input input
+                    :output output
+                    :element-type element-type
+                    :buffering buffering
+                    :external-format external-format
+                    :timeout timeout)))
       (setf (slot-value socket 'stream) stream)
-      (sb-ext:cancel-finalization socket))
+    (sb-ext:cancel-finalization socket)
     stream))
 
 

Update of /cvsroot/sbcl/sbcl
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv19679

Modified Files:
	version.lisp-expr 
Log Message:
1.0.23.69: Add docstrings to SB-BSD-SOCKETS:SOCKET-MAKE-STREAM.

* Contributed by Robert Goldman.



Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4233
retrieving revision 1.4234
diff -u -d -r1.4233 -r1.4234
--- version.lisp-expr	26 Dec 2008 14:19:06 -0000	1.4233
+++ version.lisp-expr	26 Dec 2008 15:43:25 -0000	1.4234
@@ -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".)
-"1.0.23.68"
+"1.0.23.69"

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv11497/src/compiler

Modified Files:
	constraint.lisp 
Log Message:
1.0.23.68: Cleanups in constraint propagation.

* Three changes here:

(1) Have the conset's min slot always be a fixnum.  The min and max
    slots should now conform to CL sequence bounding index idioms.

(2) Update the extrema in parallel, rather than in sequence, in the
    conset-union, -intersection, -difference.

(3) Remove some noise from conset-intersection that probably included
    an off-by-one error.

* Fixes a bug reported by Tobias C. Rittweiler on sbcl-devel.


Index: constraint.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/constraint.lisp,v
retrieving revision 1.36
retrieving revision 1.37
diff -u -d -r1.36 -r1.37
--- constraint.lisp	7 Nov 2008 15:01:36 -0000	1.36
+++ constraint.lisp	26 Dec 2008 14:19:07 -0000	1.37
@@ -149,10 +149,8 @@
             :type simple-bit-vector)
     ;; Bit-vectors win over lightweight hashes for copy, union,
     ;; intersection, difference, but lose for iteration if you iterate
-    ;; over the whole vector.  Tracking extrema helps a bit.  Note
-    ;; that the CONSET-MIN is NIL when the set is known to be empty.
-    ;; CONSET-MAX is a normal end bounding index.
-    (min nil :type (or fixnum null))
+    ;; over the whole vector.  Tracking extrema helps a bit.
+    (min 0 :type fixnum)
     (max 0 :type fixnum))
 
   (defmacro do-conset-elements ((constraint conset &optional result) &body body)
@@ -169,7 +167,7 @@
                                 (declare (ignore ,ignore))
                                 (aver (<= ,end ,constraint-universe-end)))))
         `(let* ((,vector (conset-vector ,conset))
-               (,start (or (conset-min ,conset) 0))
+               (,start (conset-min ,conset))
                (,end (min (conset-max ,conset) (length ,vector))))
           (,@with-array-data
             (do ((,index ,start (1+ ,index))) ((>= ,index ,end) ,result)
@@ -186,7 +184,7 @@
          ,@body)))
 
   (defun conset-empty (conset)
-    (or (null (conset-min conset))
+    (or (= (conset-min conset) (conset-max conset))
         ;; TODO: I bet FIND on bit-vectors can be optimized, if it
         ;; isn't.
         (not (find 1 (conset-vector conset)
@@ -233,8 +231,7 @@
       (let ((number (%constraint-number constraint)))
         (conset-grow conset (1+ number))
         (setf (sbit (conset-vector conset) number) 1)
-        (setf (conset-min conset) (min number (or (conset-min conset)
-                                                  most-positive-fixnum)))
+        (setf (conset-min conset) (min number (conset-min conset)))
         (when (>= number (conset-max conset))
           (setf (conset-max conset) (1+ number))))))
 
@@ -273,41 +270,26 @@
                 (declare (simple-bit-vector vector1 vector2))
                 (setf (conset-vector conset-1) (,bit-op vector1 vector2 t))
                 ;; Update the extrema.
-                (setf (conset-min conset-1)
-                      ,(ecase name
-                         ((conset-union)
-                          `(min (or (conset-min conset-1)
-                                    most-positive-fixnum)
-                                (or (conset-min conset-2)
-                                    most-positive-fixnum)))
-                         ((conset-intersection)
-                          `(let ((start (max (or (conset-min conset-1) 0)
-                                             (or (conset-min conset-2) 0)))
-                                 (end (min (conset-max conset-1)
-                                           (conset-max conset-1))))
+                ,(ecase name
+                   ((conset-union)
+                    `(setf (conset-min conset-1)
+                           (min (conset-min conset-1)
+                                (conset-min conset-2))
+                           (conset-max conset-1)
+                           (max (conset-max conset-1)
+                                (conset-max conset-2))))
+                   ((conset-intersection)
+                    `(let ((start (max (conset-min conset-1)
+                                       (conset-min conset-2)))
+                           (end (min (conset-max conset-1)
+                                     (conset-max conset-2))))
+                       (setf (conset-min conset-1)
                              (if (> start end)
-                                 nil
-                                 (position 1 (conset-vector conset-1)
-                                           :start start :end end))))
-                         ((conset-difference)
-                          `(position 1 (conset-vector conset-1)
-                                     :start (or (conset-min conset-1) 0)
-                                     :end (conset-max conset-1)
-                                     )))
-                      (conset-max conset-1)
-                      ,(ecase name
-                         ((conset-union)
-                          `(max (conset-max conset-1)
-                                (conset-max conset-2)))
-                         ((conset-intersection)
-                          `(let ((start (max (or (conset-min conset-1) 0)
-                                             (or (conset-min conset-2) 0)))
-                                 (end (let ((minimum-maximum
-                                             (min (conset-max conset-1)
-                                                  (conset-max conset-2))))
-                                        (if (plusp minimum-maximum)
-                                            (1- minimum-maximum)
-                                            0))))
+                                 0
+                                 (or (position 1 (conset-vector conset-1)
+                                               :start start :end end)
+                                     0))
+                             (conset-max conset-1)
                              (if (> start end)
                                  0
                                  (let ((position
@@ -316,12 +298,18 @@
                                          :start start :end end :from-end t)))
                                    (if position
                                        (1+ position)
-                                       0)))))
-                         ((conset-difference)
-                          `(let ((position
+                                       0))))))
+                   ((conset-difference)
+                    `(setf (conset-min conset-1)
+                           (or (position 1 (conset-vector conset-1)
+                                         :start (conset-min conset-1)
+                                         :end (conset-max conset-1))
+                               0)
+                           (conset-max conset-1)
+                           (let ((position
                                   (position
                                    1 (conset-vector conset-1)
-                                   :start (or (conset-min conset-1) 0)
+                                   :start (conset-min conset-1)
                                    :end (conset-max conset-1)
                                    :from-end t)))
                              (if position
@@ -878,7 +866,7 @@
         (frob let)))))
 
 ;;; Return the constraints that flow from PRED to SUCC. This is
-;;; BLOCK-OUT unless PRED ends with and IF and test constraints were
+;;; BLOCK-OUT unless PRED ends with an IF and test constraints were
 ;;; added.
 (defun block-out-for-successor (pred succ)
   (declare (type cblock pred succ))

Update of /cvsroot/sbcl/sbcl
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv11497

Modified Files:
	version.lisp-expr 
Log Message:
1.0.23.68: Cleanups in constraint propagation.

* Three changes here:

(1) Have the conset's min slot always be a fixnum.  The min and max
    slots should now conform to CL sequence bounding index idioms.

(2) Update the extrema in parallel, rather than in sequence, in the
    conset-union, -intersection, -difference.

(3) Remove some noise from conset-intersection that probably included
    an off-by-one error.

* Fixes a bug reported by Tobias C. Rittweiler on sbcl-devel.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4232
retrieving revision 1.4233
diff -u -d -r1.4232 -r1.4233
--- version.lisp-expr	25 Dec 2008 20:36:19 -0000	1.4232
+++ version.lisp-expr	26 Dec 2008 14:19:06 -0000	1.4233
@@ -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".)
-"1.0.23.67"
+"1.0.23.68"

Update of /cvsroot/sbcl/sbcl/src/compiler/mips
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv6214/src/compiler/mips

Modified Files:
	alloc.lisp 
Log Message:
1.0.23.67: Fix MIPS FIXED-ALLOC VOP.

  * No observable change in behaviour. Apparently nothing ever allocates
    a non-pointer referenced object via this code path.


Index: alloc.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/mips/alloc.lisp,v
retrieving revision 1.20
retrieving revision 1.21
diff -u -d -r1.20 -r1.21
--- alloc.lisp	17 Dec 2008 14:42:15 -0000	1.20
+++ alloc.lisp	25 Dec 2008 20:36:19 -0000	1.21
@@ -239,7 +239,12 @@
              (inst or result csp-tn lowtag)
              (inst addu csp-tn (pad-data-block words)))
             (t
-             (inst or result alloc-tn lowtag)))
+             ;; The pseudo-atomic bit in alloc-tn is set.  If the
+             ;; lowtag also has a 1 bit in the same position, we're all
+             ;; set.  Otherwise, we need to subtract the pseudo-atomic
+             ;; bit.
+             (inst or result alloc-tn (if (logbitp 0 lowtag) lowtag
+                                                             (1- lowtag)))))
       (when type
         (inst li temp (logior (ash (1- words) n-widetag-bits) type))
         (storew temp result 0 lowtag)))))

Update of /cvsroot/sbcl/sbcl
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv6214

Modified Files:
	version.lisp-expr 
Log Message:
1.0.23.67: Fix MIPS FIXED-ALLOC VOP.

  * No observable change in behaviour. Apparently nothing ever allocates
    a non-pointer referenced object via this code path.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4231
retrieving revision 1.4232
diff -u -d -r1.4231 -r1.4232
--- version.lisp-expr	23 Dec 2008 14:10:23 -0000	1.4231
+++ version.lisp-expr	25 Dec 2008 20:36:19 -0000	1.4232
@@ -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".)
-"1.0.23.66"
+"1.0.23.67"

Update of /cvsroot/sbcl/sbcl/src/compiler/mips
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv25684/src/compiler/mips

Modified Files:
	array.lisp 
Log Message:
1.0.23.66: Calculate array sizes in a more reliable way.

  * The old implementation depended on the array header size being
    an even number of words.

  * Also, another micro-optimization for MIPS.


Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/mips/array.lisp,v
retrieving revision 1.15
retrieving revision 1.16
diff -u -d -r1.15 -r1.16
--- array.lisp	17 Dec 2008 14:43:26 -0000	1.15
+++ array.lisp	23 Dec 2008 14:10:23 -0000	1.16
@@ -18,18 +18,19 @@
   (:args (type :scs (any-reg))
          (rank :scs (any-reg)))
   (:arg-types positive-fixnum positive-fixnum)
-  (:temporary (:scs (any-reg)) bytes)
-  (:temporary (:scs (non-descriptor-reg)) header)
+  (:temporary (:scs (non-descriptor-reg)) bytes header)
   (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
   (:results (result :scs (descriptor-reg)))
   (:generator 13
-    (inst addu bytes rank (+ (* array-dimensions-offset n-word-bytes)
+    (inst addu bytes rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
                              lowtag-mask))
-    (inst li header (lognot lowtag-mask))
-    (inst and bytes header)
+    (inst srl bytes n-lowtag-bits)
+    (inst sll bytes n-lowtag-bits)
     (inst addu header rank (fixnumize (1- array-dimensions-offset)))
     (inst sll header n-widetag-bits)
-    (inst or header header type)
+    (inst or header type)
+    ;; Remove the extraneous fixnum tag bits because TYPE and RANK
+    ;; were fixnums
     (inst srl header n-fixnum-tag-bits)
     (pseudo-atomic (pa-flag)
       (inst or result alloc-tn other-pointer-lowtag)

Update of /cvsroot/sbcl/sbcl
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv25684

Modified Files:
	version.lisp-expr 
Log Message:
1.0.23.66: Calculate array sizes in a more reliable way.

  * The old implementation depended on the array header size being
    an even number of words.

  * Also, another micro-optimization for MIPS.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4230
retrieving revision 1.4231
diff -u -d -r1.4230 -r1.4231
--- version.lisp-expr	23 Dec 2008 00:52:13 -0000	1.4230
+++ version.lisp-expr	23 Dec 2008 14:10:23 -0000	1.4231
@@ -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".)
-"1.0.23.65"
+"1.0.23.66"

Update of /cvsroot/sbcl/sbcl/src/compiler/alpha
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv25684/src/compiler/alpha

Modified Files:
	array.lisp 
Log Message:
1.0.23.66: Calculate array sizes in a more reliable way.

  * The old implementation depended on the array header size being
    an even number of words.

  * Also, another micro-optimization for MIPS.


Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/alpha/array.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- array.lisp	4 Jun 2006 14:25:07 -0000	1.22
+++ array.lisp	23 Dec 2008 14:10:23 -0000	1.23
@@ -22,7 +22,7 @@
   (:temporary (:scs (non-descriptor-reg)) header)
   (:results (result :scs (descriptor-reg)))
   (:generator 13
-    (inst addq rank (+ (* array-dimensions-offset n-word-bytes)
+    (inst addq rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
                        lowtag-mask)
           bytes)
     (inst li (lognot lowtag-mask) header)

Update of /cvsroot/sbcl/sbcl/src/compiler/sparc
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv25684/src/compiler/sparc

Modified Files:
	array.lisp 
Log Message:
1.0.23.66: Calculate array sizes in a more reliable way.

  * The old implementation depended on the array header size being
    an even number of words.

  * Also, another micro-optimization for MIPS.


Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/sparc/array.lisp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- array.lisp	4 Jun 2006 14:25:07 -0000	1.12
+++ array.lisp	23 Dec 2008 14:10:23 -0000	1.13
@@ -24,7 +24,8 @@
   (:generator 0
     (pseudo-atomic ()
       (inst or header alloc-tn other-pointer-lowtag)
-      (inst add ndescr rank (* (1+ array-dimensions-offset) n-word-bytes))
+      (inst add ndescr rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
+                               lowtag-mask))
       (inst andn ndescr 4)
       (inst add alloc-tn ndescr)
       (inst add ndescr rank (fixnumize (1- array-dimensions-offset)))
@@ -641,4 +642,4 @@
   (:arg-types * tagged-num unsigned-num)
   (:results (result :scs (unsigned-reg)))
   (:result-types unsigned-num)
-  (:variant vector-data-offset other-pointer-lowtag))
\ No newline at end of file
+  (:variant vector-data-offset other-pointer-lowtag))

Update of /cvsroot/sbcl/sbcl/src/compiler/ppc
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv25684/src/compiler/ppc

Modified Files:
	array.lisp 
Log Message:
1.0.23.66: Calculate array sizes in a more reliable way.

  * The old implementation depended on the array header size being
    an even number of words.

  * Also, another micro-optimization for MIPS.


Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ppc/array.lisp,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- array.lisp	4 Jun 2006 14:25:07 -0000	1.14
+++ array.lisp	23 Dec 2008 14:10:23 -0000	1.15
@@ -28,7 +28,8 @@
   (:results (result :scs (descriptor-reg)))
   (:generator 0
     (pseudo-atomic (pa-flag)
-      (inst addi ndescr rank (* (1+ array-dimensions-offset) n-word-bytes))
+      (inst addi ndescr rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
+                                lowtag-mask))
       (inst clrrwi ndescr ndescr n-lowtag-bits)
       (allocation header ndescr other-pointer-lowtag
                   :temp-tn gc-temp

Update of /cvsroot/sbcl/sbcl/src/compiler/hppa
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv25684/src/compiler/hppa

Modified Files:
	array.lisp 
Log Message:
1.0.23.66: Calculate array sizes in a more reliable way.

  * The old implementation depended on the array header size being
    an even number of words.

  * Also, another micro-optimization for MIPS.


Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/hppa/array.lisp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- array.lisp	14 Jul 2005 18:48:31 -0000	1.10
+++ array.lisp	23 Dec 2008 14:10:23 -0000	1.11
@@ -25,7 +25,8 @@
     (pseudo-atomic ()
       (inst move alloc-tn header)
       (inst dep other-pointer-lowtag 31 3 header)
-      (inst addi (* (1+ array-dimensions-offset) n-word-bytes) rank ndescr)
+      (inst addi (+ (* (1+ array-dimensions-offset) n-word-bytes) lowtag-mask)
+            rank ndescr)
       (inst dep 0 31 3 ndescr)
       (inst add alloc-tn ndescr alloc-tn)
       (inst addi (fixnumize (1- array-dimensions-offset)) rank ndescr)

Update of /cvsroot/sbcl/sbcl/src/runtime
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv26941/src/runtime

Modified Files:
	mips-assem.S 
Log Message:
1.0.23.65: MIPS runtime micro-optimization.


Index: mips-assem.S
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/mips-assem.S,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- mips-assem.S	4 Oct 2007 22:56:15 -0000	1.19
+++ mips-assem.S	23 Dec 2008 00:52:14 -0000	1.20
@@ -469,8 +469,10 @@
 multiple_value_return:
 
 	FEXPORT(fun_end_breakpoint_trap)
-	break	0x0, trap_FunEndBreakpoint
+	.set    noreorder
 	b	multiple_value_return
+	 break	0x0, trap_FunEndBreakpoint
+	.set    reorder
 	EXPORT(fun_end_breakpoint_end)
 	END(fun_end_breakpoint_guts)

Update of /cvsroot/sbcl/sbcl
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv26941

Modified Files:
	version.lisp-expr 
Log Message:
1.0.23.65: MIPS runtime micro-optimization.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4229
retrieving revision 1.4230
diff -u -d -r1.4229 -r1.4230
--- version.lisp-expr	22 Dec 2008 13:38:04 -0000	1.4229
+++ version.lisp-expr	23 Dec 2008 00:52:13 -0000	1.4230
@@ -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".)
-"1.0.23.64"
+"1.0.23.65"

Update of /cvsroot/sbcl/sbcl
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv21934

Modified Files:
	BUGS NEWS version.lisp-expr 
Log Message:
1.0.23.64: fixed bug 395

 * Add support for base-strings in fill-pointer output streams.

 * Also fix a bug revealed by this change in derivation of
   ARRAY-ELEMENT-TYPE return type.


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.558
retrieving revision 1.559
diff -u -d -r1.558 -r1.559
--- BUGS	22 Dec 2008 10:50:35 -0000	1.558
+++ BUGS	22 Dec 2008 13:38:04 -0000	1.559
@@ -1367,20 +1367,6 @@
     (FOO 1 2)
   gives NO-APPLICABLE-METHOD rather than an argument count error.
 
-395: Unicode and streams
-  One of the remaining problems in SBCL's Unicode support is the lack
-  of generality in certain streams.
-  a. FILL-POINTER-STREAMs: SBCL refuses to write (e.g. using FORMAT)
-     to streams made from strings that aren't character strings with
-     fill-pointers:
-       (let ((v (make-array 5 :fill-pointer 0 :element-type 'standard-char)))
-         (format v "foo")
-         v)
-     should return a non-simple base string containing "foo" but
-     instead errors.
-
-     (reported on sbcl-help by "tichy")
-
 396: block-compilation bug
     (let ((x 1))
       (dotimes (y 10)

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1447
retrieving revision 1.1448
diff -u -d -r1.1447 -r1.1448
--- NEWS	22 Dec 2008 10:50:36 -0000	1.1447
+++ NEWS	22 Dec 2008 13:38:04 -0000	1.1448
@@ -50,6 +50,11 @@
     and DEFSTRUCT forms :INCLUDEind structure classes defined using
     DEFCLASS :METACLASS STRUCTURE-CLASS now inherit their initforms.
     (reported by Bruno Haible and Stephen Wilson)
+  * bug fix: #395; fill-pointer output streams used now support
+    element-type BASE-CHAR as well.
+  * bug fix: compiler error when attempting to derive return value of
+    ARRAY-ELEMENT-TYPE when the array type was a union of intersection
+    types.
 
 changes in sbcl-1.0.23 relative to 1.0.22:
   * enhancement: when disassembling method functions, disassembly

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4228
retrieving revision 1.4229
diff -u -d -r1.4228 -r1.4229
--- version.lisp-expr	22 Dec 2008 12:00:24 -0000	1.4228
+++ version.lisp-expr	22 Dec 2008 13:38:04 -0000	1.4229
@@ -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".)
-"1.0.23.63"
+"1.0.23.64"

Update of /cvsroot/sbcl/sbcl/src/compiler
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv21934/src/compiler

Modified Files:
	srctran.lisp 
Log Message:
1.0.23.64: fixed bug 395

 * Add support for base-strings in fill-pointer output streams.

 * Also fix a bug revealed by this change in derivation of
   ARRAY-ELEMENT-TYPE return type.


Index: srctran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/srctran.lisp,v
retrieving revision 1.161
retrieving revision 1.162
diff -u -d -r1.161 -r1.162
--- srctran.lisp	18 Dec 2008 11:56:47 -0000	1.161
+++ srctran.lisp	22 Dec 2008 13:38:05 -0000	1.162
@@ -4073,13 +4073,15 @@
                        (specifier-type (consify element-type)))
                       (t
                        (error "can't understand type ~S~%" element-type))))))
-      (cond ((array-type-p array-type)
-             (get-element-type array-type))
-            ((union-type-p array-type)
-             (apply #'type-union
-                    (mapcar #'get-element-type (union-type-types array-type))))
-            (t
-             *universal-type*)))))
+      (labels ((recurse (type)
+                  (cond ((array-type-p type)
+                         (get-element-type type))
+                        ((union-type-p type)
+                         (apply #'type-union
+                                (mapcar #'recurse (union-type-types type))))
+                        (t
+                         *universal-type*))))
+        (recurse array-type)))))
 
 ;;; Like CMU CL, we use HEAPSORT. However, other than that, this code
 ;;; isn't really related to the CMU CL code, since instead of trying

Update of /cvsroot/sbcl/sbcl/tests
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv21934/tests

Modified Files:
	compiler.pure.lisp stream.pure.lisp 
Log Message:
1.0.23.64: fixed bug 395

 * Add support for base-strings in fill-pointer output streams.

 * Also fix a bug revealed by this change in derivation of
   ARRAY-ELEMENT-TYPE return type.


Index: compiler.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.pure.lisp,v
retrieving revision 1.186
retrieving revision 1.187
diff -u -d -r1.186 -r1.187
--- compiler.pure.lisp	2 Dec 2008 04:36:14 -0000	1.186
+++ compiler.pure.lisp	22 Dec 2008 13:38:05 -0000	1.187
@@ -2670,3 +2670,8 @@
 (with-test (:name :late-bound-primitive)
   (compile nil `(lambda ()
                   (funcall 'cons 1))))
+
+(with-test (:name :hairy-array-element-type-derivation)
+  (compile nil '(lambda (x)
+                 (declare (type (and simple-string (satisfies array-has-fill-pointer-p)) x))
+                 (array-element-type x))))

Index: stream.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/stream.pure.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- stream.pure.lisp	6 Aug 2007 11:50:48 -0000	1.18
+++ stream.pure.lisp	22 Dec 2008 13:38:05 -0000	1.19
@@ -332,3 +332,8 @@
                  (read-byte stream))
                (assert (not (listen stream)))))
         (ignore-errors (delete-file listen-testfile-name))))))
+
+(with-test (:name :bug-395)
+  (let ((v (make-array 5 :fill-pointer 0 :element-type 'standard-char)))
+    (format v "foo")
+    (assert (equal (coerce "foo" 'base-string) v))))

Update of /cvsroot/sbcl/sbcl/src/code
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv21934/src/code

Modified Files:
	stream.lisp 
Log Message:
1.0.23.64: fixed bug 395

 * Add support for base-strings in fill-pointer output streams.

 * Also fix a bug revealed by this change in derivation of
   ARRAY-ELEMENT-TYPE return type.


Index: stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/stream.lisp,v
retrieving revision 1.107
retrieving revision 1.108
diff -u -d -r1.107 -r1.108
--- stream.lisp	18 Dec 2008 10:48:21 -0000	1.107
+++ stream.lisp	22 Dec 2008 13:38:04 -0000	1.108
@@ -1557,10 +1557,10 @@
 ;;; the CLM, but they are required for the implementation of
 ;;; WITH-OUTPUT-TO-STRING.
 
-;;; FIXME: need to support (VECTOR BASE-CHAR) and (VECTOR NIL),
-;;; ideally without destroying all hope of efficiency.
+;;; FIXME: need to support (VECTOR NIL), ideally without destroying all hope
+;;; of efficiency.
 (deftype string-with-fill-pointer ()
-  '(and (vector character)
+  '(and (or (vector character) (vector base-char))
         (satisfies array-has-fill-pointer-p)))
 
 (defstruct (fill-pointer-output-stream
@@ -1579,53 +1579,63 @@
          (current+1 (1+ current)))
     (declare (fixnum current))
     (with-array-data ((workspace buffer) (start) (end))
-      (declare (type (simple-array character (*)) workspace))
-      (let ((offset-current (+ start current)))
-        (declare (fixnum offset-current))
-        (if (= offset-current end)
-            (let* ((new-length (1+ (* current 2)))
-                   (new-workspace (make-string new-length)))
-              (declare (type (simple-array character (*)) new-workspace))
-              (replace new-workspace workspace
-                       :start2 start :end2 offset-current)
-              (setf workspace new-workspace
-                    offset-current current)
-              (set-array-header buffer workspace new-length
-                                current+1 0 new-length nil))
-            (setf (fill-pointer buffer) current+1))
-        (setf (schar workspace offset-current) character)))
+      (string-dispatch
+          ((simple-array character (*))
+           (simple-array base-char (*)))
+          workspace
+        (let ((offset-current (+ start current)))
+          (declare (fixnum offset-current))
+          (if (= offset-current end)
+              (let* ((new-length (1+ (* current 2)))
+                     (new-workspace
+                      (ecase (array-element-type workspace)
+                        (character (make-string new-length
+                                                :element-type 'character))
+                        (base-char (make-string new-length
+                                                :element-type 'base-char)))))
+                (replace new-workspace workspace :start2 start :end2 offset-current)
+                (setf workspace new-workspace
+                      offset-current current)
+                (set-array-header buffer workspace new-length
+                                  current+1 0 new-length nil))
+              (setf (fill-pointer buffer) current+1))
+          (setf (char workspace offset-current) character))))
     current+1))
 
 (defun fill-pointer-sout (stream string start end)
-  (declare (simple-string string) (fixnum start end))
-  (let* ((string (if (typep string '(simple-array character (*)))
-                     string
-                     (coerce string '(simple-array character (*)))))
-         (buffer (fill-pointer-output-stream-string stream))
-         (current (fill-pointer buffer))
-         (string-len (- end start))
-         (dst-end (+ string-len current)))
-    (declare (fixnum current dst-end string-len))
-    (with-array-data ((workspace buffer) (dst-start) (dst-length))
-      (declare (type (simple-array character (*)) workspace))
-      (let ((offset-dst-end (+ dst-start dst-end))
-            (offset-current (+ dst-start current)))
-        (declare (fixnum offset-dst-end offset-current))
-        (if (> offset-dst-end dst-length)
-            (let* ((new-length (+ (the fixnum (* current 2)) string-len))
-                   (new-workspace (make-string new-length)))
-              (declare (type (simple-array character (*)) new-workspace))
-              (replace new-workspace workspace
-                       :start2 dst-start :end2 offset-current)
-              (setf workspace new-workspace
-                    offset-current current
-                    offset-dst-end dst-end)
-              (set-array-header buffer workspace new-length
-                                dst-end 0 new-length nil))
-            (setf (fill-pointer buffer) dst-end))
-        (replace workspace string
-                 :start1 offset-current :start2 start :end2 end)))
-    dst-end))
+  (declare (fixnum start end))
+  (string-dispatch
+      ((simple-array character (*))
+       (simple-array base-char (*)))
+      string
+    (let* ((buffer (fill-pointer-output-stream-string stream))
+           (current (fill-pointer buffer))
+           (string-len (- end start))
+           (dst-end (+ string-len current)))
+      (declare (fixnum current dst-end string-len))
+      (with-array-data ((workspace buffer) (dst-start) (dst-length))
+        (let ((offset-dst-end (+ dst-start dst-end))
+              (offset-current (+ dst-start current)))
+          (declare (fixnum offset-dst-end offset-current))
+          (if (> offset-dst-end dst-length)
+              (let* ((new-length (+ (the fixnum (* current 2)) string-len))
+                     (new-workspace
+                      (ecase (array-element-type workspace)
+                        (character (make-string new-length
+                                                :element-type 'character))
+                        (base-char (make-string new-length
+                                                :element-type 'base-char)))))
+                (replace new-workspace workspace
+                         :start2 dst-start :end2 offset-current)
+                (setf workspace new-workspace
+                      offset-current current
+                      offset-dst-end dst-end)
+                (set-array-header buffer workspace new-length
+                                  dst-end 0 new-length nil))
+              (setf (fill-pointer buffer) dst-end))
+          (replace workspace string
+                   :start1 offset-current :start2 start :end2 end)))
+      dst-end)))
 
 (defun fill-pointer-misc (stream operation &optional arg1 arg2)
   (declare (ignore arg2))
@@ -1659,8 +1669,9 @@
            (if found
                (- end (the fixnum found))
                current)))))
-     (:element-type (array-element-type
-                     (fill-pointer-output-stream-string stream)))))
+     (:element-type
+      (array-element-type
+       (fill-pointer-output-stream-string stream)))))
 
 ;;;; case frobbing streams, used by FORMAT ~(...~)

Update of /cvsroot/sbcl/sbcl/src/code
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv15533/src/code

Modified Files:
	hash-table.lisp 
Log Message:
1.0.23.63: WITH-HASH-TABLE-ITERATOR lambda-list beautification

 * Iterator lambda-list name is NAME, not FUNCTION, which was a bit
   confusing since it is bound to a macro.

 * Thanks to Tobias Rittweiler.


Index: hash-table.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/hash-table.lisp,v
retrieving revision 1.18
retrieving revision 1.19
diff -u -d -r1.18 -r1.19
--- hash-table.lisp	3 Jan 2008 03:54:05 -0000	1.18
+++ hash-table.lisp	22 Dec 2008 12:00:24 -0000	1.19
@@ -95,32 +95,32 @@
 ;; the generational garbage collector needs to know it.
 (defconstant +magic-hash-vector-value+ (ash 1 (1- sb!vm:n-word-bits)))
 
-(defmacro-mundanely with-hash-table-iterator ((function hash-table) &body body)
+(defmacro-mundanely with-hash-table-iterator ((name hash-table) &body body)
   #!+sb-doc
-  "WITH-HASH-TABLE-ITERATOR ((function hash-table) &body body)
+  "WITH-HASH-TABLE-ITERATOR ((name hash-table) &body body)
 
-Provides a method of manually looping over the elements of a hash-table.
-FUNCTION is bound to a generator-macro that, within the scope of the
-invocation, returns one or three values. The first value tells whether any
-objects remain in the hash table. When the first value is non-NIL, the second
-and third values are the key and the value of the next object.
+Provides a method of manually looping over the elements of a hash-table. NAME
+is bound to a generator-macro that, within the scope of the invocation,
+returns one or three values. The first value tells whether any objects remain
+in the hash table. When the first value is non-NIL, the second and third
+values are the key and the value of the next object.
 
-Consequences are undefined if HASH-TABLE is mutated during execution
-of BODY, except for changing or removing elements corresponding to the
-current key. The applies to all threads, not just the curren one --
-even for synchronized hash-tables. If the table may be mutated by
-another thread during iteration, use eg. SB-EXT:WITH-LOCKED-HASH-TABLE
-to protect the WITH-HASH-TABLE-ITERATOR for."
+Consequences are undefined if HASH-TABLE is mutated during execution of BODY,
+except for changing or removing elements corresponding to the current key. The
+applies to all threads, not just the curren one -- even for synchronized
+hash-tables. If the table may be mutated by another thread during iteration,
+use eg. SB-EXT:WITH-LOCKED-HASH-TABLE to protect the WITH-HASH-TABLE-ITERATOR
+for."
   ;; This essentially duplicates MAPHASH, so any changes here should
   ;; be reflected there as well.
-  (let ((n-function (gensym "WITH-HASH-TABLE-ITERATOR-")))
-    `(let ((,n-function
+  (let ((function (make-symbol (concatenate 'string (symbol-name name) "-FUN"))))
+    `(let ((,function
             (let* ((table ,hash-table)
                    (length (length (hash-table-next-vector table)))
                    (index 1))
               (declare (type index/2 index))
               (labels
-                  ((,function ()
+                  ((,name ()
                      ;; (We grab the table again on each iteration just in
                      ;; case it was rehashed by a PUTHASH.)
                      (let ((kv-vector (hash-table-table table)))
@@ -130,11 +130,11 @@
                                (value (aref kv-vector (1+ (* 2 index)))))
                            (incf index)
                            (unless (or (eq key +empty-ht-slot+)
-                                        (eq value +empty-ht-slot+))
+                                       (eq value +empty-ht-slot+))
                              (return (values t key value))))))))
-                #',function))))
-      (macrolet ((,function () '(funcall ,n-function)))
-        ,@body))))
+                #',name))))
+       (macrolet ((,name () '(funcall ,function)))
+         ,@body))))
 
 (defmacro-mundanely with-locked-hash-table ((hash-table) &body body)
   #!+sb-doc

Update of /cvsroot/sbcl/sbcl
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv15533

Modified Files:
	version.lisp-expr 
Log Message:
1.0.23.63: WITH-HASH-TABLE-ITERATOR lambda-list beautification

 * Iterator lambda-list name is NAME, not FUNCTION, which was a bit
   confusing since it is bound to a macro.

 * Thanks to Tobias Rittweiler.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4227
retrieving revision 1.4228
diff -u -d -r1.4227 -r1.4228
--- version.lisp-expr	21 Dec 2008 17:55:18 -0000	1.4227
+++ version.lisp-expr	22 Dec 2008 12:00:24 -0000	1.4228
@@ -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".)
-"1.0.23.62"
+"1.0.23.63"

Update of /cvsroot/sbcl/sbcl/tests
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv11018/tests

Modified Files:
	clos.impure.lisp 
Log Message:
1.0.23.62: fix bug 357

 Originally reported by Bruno Haible, more recently by Stephen Wilson.

 * SHARED-INITIALIZE (SLOT-OBJECT) should not check structure slots
   versus +SLOT-UNBOUND+: uninitialized slots are zeroed. Since adding
   slots to structure classes cannot cause those slots to be added to
   structure instances, we don't really have to check for boundness at
   all.

 * SB-PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST and
   SB-PCL::MAKE-STRUCTURE-CLASS-DEFSTRUCT-FORM did not take overridden
   slot specifications into account, and the latter also omitted
   initform and type information.

 * Delete SB-PCL::ALLOCATE-STRUCTURE-INSTANCE, unused.

 * ALLOCATE-INSTANCE (STRUCTURE-OBJECT) should not fall back on
   ALLOCATE-STANDARD-INSTANCE.


Index: clos.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/clos.impure.lisp,v
retrieving revision 1.101
retrieving revision 1.102
diff -u -d -r1.101 -r1.102
--- clos.impure.lisp	19 Dec 2008 15:20:44 -0000	1.101
+++ clos.impure.lisp	22 Dec 2008 10:50:36 -0000	1.102
@@ -1674,5 +1674,38 @@
   faax)
 (with-test (:name :no-implicit-declarations-for-local-specials)
   (assert (not (no-implicit-declarations-for-local-specials 1.0d0))))
+
+(defstruct bug-357-a
+  slot1
+  (slot2 t)
+  (slot3 (coerce pi 'single-float) :type single-float))
+(defclass bug-357-b (bug-357-a)
+  ((slot2 :initform 't2)
+   (slot4 :initform -44)
+   (slot5)
+   (slot6 :initform t)
+   (slot7 :initform (floor (* pi pi)))
+   (slot8 :initform 88))
+  (:metaclass structure-class))
+(defstruct (bug-357-c (:include bug-357-b (slot8 -88) (slot5 :ok)))
+  slot9
+  (slot10 t)
+  (slot11 (floor (exp 3))))
+(with-test (:name :bug-357)
+  (flet ((slots (x)
+           (list (bug-357-c-slot1 x)
+                 (bug-357-c-slot2 x)
+                 (bug-357-c-slot3 x)
+                 (bug-357-c-slot4 x)
+                 (bug-357-c-slot5 x)
+                 (bug-357-c-slot6 x)
+                 (bug-357-c-slot7 x)
+                 (bug-357-c-slot8 x)
+                 (bug-357-c-slot9 x)
+                 (bug-357-c-slot10 x)
+                 (bug-357-c-slot11 x))))
+    (let ((base (slots (make-bug-357-c))))
+      (assert (equal base (slots (make-instance 'bug-357-c))))
+      (assert (equal base '(nil t2 3.1415927 -44 :ok t 9 -88 nil t 20))))))
 
 ;;;; success

Update of /cvsroot/sbcl/sbcl
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv11018

Modified Files:
	BUGS NEWS 
Log Message:
1.0.23.62: fix bug 357

 Originally reported by Bruno Haible, more recently by Stephen Wilson.

 * SHARED-INITIALIZE (SLOT-OBJECT) should not check structure slots
   versus +SLOT-UNBOUND+: uninitialized slots are zeroed. Since adding
   slots to structure classes cannot cause those slots to be added to
   structure instances, we don't really have to check for boundness at
   all.

 * SB-PCL::STRUCTURE-TYPE-SLOT-DESCRIPTION-LIST and
   SB-PCL::MAKE-STRUCTURE-CLASS-DEFSTRUCT-FORM did not take overridden
   slot specifications into account, and the latter also omitted
   initform and type information.

 * Delete SB-PCL::ALLOCATE-STRUCTURE-INSTANCE, unused.

 * ALLOCATE-INSTANCE (STRUCTURE-OBJECT) should not fall back on
   ALLOCATE-STANDARD-INSTANCE.


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.557
retrieving revision 1.558
diff -u -d -r1.557 -r1.558
--- BUGS	21 Dec 2008 09:51:01 -0000	1.557
+++ BUGS	22 Dec 2008 10:50:35 -0000	1.558
@@ -1198,52 +1198,6 @@
     (make-instance 'bar)
   ]
 
-357: defstruct inheritance of initforms
-    (reported by Bruno Haible)
-  When defstruct and defclass (with :metaclass structure-class) are mixed,
-  1. some slot initforms are ignored by the DEFSTRUCT generated constructor
-     function, and 
-  2. all slot initforms are ignored by MAKE-INSTANCE. (This can be arguably
-     OK for initforms that were given in a DEFSTRUCT form, but for those
-     given in a DEFCLASS form, I think it qualifies as a bug.)
-  Test case:
-  (defstruct structure02a
-    slot1
-    (slot2 t)
-    (slot3 (floor pi)))
-  (defclass structure02b (structure02a)
-    ((slot4 :initform -44)
-     (slot5)
-     (slot6 :initform t)
-     (slot7 :initform (floor (* pi pi)))
-     (slot8 :initform 88))
-    (:metaclass structure-class))
-  (defstruct (structure02c (:include structure02b (slot8 -88)))
-    slot9 
-    (slot10 t)
-    (slot11 (floor (exp 3))))
-  ;; 1. Form:
-  (let ((a (make-structure02c)))
-    (list (structure02c-slot4 a)
-          (structure02c-slot5 a)
-          (structure02c-slot6 a)
-          (structure02c-slot7 a)))
-  Expected: (-44 nil t 9)
-  Got: (SB-PCL::..SLOT-UNBOUND.. SB-PCL::..SLOT-UNBOUND..
-        SB-PCL::..SLOT-UNBOUND.. SB-PCL::..SLOT-UNBOUND..)
-  ;; 2. Form:
-  (let ((b (make-instance 'structure02c)))
-    (list (structure02c-slot2 b)
-          (structure02c-slot3 b)
-          (structure02c-slot4 b)
-          (structure02c-slot6 b)
-          (structure02c-slot7 b)
-          (structure02c-slot8 b)
-          (structure02c-slot10 b)
-          (structure02c-slot11 b)))
-  Expected: (t 3 -44 t 9 -88 t 20)
-  Got: (0 0 0 0 0 0 0 0)
-
 359: wrong default value for ensure-generic-function's :generic-function-class argument
     (reported by Bruno Haible)
   ANSI CL is silent on this, but the MOP's specification of ENSURE-GENERIC-FUNCTION says:

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1446
retrieving revision 1.1447
diff -u -d -r1.1446 -r1.1447
--- NEWS	21 Dec 2008 15:03:11 -0000	1.1446
+++ NEWS	22 Dec 2008 10:50:36 -0000	1.1447
@@ -45,6 +45,11 @@
   * bug fix: #354; duplicated frames in backtraces due to
     non-tail-call-optimized XEPs to functions with return type NIL
     have been elimited.
+  * bug fix: #357; MAKE-INSTANCE/SHARED-INITIALIZE now
+    initializes structure object slots according to DEFSTRUCT initforms,
+    and DEFSTRUCT forms :INCLUDEind structure classes defined using
+    DEFCLASS :METACLASS STRUCTURE-CLASS now inherit their initforms.
+    (reported by Bruno Haible and Stephen Wilson)
 
 changes in sbcl-1.0.23 relative to 1.0.22:
   * enhancement: when disassembling method functions, disassembly