Steel Bank Common Lisp

Update of /cvsroot/sbcl/sbcl/contrib/sb-posix
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv27238/contrib/sb-posix

Modified Files:
	interface.lisp 
Log Message:
1.0.33.30: Fix sb-posix build on win32.

  * This was entirely symbol-export issues between win32 and non-win32.


Index: interface.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-posix/interface.lisp,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -d -r1.57 -r1.58
--- interface.lisp	17 Dec 2009 23:25:04 -0000	1.57
+++ interface.lisp	24 Dec 2009 00:08:12 -0000	1.58
@@ -728,7 +728,10 @@
 
 ;;; environment
 
-(export 'getenv :sb-posix)
+(eval-when (:compile-toplevel :load-toplevel)
+  ;; Do this at compile-time as Win32 code below refers to it as
+  ;; sb-posix:getenv.
+  (export 'getenv :sb-posix))
 (defun getenv (name)
   (let ((r (alien-funcall
             (extern-alien "getenv" (function (* char) c-string))
@@ -760,11 +763,13 @@
 (progn
   ;; Windows doesn't define a POSIX setenv, but happily their _putenv is sane.
   (define-call* "putenv" int minusp (string c-string))
+  (export 'setenv :sb-posix)
   (defun setenv (name value overwrite)
     (declare (string name value))
     (if (and (zerop overwrite) (sb-posix:getenv name))
         0
         (putenv (concatenate 'string name "=" value))))
+  (export 'unsetenv :sb-posix)
   (defun unsetenv (name)
     (declare (string name))
     (putenv (concatenate 'string name "="))))

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv27238

Modified Files:
	version.lisp-expr 
Log Message:
1.0.33.30: Fix sb-posix build on win32.

  * This was entirely symbol-export issues between win32 and non-win32.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4709
retrieving revision 1.4710
diff -u -d -r1.4709 -r1.4710
--- version.lisp-expr	22 Dec 2009 17:22:50 -0000	1.4709
+++ version.lisp-expr	24 Dec 2009 00:08:11 -0000	1.4710
@@ -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.33.29"
+"1.0.33.30"

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv23615

Modified Files:
	version.lisp-expr 
Log Message:
1.0.33.29: Fix x86oid backtrace on sigaltstack in LDB.

  * altstack_pointer_p() derives the location of the altstack from the 
value of arch_os_get_current_thread(), which returns a struct thread *. 
This caused the subsequent offset calculation to be off by a factor of 
sizeof(struct thread), thus completely overshooting the altstack area.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4708
retrieving revision 1.4709
diff -u -d -r1.4708 -r1.4709
--- version.lisp-expr	21 Dec 2009 16:30:08 -0000	1.4708
+++ version.lisp-expr	22 Dec 2009 17:22:50 -0000	1.4709
@@ -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.33.28"
+"1.0.33.29"

Update of /cvsroot/sbcl/sbcl/src/runtime
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv23615/src/runtime

Modified Files:
	backtrace.c 
Log Message:
1.0.33.29: Fix x86oid backtrace on sigaltstack in LDB.

  * altstack_pointer_p() derives the location of the altstack from the 
value of arch_os_get_current_thread(), which returns a struct thread *. 
This caused the subsequent offset calculation to be off by a factor of 
sizeof(struct thread), thus completely overshooting the altstack area.


Index: backtrace.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/backtrace.c,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -d -r1.45 -r1.46
--- backtrace.c	21 Apr 2009 11:25:53 -0000	1.45
+++ backtrace.c	22 Dec 2009 17:22:51 -0000	1.46
@@ -288,7 +288,7 @@
 static int
 altstack_pointer_p (void *p) {
 #ifndef LISP_FEATURE_WIN32
-    void* stack_start = arch_os_get_current_thread() + dynamic_values_bytes;
+    void* stack_start = ((void *)arch_os_get_current_thread()) + dynamic_values_bytes;
     void* stack_end = stack_start + 32*SIGSTKSZ;
 
     return (p > stack_start && p <= stack_end);

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv16353

Modified Files:
	version.lisp-expr 
Log Message:
1.0.33.28: Display descriptions for internal errors in the runtime.

  * In genesis, output a define with the descriptions of internal
errors.

  * In interr.c, create an array with said descriptions and use it when
describing an internal error.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4707
retrieving revision 1.4708
diff -u -d -r1.4707 -r1.4708
--- version.lisp-expr	21 Dec 2009 13:12:47 -0000	1.4707
+++ version.lisp-expr	21 Dec 2009 16:30:08 -0000	1.4708
@@ -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.33.27"
+"1.0.33.28"

Update of /cvsroot/sbcl/sbcl/src/compiler/generic
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv16353/src/compiler/generic

Modified Files:
	genesis.lisp 
Log Message:
1.0.33.28: Display descriptions for internal errors in the runtime.

  * In genesis, output a define with the descriptions of internal
errors.

  * In interr.c, create an array with said descriptions and use it when
describing an internal error.


Index: genesis.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/generic/genesis.lisp,v
retrieving revision 1.156
retrieving revision 1.157
diff -u -d -r1.156 -r1.157
--- genesis.lisp	19 Nov 2009 16:08:37 -0000	1.156
+++ genesis.lisp	21 Dec 2009 16:30:09 -0000	1.157
@@ -2832,7 +2832,9 @@
         (unless (eq nil (car current-error))
           (format t "#define ~A ~D~%"
                   (c-symbol-name (car current-error))
-                  i)))))
+                  i))))
+    (format t "#define INTERNAL_ERROR_NAMES \\~%~{~S~#[~:;, \\~%~]~}~%"
+            (map 'list #'cdr internal-errors)))
   (terpri)
 
   ;; I'm not really sure why this is in SB!C, since it seems

Update of /cvsroot/sbcl/sbcl/src/runtime
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv16353/src/runtime

Modified Files:
	interr.c 
Log Message:
1.0.33.28: Display descriptions for internal errors in the runtime.

  * In genesis, output a define with the descriptions of internal
errors.

  * In interr.c, create an array with said descriptions and use it when
describing an internal error.


Index: interr.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/interr.c,v
retrieving revision 1.26
retrieving revision 1.27
diff -u -d -r1.26 -r1.27
--- interr.c	22 Mar 2009 21:44:07 -0000	1.26
+++ interr.c	21 Dec 2009 16:30:09 -0000	1.27
@@ -117,6 +117,7 @@
 #endif
 }
 
+char *internal_error_descriptions[] = {INTERNAL_ERROR_NAMES};
 /* internal error handler for when the Lisp error system doesn't exist
  *
  * FIXME: Shouldn't error output go to stderr instead of stdout? (Alas,
@@ -129,7 +130,9 @@
     int len, scoffset, sc, offset, ch;
 
     len = *ptr++;
-    printf("internal error #%d\n", *ptr++);
+    printf("internal error #%d (%s)\n", *ptr,
+           internal_error_descriptions[*ptr]);
+    ptr++;
     len--;
     while (len > 0) {
         scoffset = *ptr++;

Update of /cvsroot/sbcl/sbcl/src/code
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv24751/src/code

Modified Files:
	describe.lisp 
Log Message:
1.0.33.27: fix regressions in DESCRIBE from 1.0.33.5


Index: describe.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/describe.lisp,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -d -r1.57 -r1.58
--- describe.lisp	4 Dec 2009 16:07:39 -0000	1.57
+++ describe.lisp	21 Dec 2009 13:12:47 -0000	1.58
@@ -167,39 +167,42 @@
     (base-char "base-char")
     (t "character")))
 
+(defun print-standard-describe-header (x stream)
+  (format stream "~&~A~%  [~A]~%"
+          (object-self-string x)
+          (object-type-string x)))
+
 (defgeneric describe-object (x stream))
 
 ;;; Catch-all.
+
 (defmethod describe-object ((x t) s)
-  (format s "~&~A~%  [~A]~%"
-          (object-self-string x)
-          (object-type-string x))
-  (values))
+  (print-standard-describe-header x s))
 
 (defmethod describe-object ((x cons) s)
-  (call-next-method)
+  (print-standard-describe-header x s)
   (describe-function x nil s))
 
 (defmethod describe-object ((x function) s)
-  (call-next-method)
+  (print-standard-describe-header x s)
   (describe-function nil x s))
 
 (defmethod describe-object ((x class) s)
-  (call-next-method)
+  (print-standard-describe-header x s)
   (describe-class nil x s)
   (describe-instance x s))
 
 (defmethod describe-object ((x sb-pcl::slot-object) s)
-  (call-next-method)
+  (print-standard-describe-header x s)
   (describe-instance x s))
 
 (defmethod describe-object ((x character) s)
-  (call-next-method)
+  (print-standard-describe-header x s)
   (format s "~%:_Char-code: ~S" (char-code x))
   (format s "~%:_Char-name: ~A~%_" (char-name x)))
 
 (defmethod describe-object ((x array) s)
-  (call-next-method)
+  (print-standard-describe-header x s)
   (format s "~%Element-type: ~S" (array-element-type x))
   (if (vectorp x)
       (if (array-has-fill-pointer-p x)
@@ -222,7 +225,7 @@
     (terpri s)))
 
 (defmethod describe-object ((x hash-table) s)
-  (call-next-method)
+  (print-standard-describe-header x s)
   ;; Don't print things which are already apparent from the printed
   ;; representation -- COUNT, TEST, and WEAKNESS
   (format s "~%Occupancy: ~,1F" (float (/ (hash-table-count x)
@@ -234,7 +237,7 @@
   (terpri s))
 
 (defmethod describe-object ((symbol symbol) stream)
-  (call-next-method)
+  (print-standard-describe-header symbol stream)
   ;; Describe the value cell.
   (let* ((kind (info :variable :kind symbol))
          (wot (ecase kind
@@ -318,42 +321,43 @@
       (terpri stream))))
 
 (defmethod describe-object ((package package) stream)
-  (call-next-method)
-  (describe-documentation package t stream)
-  (flet ((humanize (list)
-           (sort (mapcar (lambda (x)
-                           (if (packagep x)
-                               (package-name x)
-                               x))
-                         list)
-                 #'string<))
-         (out (label list)
-           (describe-stuff label list stream :escape nil)))
-    (let ((implemented (humanize (package-implemented-by-list package)))
-          (implements (humanize (package-implements-list package)))
-          (nicks (humanize (package-nicknames package)))
-          (uses (humanize (package-use-list package)))
-          (used (humanize (package-used-by-list package)))
-          (shadows (humanize (package-shadowing-symbols package)))
-          (this (list (package-name package)))
-          (exports nil))
-      (do-external-symbols (ext package)
-        (push ext exports))
-      (setf exports (humanize exports))
-      (when (package-locked-p package)
-        (format stream "~@:_Locked."))
-      (when (set-difference implemented this :test #'string=)
-        (out "Implemented-by-list" implemented))
-      (when (set-difference implements this :test #'string=)
-        (out "Implements-list" implements))
-      (out "Nicknames" nicks)
-      (out "Use-list" uses)
-      (out "Used-by-list" used)
-      (out "Shadows" shadows)
-      (out "Exports" exports)
-      (format stream "~@:_~S internal symbols."
-              (package-internal-symbol-count package))))
-  (terpri stream))
+  (print-standard-describe-header package stream)
+  (pprint-logical-block (stream nil)
+    (describe-documentation package t stream)
+    (flet ((humanize (list)
+             (sort (mapcar (lambda (x)
+                             (if (packagep x)
+                                 (package-name x)
+                                 x))
+                           list)
+                   #'string<))
+           (out (label list)
+             (describe-stuff label list stream :escape nil)))
+      (let ((implemented (humanize (package-implemented-by-list package)))
+            (implements (humanize (package-implements-list package)))
+            (nicks (humanize (package-nicknames package)))
+            (uses (humanize (package-use-list package)))
+            (used (humanize (package-used-by-list package)))
+            (shadows (humanize (package-shadowing-symbols package)))
+            (this (list (package-name package)))
+            (exports nil))
+        (do-external-symbols (ext package)
+          (push ext exports))
+        (setf exports (humanize exports))
+        (when (package-locked-p package)
+          (format stream "~@:_Locked."))
+        (when (set-difference implemented this :test #'string=)
+          (out "Implemented-by-list" implemented))
+        (when (set-difference implements this :test #'string=)
+          (out "Implements-list" implements))
+        (out "Nicknames" nicks)
+        (out "Use-list" uses)
+        (out "Used-by-list" used)
+        (out "Shadows" shadows)
+        (out "Exports" exports)
+        (format stream "~@:_~S internal symbols."
+                (package-internal-symbol-count package))))
+    (terpri stream)))
 
 ;;;; Helpers to deal with shared functionality

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv24751

Modified Files:
	version.lisp-expr 
Log Message:
1.0.33.27: fix regressions in DESCRIBE from 1.0.33.5


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4706
retrieving revision 1.4707
diff -u -d -r1.4706 -r1.4707
--- version.lisp-expr	18 Dec 2009 14:26:34 -0000	1.4706
+++ version.lisp-expr	21 Dec 2009 13:12:47 -0000	1.4707
@@ -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.33.26"
+"1.0.33.27"

Update of /cvsroot/sbcl/sbcl/doc/manual
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv17978/doc/manual

Modified Files:
	threading.texinfo 
Log Message:
1.0.33.26: enabled threads by default on x86[-64] Linux

 I'll let FreeBSD folks make the judgement if threads should be
 default there as well.

 Also: update INSTALL documentation regarding *FEATURES* a bit, and
 make the documentation clear about availability of threads on
 different builds.


Index: threading.texinfo
===================================================================
RCS file: /cvsroot/sbcl/sbcl/doc/manual/threading.texinfo,v
retrieving revision 1.14
retrieving revision 1.15
diff -u -d -r1.14 -r1.15
--- threading.texinfo	18 Jun 2009 12:41:14 -0000	1.14
+++ threading.texinfo	18 Dec 2009 14:26:34 -0000	1.15
@@ -9,9 +9,12 @@
 not allow Lisp control of the scheduler.  This is found in the
 SB-THREAD package.
 
-This requires Linux (2.6+ or systems with NPTL backports) running on the
-x86 or x86-64 architecture, or SunOS (Solaris) on the x86.  Support for
-threading on Darwin (Mac OS X) and FreeBSD on the x86 is experimental.
+Threads are part of the default build on x86[-64] Linux only.
+
+They are also experimentally supported on: x86[-64] Darwin (Mac OS X),
+x86[-64] FreeBSD, and x86 SunOS (Solaris). On these platforms threads
+must be explicitly enabled at build-time, see @file{INSTALL} for
+directions.
 
 @menu
 * Threading basics::

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv17978

Modified Files:
	INSTALL NEWS base-target-features.lisp-expr make-config.sh 
	version.lisp-expr 
Log Message:
1.0.33.26: enabled threads by default on x86[-64] Linux

 I'll let FreeBSD folks make the judgement if threads should be
 default there as well.

 Also: update INSTALL documentation regarding *FEATURES* a bit, and
 make the documentation clear about availability of threads on
 different builds.


Index: INSTALL
===================================================================
RCS file: /cvsroot/sbcl/sbcl/INSTALL,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -d -r1.31 -r1.32
--- INSTALL	4 Jun 2009 18:01:31 -0000	1.31
+++ INSTALL	18 Dec 2009 14:26:33 -0000	1.32
@@ -25,7 +25,7 @@
     $ sh run-sbcl.sh
 
   The following command installs SBCL and related documentation under
-  the "/usr/local" directory:
+  the "/usr/local" directory (typically run as root):
 
     # INSTALL_ROOT=/usr/local sh install.sh
 
@@ -159,13 +159,27 @@
                (pushnew x features))
              (disable (x)
                (setf features (remove x features))))
-        ;; Threading support, available only on x86/x86-64 Linux, x86 Solaris
-        ;; and x86 Mac OS X (experimental).
+        ;; Threading support.
         (enable :sb-thread)))
 
   This is the preferred way because it lets local changes interact
   cleanly with CVS changes to the main, global source tree.
 
+  Some features of interest:
+
+    :SB-THREAD
+      Native threads. Enabled by default on x86[-64] Linux only, also
+      available on x86[-64] Max OS X, x86[-64] FreeBSD, and x86
+      Solaris.
+
+    :SB-UNICODE
+      Unicode support. Enabled by default. Disabling this feature
+      limits characters to the 8-bit ISO-8859-1 set.
+
+    :SB-XREF-FOR-INTERNALS
+      XREF data for SBCL internals. Not enabled by default, increases
+      core size by 5-6mb.
+
   A catalog of available features and their meaning can be found in
   "base-target-features.lisp-expr".
 
@@ -243,7 +257,7 @@
   Supported operating systems and architectures:
 
                            x86 x86-64 PPC Sparc Alpha MIPS MIPSel
-    Linux 2.2, 2.4, 2.6     X     X    X    X     X     X     X
+    Linux 2.6               X     X    X    X     X     X     X
     Darwin (Mac OS X)       X     X    X
     Solaris                 X               X
     FreeBSD                 X     X

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1659
retrieving revision 1.1660
diff -u -d -r1.1659 -r1.1660
--- NEWS	18 Dec 2009 13:21:44 -0000	1.1659
+++ NEWS	18 Dec 2009 14:26:33 -0000	1.1660
@@ -1,5 +1,7 @@
 ;;;; -*- coding: utf-8; fill-column: 78 -*-
 changes relative to sbcl-1.0.33:
+  * minor incompatible change: threading support is now enabled by default
+    on x86[-64] Linux.
   * enhancement: SB-INTROSPECT:DEFTYPE-LAMBDA-LIST now also works on most
     builtin types.
   * enhancement: Errors during compile-time-too processing (i.e. EVAL-WHEN)

Index: base-target-features.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/base-target-features.lisp-expr,v
retrieving revision 1.52
retrieving revision 1.53
diff -u -d -r1.52 -r1.53
--- base-target-features.lisp-expr	12 Nov 2009 15:10:04 -0000	1.52
+++ base-target-features.lisp-expr	18 Dec 2009 14:26:34 -0000	1.53
@@ -216,12 +216,9 @@
 
  ;; low-level thread primitives support
  ;;
- ;; As of SBCL 0.8, this is only supposed to work in x86 Linux with
- ;; NPTL support (usually kernel 2.6, though sme Red Hat distributions
- ;; with older kernels also have it) and is implemented using clone(2)
- ;; and the %fs segment register.  Note that no consistent effort to
- ;; audit the SBCL library code for thread safety has been performed,
- ;; so caveat executor.
+ ;; As of SBCL 1.0.33.26, threads are part of the default build on
+ ;; x86oid Linux. Other platforms that support them include
+ ;; x86oid Darwin, FreeBSD, and Solaris.
  ; :sb-thread
 
  ;; lutex support

Index: make-config.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/make-config.sh,v
retrieving revision 1.91
retrieving revision 1.92
diff -u -d -r1.91 -r1.92
--- make-config.sh	29 Oct 2009 16:39:01 -0000	1.91
+++ make-config.sh	18 Dec 2009 14:26:34 -0000	1.92
@@ -160,9 +160,12 @@
         # If you add other platforms here, don't forget to edit
         # src/runtime/Config.foo-linux too.
         case "$sbcl_arch" in
-        x86 | x86-64 | mips)
-            printf ' :largefile' >> $ltf
-            ;;
+	    mips)
+		printf ' :largefile' >> $ltf
+		;;
+            x86 | x86-64)
+		printf ' :sb-thread :largefile' >> $ltf
+		;;
         esac
 
         if [ $sbcl_arch = "x86-64" ]; then

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4705
retrieving revision 1.4706
diff -u -d -r1.4705 -r1.4706
--- version.lisp-expr	18 Dec 2009 13:21:46 -0000	1.4705
+++ version.lisp-expr	18 Dec 2009 14:26:34 -0000	1.4706
@@ -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.33.25"
+"1.0.33.26"

Update of /cvsroot/sbcl/sbcl/contrib/sb-queue
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv31958/contrib/sb-queue

Modified Files:
	Makefile test-queue.lisp 
Added Files:
	queue.lisp sb-queue.asd 
Removed Files:
	sb-queue.lisp 
Log Message:
1.0.33.25: switch SB-QUEUE into using ASDF

 ...so that other systems can :depends-on it.


--- NEW FILE: queue.lisp ---
;;;; Lock-free FIFO queues, from "An Optimistic Approach to Lock-Free FIFO
;;;; Queues" by Edya Ladan-Mozes and Nir Shavit.
;;;;
;;;; Written by Nikodemus Siivola for SBCL.
;;;;
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was written at
;;;; Carnegie Mellon University and released into the public domain. The
;;;; software is in the public domain and is provided with absolutely no
;;;; warranty. See the COPYING and CREDITS files for more information.

(defpackage :sb-queue
  (:use :cl :sb-thread :sb-sys :sb-ext)
  (:export
   "DEQUEUE"
   "ENQUEUE"
   "LIST-QUEUE-CONTENTS"
   "MAKE-QUEUE"
   "QUEUE"
   "QUEUE-COUNT"
   "QUEUE-EMPTY-P"
   "QUEUE-NAME"
   "QUEUEP"))

(in-package :sb-queue)

(defconstant +dummy+ '.dummy.)

(declaim (inline make-node))
(defstruct node
  value
  (prev nil :type (or null node))
  (next nil :type (or null node)))

(declaim (inline %make-queue))
(defstruct (queue (:constructor %make-queue (head tail name))
                  (:copier nil)
                  (:predicate queuep))
  "Lock-free thread safe queue. ENQUEUE can be used to add objects to the queue,
and DEQUEUE retrieves items from the queue in FIFO order."
  (head (error "No HEAD.") :type node)
  (tail (error "No TAIL.") :type node)
  (name nil))

(setf (documentation 'queuep 'function)
      "Returns true if argument is a QUEUE, NIL otherwise."
      (documentation 'queue-name 'function)
      "Name of a QUEUE. Can be assingned to using SETF. Queue names
can be arbitrary printable objects, and need not be unique.")

(defun make-queue (&key name initial-contents)
  "Returns a new QUEUE with NAME and contents of the INITIAL-CONTENTS
sequence enqueued."
  (let* ((dummy (make-node :value +dummy+))
         (queue (%make-queue dummy dummy name)))
    (flet ((enc-1 (x)
             (enqueue x queue)))
      (declare (dynamic-extent #'enc-1))
      (map nil #'enc-1 initial-contents))
    queue))

(defun enqueue (value queue)
  "Adds VALUE to the end of QUEUE. Returns VALUE."
  (let ((node (make-node :value value)))
    (loop for tail = (queue-tail queue)
          do (setf (node-next node) tail)
             (when (eq tail (sb-ext:compare-and-swap (queue-tail queue) tail node))
               (setf (node-prev tail) node)
               (return value)))))

(defun dequeue (queue)
  "Retrieves the oldest value in QUEUE and returns it as the primary value,
and T as secondary value. If the queue is empty, returns NIL as both primary
and secondary value."
  (tagbody
   :continue
     (let* ((head (queue-head queue))
            (tail (queue-tail queue))
            (first-node-prev (node-prev head))
            (val (node-value head)))
       (when (eq head (queue-head queue))
         (cond ((not (eq val +dummy+))
                (if (eq tail head)
                    (let ((dummy (make-node :value +dummy+ :next tail)))
                      (when (eq tail (sb-ext:compare-and-swap (queue-tail queue)
                                                              tail dummy))
                        (setf (node-prev head) dummy))
                      (go :continue))
                    (when (null first-node-prev)
                      (fixList queue tail head)
                      (go :continue)))
                (when (eq head (sb-ext:compare-and-swap (queue-head queue)
                                                        head first-node-prev))
                  ;; This assignment is not present in the paper, but is
                  ;; equivalent to the free(head.ptr) call there: it unlinks
                  ;; the HEAD from the queue -- the code in the paper leaves
                  ;; the dangling pointer in place.
                  (setf (node-next first-node-prev) nil)
                  (return-from dequeue (values val t))))
               ((eq tail head)
                (return-from dequeue (values nil nil)))
               ((null first-node-prev)
                (fixList queue tail head)
                (go :continue))
               (t
                (sb-ext:compare-and-swap (queue-head queue)
                                         head first-node-prev)))))
     (go :continue)))

(defun fixlist (queue tail head)
  (let ((current tail))
    (loop while (and (eq head (queue-head queue)) (not (eq current head)))
          do (let ((next (node-next current)))
               (when (not next)
                 (return-from fixlist nil))
               (let ((nextNodePrev (node-prev next)))
                 (when (not (eq nextNodePrev current))
                   (setf (node-prev next) current))
                 (setf current next))))))

(defun list-queue-contents (queue)
  "Returns the contents of QUEUE as a list without removing them from the
QUEUE. Mainly useful for manual examination of queue state."
  (let (all)
    (labels ((walk (node)
               ;; Since NEXT pointers are always right, traversing from tail
               ;; to head is safe.
               (let ((value (node-value node))
                     (next (node-next node)))
                 (unless (eq +dummy+ value)
                   (push value all))
                 (when next
                   (walk next)))))
      (walk (queue-tail queue)))
    all))

(defun queue-count (queue)
  "Returns the number of objects in QUEUE. Mainly useful for manual
examination of queue state, and in PRINT-OBJECT methods: inefficient as it
walks the entire queue."
  (let ((n 0))
    (declare (unsigned-byte n))
    (labels ((walk (node)
               (let ((value (node-value node))
                     (next (node-next node)))
                 (unless (eq +dummy+ value)
                   (incf n))
                 (when next
                   (walk next)))))
      (walk (queue-tail queue))
      n)))

(defun queue-empty-p (queue)
  "Returns T if QUEUE is empty, NIL otherwise."
  (let* ((head (queue-head queue))
         (tail (queue-tail queue))
         (val (node-value head)))
    (and (eq head tail) (eq val +dummy+))))

(provide :sb-queue)

--- NEW FILE: sb-queue.asd ---
;;; -*-  Lisp -*-

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(defpackage :sb-queue-system
  (:use :asdf :cl))

(in-package :sb-queue-system)

(defsystem :sb-queue
  :components ((:file "queue")))

(defsystem :sb-queue-tests
  :depends-on (:sb-queue :sb-rt)
  :components ((:file "test-queue")))

(defmethod perform :after ((o load-op) (c (eql (find-system :sb-queue))))
  (provide 'sb-queue))

(defmethod perform ((o test-op) (c (eql (find-system :sb-queue))))
  (operate 'load-op :sb-queue-tests)
  (operate 'test-op :sb-queue-tests))

(defmethod perform ((op test-op) (com (eql (find-system :sb-queue-tests))))
  (or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
      (error "~S failed" 'test-op)))

Index: Makefile
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-queue/Makefile,v
retrieving revision 1.1
retrieving revision 1.2
diff -u -d -r1.1 -r1.2
--- Makefile	22 Jun 2009 11:53:51 -0000	1.1
+++ Makefile	18 Dec 2009 13:21:46 -0000	1.2
@@ -1,6 +1,2 @@
-MODULE=sb-queue
-include ../vanilla-module.mk
-
-test::
-	echo "TEST sb-queue"
-	$(SBCL) --disable-debugger --load test-queue.lisp
+SYSTEM=sb-queue
+include ../asdf-module.mk

Index: test-queue.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-queue/test-queue.lisp,v
retrieving revision 1.2
retrieving revision 1.3
diff -u -d -r1.2 -r1.3
--- test-queue.lisp	25 Jun 2009 14:55:41 -0000	1.2
+++ test-queue.lisp	18 Dec 2009 13:21:47 -0000	1.3
@@ -1,107 +1,151 @@
-(require :sb-queue)
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was written at
+;;;; Carnegie Mellon University and released into the public domain. The
+;;;; software is in the public domain and is provided with absolutely no
+;;;; warranty. See the COPYING and CREDITS files for more information.
 
 (defpackage :sb-queue-test
-  (:use :cl :sb-thread :sb-queue)
+  (:use :cl :sb-thread :sb-queue :sb-rt)
   (:export))
 
 (in-package :sb-queue-test)
 
-(let ((q (make-queue :name 'test-q :initial-contents '(1 2 3))))
-  (enqueue 4 q)
-  (assert (eq 'test-q (queue-name q)))
-  (multiple-value-bind (v ok) (dequeue q)
-    (assert (eql 1 v))
-    (assert (eq t ok)))
-  (assert (equal (list-queue-contents q) (list 2 3 4))))
+(deftest queue.1
+    (let ((q (make-queue :name 'test-q :initial-contents '(1 2 3))))
+      (enqueue 4 q)
+      (values (queue-name q)
+              (multiple-value-list (dequeue q))
+              (list-queue-contents q)))
+  test-q
+  (1 t)
+  (2 3 4))
 
-(assert (equal (list nil nil) (multiple-value-list (dequeue (make-queue)))))
+(deftest queue.2
+    (dequeue (make-queue))
+  nil
+  nil)
 
-(assert (equal (list nil t) (multiple-value-list (dequeue (make-queue :initial-contents '(nil))))))
+(deftest queue.3
+    (dequeue (make-queue :initial-contents '(nil)))
+  nil
+  t)
 
-(let ((x (make-instance 'structure-object))
-      (y (make-queue)))
-  (assert (not (typep x 'queue)))
-  (assert (not (queuep x)))
-  (assert (typep y 'queue))
-  (assert (queuep y)))
+(deftest queue.4
+    (let ((x (make-instance 'structure-object))
+          (y (make-queue)))
+      ;; I wonder why I thought this needs testing?
+      (values (typep x 'queue)
+              (queuep x)
+              (typep y 'queue)
+              (queuep y)))
+  nil nil t t)
 
-(let ((q (make-queue :initial-contents (vector 1 2 3 4 5))))
-  (assert (= 5 (queue-count q)))
-  (enqueue 'foo q)
-  (assert (= 6 (queue-count q)))
-  (dequeue q)
-  (assert (= 5 (queue-count q)))
-  (dequeue q)
-  (assert (= 4 (queue-count q)))
-  (dequeue q)
-  (assert (= 3 (queue-count q)))
-  (dequeue q)
-  (assert (= 2 (queue-count q)))
-  (dequeue q)
-  (assert (= 1 (queue-count q)))
-  (assert (not (queue-empty-p q)))
-  (dequeue q)
-  (assert (= 0 (queue-count q)))
-  (assert (queue-empty-p q))
-  (dequeue q)
-  (assert (= 0 (queue-count q)))
-  (assert (queue-empty-p q)))
+(deftest queue.5
+    (let ((q (make-queue :initial-contents (vector 1 2 3 4 5))))
+      (values (= 5 (queue-count q))
+              (enqueue 'foo q)
+              (= 6 (queue-count q))
+              (dequeue q)
+              (= 5 (queue-count q))
+              (dequeue q)
+              (= 4 (queue-count q))
+              (dequeue q)
+              (= 3 (queue-count q))
+              (dequeue q)
+              (= 2 (queue-count q))
+              (dequeue q)
+              (= 1 (queue-count q))
+              (not (queue-empty-p q))
+              (dequeue q)
+              (= 0 (queue-count q))
+              (queue-empty-p q)
+              (dequeue q)
+              (= 0 (queue-count q))
+              (queue-empty-p q)))
+  t
+  foo
+  t
+  1
+  t
+  2
+  t
+  3
+  t
+  4
+  t
+  5
+  t
+  t
+  foo
+  t
+  t
+  nil
+  t
+  t)
 
 #+sb-thread
-(let* ((q (make-queue))
-       (w (make-semaphore))
-       (r (make-semaphore))
-       (n 100000)
-       (schedulers (list
-                    (make-thread (lambda ()
-                                   (signal-semaphore r)
-                                   (wait-on-semaphore w)
-                                   (dotimes (i n)
-                                     (enqueue (cons :a i) q))))
-                    (make-thread (lambda ()
-                                   (signal-semaphore r)
-                                   (wait-on-semaphore w)
-                                   (dotimes (i n)
-                                     (enqueue (cons :b i) q))))
-                    (make-thread (lambda ()
-                                   (signal-semaphore r)
-                                   (wait-on-semaphore w)
-                                   (dotimes (i n)
-                                     (enqueue (cons :c i) q))))
-                    (make-thread (lambda ()
-                                   (signal-semaphore r)
-                                   (wait-on-semaphore w)
-                                   (dotimes (i n)
-                                     (enqueue (cons :d i) q)))))))
-  (loop repeat 4 do (wait-on-semaphore r))
-  (signal-semaphore w 4)
-  (mapc #'join-thread schedulers)
-  (let (a b c d)
-    (loop
-      (multiple-value-bind (item ok) (dequeue q)
-        (cond (item
-               (assert ok)
-               (case (car item)
-                 (:a (push (cdr item) a))
-                 (:b (push (cdr item) b))
-                 (:c (push (cdr item) c))
-                 (:d (push (cdr item) d))))
-              (t
-               (assert (not ok))
-               (return)))))
-    (labels ((check-list (list)
-               (when list
-                 (if (cdr list)
-                     (when (= (first list) (1- (second list)))
-                       (check-list (cdr list)))
-                     (= (first list) (1- n))))))
-      (assert (eq t (check-list (nreverse a))))
-      (assert (eq t (check-list (nreverse b))))
-      (assert (eq t (check-list (nreverse c))))
-      (assert (eq t (check-list (nreverse d)))))))
+(deftest queue.t.1
+    (let* ((q (make-queue))
+           (w (make-semaphore))
+           (r (make-semaphore))
+           (n 100000)
+           (schedulers (list
+                        (make-thread (lambda ()
+                                       (signal-semaphore r)
+                                       (wait-on-semaphore w)
+                                       (dotimes (i n)
+                                         (enqueue (cons :a i) q))))
+                        (make-thread (lambda ()
+                                       (signal-semaphore r)
+                                       (wait-on-semaphore w)
+                                       (dotimes (i n)
+                                         (enqueue (cons :b i) q))))
+                        (make-thread (lambda ()
+                                       (signal-semaphore r)
+                                       (wait-on-semaphore w)
+                                       (dotimes (i n)
+                                         (enqueue (cons :c i) q))))
+                        (make-thread (lambda ()
+                                       (signal-semaphore r)
+                                       (wait-on-semaphore w)
+                                       (dotimes (i n)
+                                         (enqueue (cons :d i) q)))))))
+      (loop repeat 4 do (wait-on-semaphore r))
+      (signal-semaphore w 4)
+      (mapc #'join-thread schedulers)
+      (let (a b c d)
+        (loop
+          (multiple-value-bind (item ok) (dequeue q)
+            (cond (item
+                   (assert ok)
+                   (case (car item)
+                     (:a (push (cdr item) a))
+                     (:b (push (cdr item) b))
+                     (:c (push (cdr item) c))
+                     (:d (push (cdr item) d))))
+                  (t
+                   (assert (not ok))
+                   (return)))))
+        (labels ((check-list (list)
+                   (when list
+                     (if (cdr list)
+                         (when (= (first list) (1- (second list)))
+                           (check-list (cdr list)))
+                         (= (first list) (1- n))))))
+          (values (check-list (nreverse a))
+                  (check-list (nreverse b))
+                  (check-list (nreverse c))
+                  (check-list (nreverse d))))))
+  t
+  t
+  t
+  t)
 
 #+sb-thread
-(let ((q (make-queue))
+(deftest queue.t.2
+    (let ((q (make-queue))
           (w (make-semaphore))
           (r (make-semaphore)))
       (dotimes (i 1000000)
@@ -127,98 +171,96 @@
                      (make-thread #'dq))))
           (loop repeat 4 do (wait-on-semaphore r))
           (signal-semaphore w 4)
-          (mapcar (lambda (th)
-                    (assert (eq t (join-thread th))))
-                  deschedulers))))
+          (mapcar #'join-thread deschedulers))))
+  (t t t t))
 
 #+sb-thread
-(let* ((q (make-queue))
-       (w (make-semaphore))
-       (r (make-semaphore))
-       (n 100000)
-       (schedulers (list
-                    (make-thread (lambda ()
-                                   (signal-semaphore r)
-                                   (wait-on-semaphore w)
-                                   (dotimes (i n)
-                                     (enqueue (cons :a i) q))))
-                    (make-thread (lambda ()
-                                   (signal-semaphore r)
-                                   (wait-on-semaphore w)
-                                   (dotimes (i n)
-                                     (enqueue (cons :b i) q))))
-                    (make-thread (lambda ()
-                                   (signal-semaphore r)
-                                   (wait-on-semaphore w)
-                                   (dotimes (i n)
-                                     (enqueue (cons :c i) q))))
-                    (make-thread (lambda ()
-                                   (signal-semaphore r)
-                                   (wait-on-semaphore w)
-                                   (dotimes (i n)
-                                     (enqueue (cons :d i) q)))))))
-  (flet ((dq ()
-           (let ((a -1)
-                 (ac 0)
-                 (b -1)
-                 (bc 0)
-                 (c -1)
-                 (cc 0)
-                 (d -1)
-                 (dc 0))
-             (signal-semaphore r)
-             (wait-on-semaphore w)
-             (loop (multiple-value-bind (item ok) (dequeue q)
-                     (cond (item
-                            (let ((n (cdr item)))
-                              (macrolet ((test (name c)
-                                           `(if (< ,name n)
-                                                (progn
-                                                  (setf ,name n)
-                                                  (incf ,c))
-                                                (return nil))))
-                                (ecase (car item)
-                                  (:a (test a ac))
-                                  (:b (test b bc))
-                                  (:c (test c cc))
-                                  (:d (test d dc))))))
-                           (t
-                            (assert (not ok))
-                            (unless (or (some #'thread-alive-p schedulers)
-                                        (not (queue-empty-p q)))
-                              (return (list a ac b bc c cc d dc))))))))))
-    (let ((deschedulers (list
-                         (make-thread #'dq)
-                         (make-thread #'dq)
-                         (make-thread #'dq)
-                         (make-thread #'dq))))
-      (loop repeat 8 do (wait-on-semaphore r))
-      (signal-semaphore w 8)
-      (let ((a -1)
-            (ac 0)
-            (b -1)
-            (bc 0)
-            (c -1)
-            (cc 0)
-            (d -1)
-            (dc 0))
-        (mapc (lambda (th)
-                (let ((results (join-thread th)))
-                  (when results
-                    (destructuring-bind (ta tac tb tbc tc tcc td tdc) results
-                      (setf a (max ta a)
-                            b (max tb b)
-                            c (max tc c)
-                            d (max td d))
-                      (incf ac tac)
-                      (incf bc tbc)
-                      (incf cc tcc)
-                      (incf dc tdc)))))
-              deschedulers)
-        (assert (and (= n ac (1+ a))
-                     (= n bc (1+ b))
-                     (= n cc (1+ c))
-                     (= n dc (1+ d))))))))
-
-;;;; Unix success convention for exit codes
-(sb-ext:quit :unix-status 0)
+(deftest queue.t.3
+    (let* ((q (make-queue))
+           (w (make-semaphore))
+           (r (make-semaphore))
+           (n 100000)
+           (schedulers (list
+                        (make-thread (lambda ()
+                                       (signal-semaphore r)
+                                       (wait-on-semaphore w)
+                                       (dotimes (i n)
+                                         (enqueue (cons :a i) q))))
+                        (make-thread (lambda ()
+                                       (signal-semaphore r)
+                                       (wait-on-semaphore w)
+                                       (dotimes (i n)
+                                         (enqueue (cons :b i) q))))
+                        (make-thread (lambda ()
+                                       (signal-semaphore r)
+                                       (wait-on-semaphore w)
+                                       (dotimes (i n)
+                                         (enqueue (cons :c i) q))))
+                        (make-thread (lambda ()
+                                       (signal-semaphore r)
+                                       (wait-on-semaphore w)
+                                       (dotimes (i n)
+                                         (enqueue (cons :d i) q)))))))
+      (flet ((dq ()
+               (let ((a -1)
+                     (ac 0)
+                     (b -1)
+                     (bc 0)
+                     (c -1)
+                     (cc 0)
+                     (d -1)
+                     (dc 0))
+                 (signal-semaphore r)
+                 (wait-on-semaphore w)
+                 (loop (multiple-value-bind (item ok) (dequeue q)
+                         (cond (item
+                                (let ((n (cdr item)))
+                                  (macrolet ((test (name c)
+                                               `(if (< ,name n)
+                                                    (progn
+                                                      (setf ,name n)
+                                                      (incf ,c))
+                                                    (return nil))))
+                                    (ecase (car item)
+                                      (:a (test a ac))
+                                      (:b (test b bc))
+                                      (:c (test c cc))
+                                      (:d (test d dc))))))
+                               (t
+                                (assert (not ok))
+                                (unless (or (some #'thread-alive-p schedulers)
+                                            (not (queue-empty-p q)))
+                                  (return (list a ac b bc c cc d dc))))))))))
+        (let ((deschedulers (list
+                             (make-thread #'dq)
+                             (make-thread #'dq)
+                             (make-thread #'dq)
+                             (make-thread #'dq))))
+          (loop repeat 8 do (wait-on-semaphore r))
+          (signal-semaphore w 8)
+          (let ((a -1)
+                (ac 0)
+                (b -1)
+                (bc 0)
+                (c -1)
+                (cc 0)
+                (d -1)
+                (dc 0))
+            (mapc (lambda (th)
+                    (let ((results (join-thread th)))
+                      (when results
+                        (destructuring-bind (ta tac tb tbc tc tcc td tdc) results
+                          (setf a (max ta a)
+                                b (max tb b)
+                                c (max tc c)
+                                d (max td d))
+                          (incf ac tac)
+                          (incf bc tbc)
+                          (incf cc tcc)
+                          (incf dc tdc)))))
+                  deschedulers)
+            (and (= n ac (1+ a))
+                 (= n bc (1+ b))
+                 (= n cc (1+ c))
+                 (= n dc (1+ d)))))))
+  t)

--- sb-queue.lisp DELETED ---

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv31958

Modified Files:
	NEWS version.lisp-expr 
Log Message:
1.0.33.25: switch SB-QUEUE into using ASDF

 ...so that other systems can :depends-on it.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1658
retrieving revision 1.1659
diff -u -d -r1.1658 -r1.1659
--- NEWS	18 Dec 2009 09:42:23 -0000	1.1658
+++ NEWS	18 Dec 2009 13:21:44 -0000	1.1659
@@ -6,6 +6,7 @@
     are now caught and reported just like errors during macroexpansion.
   * enhancement: SB-POSIX now provides access to tcdrain(), tcflow(),
     tcflush(), tcgetsid(), and tcsendbreak(). (thanks to Jerry James)
+  * enhancement: ASDF systems can now depends on SB-QUEUE.
   * fixes and improvements related to Unicode and external formats:
     ** bug fix: error handling and restart usage in the ucs-2 external format 
        has been improved.

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4704
retrieving revision 1.4705
diff -u -d -r1.4704 -r1.4705
--- version.lisp-expr	18 Dec 2009 09:42:23 -0000	1.4704
+++ version.lisp-expr	18 Dec 2009 13:21:46 -0000	1.4705
@@ -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.33.24"
+"1.0.33.25"

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv32080

Modified Files:
	NEWS version.lisp-expr 
Log Message:
1.0.33.24: both .FASL and .fasl force fasl-loading

 Bug with case-insensitive filesystems cause other implementations
 .FASL files to be loaded as source reported by Willem Broekema.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1657
retrieving revision 1.1658
diff -u -d -r1.1657 -r1.1658
--- NEWS	17 Dec 2009 23:25:04 -0000	1.1657
+++ NEWS	18 Dec 2009 09:42:23 -0000	1.1658
@@ -14,6 +14,10 @@
   * bug fix: SB-POSIX wrapper for putenv no longer tries to put lisp strings
     in the environment. setenv() and unsetenv() are also provided. (reported by
     Fare Rideau; launchpad bug lp#460455)
+  * bug fix: LOAD of both .fasl and .FASL type files now forces fasl-style
+    loading. This ensures sensible errors for .FASL files from other
+    implementations on case-insensitive filesystems. (reported by Willem
+    Broekema; launchpad bug lp#489417)
   * bug fix: #p"\\\\" can now be read without error on Win32.  (reported by
     Willem Broekema; launchpad bug lp#489698).
   * bug fix: some minor code rearrangements to reenable warning-free building

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4703
retrieving revision 1.4704
diff -u -d -r1.4703 -r1.4704
--- version.lisp-expr	18 Dec 2009 09:11:26 -0000	1.4703
+++ version.lisp-expr	18 Dec 2009 09:42:23 -0000	1.4704
@@ -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.33.23"
+"1.0.33.24"

Update of /cvsroot/sbcl/sbcl/src/code
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv32080/src/code

Modified Files:
	target-load.lisp 
Log Message:
1.0.33.24: both .FASL and .fasl force fasl-loading

 Bug with case-insensitive filesystems cause other implementations
 .FASL files to be loaded as source reported by Willem Broekema.


Index: target-load.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-load.lisp,v
retrieving revision 1.48
retrieving revision 1.49
diff -u -d -r1.48 -r1.49
--- target-load.lisp	24 Jun 2009 15:14:44 -0000	1.48
+++ target-load.lisp	18 Dec 2009 09:42:23 -0000	1.49
@@ -139,7 +139,7 @@
           (return-from load nil))
         (let* ((real (probe-file stream))
                (should-be-fasl-p
-                (and real (string= (pathname-type real) *fasl-file-type*))))
+                (and real (string-equal (pathname-type real) *fasl-file-type*))))
           ;; Don't allow empty .fasls, and assume other empty files
           ;; are source files.
           (when (and (or should-be-fasl-p (not (eql 0 (file-length stream))))

Update of /cvsroot/sbcl/sbcl/contrib/sb-introspect
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv22336/contrib/sb-introspect

Modified Files:
	introspect.lisp 
Log Message:
1.0.33.23: nuke trailing newline from error string

 Thanks to Stas Boukarev.


Index: introspect.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-introspect/introspect.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- introspect.lisp	28 Nov 2009 13:25:21 -0000	1.5
+++ introspect.lisp	18 Dec 2009 09:11:26 -0000	1.6
@@ -358,7 +358,7 @@
     ((or condition standard-object structure-object)
      (find-definition-source (class-of object)))
     (t
-     (error "Don't know how to retrieve source location for a ~S~%"
+     (error "Don't know how to retrieve source location for a ~S"
             (type-of object)))))
 
 (defun find-function-definition-source (function)

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv22336

Modified Files:
	version.lisp-expr 
Log Message:
1.0.33.23: nuke trailing newline from error string

 Thanks to Stas Boukarev.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4702
retrieving revision 1.4703
diff -u -d -r1.4702 -r1.4703
--- version.lisp-expr	18 Dec 2009 02:19:30 -0000	1.4702
+++ version.lisp-expr	18 Dec 2009 09:11:26 -0000	1.4703
@@ -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.33.22"
+"1.0.33.23"

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv16302

Modified Files:
	version.lisp-expr 
Log Message:
1.0.33.22: fix WITH-MUTEX docstring

Noted on sbcl-devel 2009-12-17 by William Halliburton.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4701
retrieving revision 1.4702
diff -u -d -r1.4701 -r1.4702
--- version.lisp-expr	17 Dec 2009 23:25:04 -0000	1.4701
+++ version.lisp-expr	18 Dec 2009 02:19:30 -0000	1.4702
@@ -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.33.21"
+"1.0.33.22"

Update of /cvsroot/sbcl/sbcl/src/code
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv16302/src/code

Modified Files:
	thread.lisp 
Log Message:
1.0.33.22: fix WITH-MUTEX docstring

Noted on sbcl-devel 2009-12-17 by William Halliburton.


Index: thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/thread.lisp,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -d -r1.31 -r1.32
--- thread.lisp	2 Dec 2009 08:54:43 -0000	1.31
+++ thread.lisp	18 Dec 2009 02:19:30 -0000	1.32
@@ -66,9 +66,9 @@
 (sb!xc:defmacro with-mutex ((mutex &key (value '*current-thread*) (wait-p t))
                             &body body)
   #!+sb-doc
-  "Acquire MUTEX for the dynamic scope of BODY, setting it to
-NEW-VALUE or some suitable default value if NIL.  If WAIT-P is non-NIL
-and the mutex is in use, sleep until it is available"
+  "Acquire MUTEX for the dynamic scope of BODY, setting it to VALUE or
+some suitable default value if NIL.  If WAIT-P is non-NIL and the mutex
+is in use, sleep until it is available"
   `(dx-flet ((with-mutex-thunk () ,@body))
      (call-with-mutex
       #'with-mutex-thunk

Update of /cvsroot/sbcl/sbcl
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv6279

Modified Files:
	NEWS version.lisp-expr 
Log Message:
1.0.33.21: safe SB-POSIX:PUTENV

 Reported by Fare Rideau: POSIX putenv() puts the actual string it is
 passed into environ, which is definitely wrong for any lisp string.

 Since we don't want to leak memory either, implement our own putenv()
 on top of setenv() -- and the other way around on Windows which
 doesn't have setenv().

 Messed up is what this is -- to keep a semblance of sanity add
 test-cases.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1656
retrieving revision 1.1657
diff -u -d -r1.1656 -r1.1657
--- NEWS	17 Dec 2009 12:13:56 -0000	1.1656
+++ NEWS	17 Dec 2009 23:25:04 -0000	1.1657
@@ -11,6 +11,9 @@
        has been improved.
     ** there is now an implementation of the ucs-4 external format.
     ** the utf-16 and utf-32 external formats are supported.
+  * bug fix: SB-POSIX wrapper for putenv no longer tries to put lisp strings
+    in the environment. setenv() and unsetenv() are also provided. (reported by
+    Fare Rideau; launchpad bug lp#460455)
   * bug fix: #p"\\\\" can now be read without error on Win32.  (reported by
     Willem Broekema; launchpad bug lp#489698).
   * bug fix: some minor code rearrangements to reenable warning-free building

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4700
retrieving revision 1.4701
diff -u -d -r1.4700 -r1.4701
--- version.lisp-expr	17 Dec 2009 21:01:47 -0000	1.4700
+++ version.lisp-expr	17 Dec 2009 23:25:04 -0000	1.4701
@@ -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.33.20"
+"1.0.33.21"

Update of /cvsroot/sbcl/sbcl/contrib/sb-posix
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv6279/contrib/sb-posix

Modified Files:
	interface.lisp posix-tests.lisp 
Log Message:
1.0.33.21: safe SB-POSIX:PUTENV

 Reported by Fare Rideau: POSIX putenv() puts the actual string it is
 passed into environ, which is definitely wrong for any lisp string.

 Since we don't want to leak memory either, implement our own putenv()
 on top of setenv() -- and the other way around on Windows which
 doesn't have setenv().

 Messed up is what this is -- to keep a semblance of sanity add
 test-cases.


Index: interface.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-posix/interface.lisp,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -d -r1.56 -r1.57
--- interface.lisp	17 Dec 2009 12:13:57 -0000	1.56
+++ interface.lisp	17 Dec 2009 23:25:04 -0000	1.57
@@ -736,7 +736,38 @@
     (declare (type (alien (* char)) r))
     (unless (null-alien r)
       (cast r c-string))))
-(define-call "putenv" int minusp (string c-string))
+#-win32
+(progn
+  (define-call "setenv" int minusp (name c-string) (value c-string) (overwrite int))
+  (define-call "unsetenv" int minusp (name c-string))
+  (export 'putenv :sb-posix)
+  (defun putenv (string)
+    (declare (string string))
+    ;; We don't want to call actual putenv: the string passed to putenv ends
+    ;; up in environ, and we any string we allocate GC might move.
+    ;;
+    ;; This makes our wrapper nonconformant if you squit hard enough, but
+    ;; users who care about that should really be calling putenv() directly in
+    ;; order to be able to manage memory sanely.
+    (let ((p (position #\= string))
+          (n (length string)))
+      (if p
+          (if (= p n)
+              (unsetenv (subseq string 0 p))
+              (setenv (subseq string 0 p) (subseq string (1+ p)) 1))
+          (error "Invalid argument to putenv: ~S" string)))))
+#+win32
+(progn
+  ;; Windows doesn't define a POSIX setenv, but happily their _putenv is sane.
+  (define-call* "putenv" int minusp (string c-string))
+  (defun setenv (name value overwrite)
+    (declare (string name value))
+    (if (and (zerop overwrite) (sb-posix:getenv name))
+        0
+        (putenv (concatenate 'string name "=" value))))
+  (defun unsetenv (name)
+    (declare (string name))
+    (putenv (concatenate 'string name "="))))
 
 ;;; syslog
 #-win32

Index: posix-tests.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-posix/posix-tests.lisp,v
retrieving revision 1.43
retrieving revision 1.44
diff -u -d -r1.43 -r1.44
--- posix-tests.lisp	31 Aug 2009 06:11:12 -0000	1.43
+++ posix-tests.lisp	17 Dec 2009 23:25:04 -0000	1.44
@@ -823,3 +823,31 @@
                (values (integerp fd) (pathname-name pathname))
             (delete-file temp)))))
   t "mkstemp-1")
+
+(deftest envstuff
+    (let ((name1 "ASLIFJLSDKFJKAHGSDKLJH")
+          (name2 "KJHFKLJDSHIUYHBSDNFCBH"))
+      (values (sb-posix:getenv name1)
+              (sb-posix:getenv name1)
+              (progn
+                (sb-posix:putenv (concatenate 'string name1 "=name1,test1"))
+                (sb-ext:gc :full t)
+                (sb-posix:getenv name1))
+              (progn
+                (sb-posix:setenv name1 "name1,test2" 0)
+                (sb-ext:gc :full t)
+                (sb-posix:getenv name1))
+              (progn
+                (sb-posix:setenv name2 "name2,test1" 0)
+                (sb-ext:gc :full t)
+                (sb-posix:getenv name2))
+              (progn
+                (sb-posix:setenv name2 "name2,test2" 1)
+                (sb-ext:gc :full t)
+                (sb-posix:getenv name2))))
+  nil
+  nil
+  "name1,test1"
+  "name1,test1"
+  "name2,test1"
+  "name2,test2")

Update of /cvsroot/sbcl/sbcl/src/compiler/x86
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv18021/src/compiler/x86

Modified Files:
	arith.lisp cell.lisp move.lisp system.lisp 
Log Message:
1.0.33.20: MORE CONSTANTIFICATION

Use FIXNUM-TAG-MASK and N-FIXNUM-TAG-BITS where appropriate.


Index: arith.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/arith.lisp,v
retrieving revision 1.58
retrieving revision 1.59
diff -u -d -r1.58 -r1.59
--- arith.lisp	1 May 2009 18:17:46 -0000	1.58
+++ arith.lisp	17 Dec 2009 21:01:47 -0000	1.59
@@ -359,7 +359,7 @@
   (:note "inline fixnum arithmetic")
   (:generator 4
     (move r x)
-    (inst sar r 2)
+    (inst sar r n-fixnum-tag-bits)
     (inst imul r y)))
 
 (define-vop (fast-*-c/fixnum=>fixnum fast-safe-arith-op)
@@ -445,8 +445,9 @@
     (inst cdq)
     (inst idiv eax y)
     (if (location= quo eax)
-        (inst shl eax 2)
-        (inst lea quo (make-ea :dword :index eax :scale 4)))
+        (inst shl eax n-fixnum-tag-bits)
+        (inst lea quo (make-ea :dword :index eax
+                               :scale (ash 1 n-fixnum-tag-bits))))
     (move rem edx)))
 
 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
@@ -471,8 +472,9 @@
     (inst mov y-arg (fixnumize y))
     (inst idiv eax y-arg)
     (if (location= quo eax)
-        (inst shl eax 2)
-        (inst lea quo (make-ea :dword :index eax :scale 4)))
+        (inst shl eax n-fixnum-tag-bits)
+        (inst lea quo (make-ea :dword :index eax
+                               :scale (ash 1 n-fixnum-tag-bits))))
     (move rem edx)))
 
 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)
@@ -1581,7 +1583,7 @@
   (:result-types unsigned-num)
   (:generator 1
     (move digit fixnum)
-    (inst sar digit 2)))
+    (inst sar digit n-fixnum-tag-bits)))
 
 (define-vop (bignum-floor)
   (:translate sb!bignum:%floor)
@@ -1617,7 +1619,7 @@
   (:generator 1
     (move res digit)
     (when (sc-is res any-reg control-stack)
-      (inst shl res 2))))
+      (inst shl res n-fixnum-tag-bits))))
 
 (define-vop (digit-ashr)
   (:translate sb!bignum:%ashr)

Index: cell.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/cell.lisp,v
retrieving revision 1.46
retrieving revision 1.47
diff -u -d -r1.46 -r1.47
--- cell.lisp	8 May 2009 19:08:08 -0000	1.46
+++ cell.lisp	17 Dec 2009 21:01:47 -0000	1.47
@@ -504,7 +504,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (when (sc-is index any-reg)
-      (inst shl tmp 2)
+      (inst shl tmp n-fixnum-tag-bits)
       (inst sub tmp index))
     (inst mov value (make-ea-for-raw-slot object index tmp 1))))
 
@@ -522,7 +522,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (when (sc-is index any-reg)
-      (inst shl tmp 2)
+      (inst shl tmp n-fixnum-tag-bits)
       (inst sub tmp index))
     (inst mov (make-ea-for-raw-slot object index tmp 1) value)
     (move result value)))
@@ -549,7 +549,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (when (sc-is index any-reg)
-      (inst shl tmp 2)
+      (inst shl tmp n-fixnum-tag-bits)
       (inst sub tmp index))
     (inst xadd (make-ea-for-raw-slot object index tmp 1) diff :lock)
     (move result diff)))
@@ -566,7 +566,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (when (sc-is index any-reg)
-      (inst shl tmp 2)
+      (inst shl tmp n-fixnum-tag-bits)
       (inst sub tmp index))
     (with-empty-tn@...)
       (inst fld (make-ea-for-raw-slot object index tmp 1)))))
@@ -585,7 +585,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (when (sc-is index any-reg)
-      (inst shl tmp 2)
+      (inst shl tmp n-fixnum-tag-bits)
       (inst sub tmp index))
     (unless (zerop (tn-offset value))
       (inst fxch value))
@@ -622,7 +622,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (when (sc-is index any-reg)
-      (inst shl tmp 2)
+      (inst shl tmp n-fixnum-tag-bits)
       (inst sub tmp index))
     (with-empty-tn@...)
       (inst fldd (make-ea-for-raw-slot object index tmp 2)))))
@@ -641,7 +641,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (when (sc-is index any-reg)
-      (inst shl tmp 2)
+      (inst shl tmp n-fixnum-tag-bits)
       (inst sub tmp index))
     (unless (zerop (tn-offset value))
       (inst fxch value))
@@ -679,7 +679,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (when (sc-is index any-reg)
-      (inst shl tmp 2)
+      (inst shl tmp n-fixnum-tag-bits)
       (inst sub tmp index))
     (let ((real-tn (complex-single-reg-real-tn value)))
       (with-empty-tn@... (real-tn)
@@ -702,7 +702,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (when (sc-is index any-reg)
-      (inst shl tmp 2)
+      (inst shl tmp n-fixnum-tag-bits)
       (inst sub tmp index))
     (let ((value-real (complex-single-reg-real-tn value))
           (result-real (complex-single-reg-real-tn result)))
@@ -758,7 +758,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (when (sc-is index any-reg)
-      (inst shl tmp 2)
+      (inst shl tmp n-fixnum-tag-bits)
       (inst sub tmp index))
     (let ((real-tn (complex-double-reg-real-tn value)))
       (with-empty-tn@... (real-tn)
@@ -781,7 +781,7 @@
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
     (when (sc-is index any-reg)
-      (inst shl tmp 2)
+      (inst shl tmp n-fixnum-tag-bits)
       (inst sub tmp index))
     (let ((value-real (complex-double-reg-real-tn value))
           (result-real (complex-double-reg-real-tn result)))

Index: move.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/move.lisp,v
retrieving revision 1.19
retrieving revision 1.20
diff -u -d -r1.19 -r1.20
--- move.lisp	18 Jul 2009 17:53:00 -0000	1.19
+++ move.lisp	17 Dec 2009 21:01:47 -0000	1.20
@@ -178,12 +178,12 @@
                    :from (:argument 0) :to (:result 0) :target y) eax)
   (:generator 4
     (move eax x)
-    (inst test al-tn 3)
+    (inst test al-tn fixnum-tag-mask)
     (inst jmp :z fixnum)
     (loadw y eax bignum-digits-offset other-pointer-lowtag)
     (inst jmp done)
     FIXNUM
-    (inst sar eax 2)
+    (inst sar eax n-fixnum-tag-bits)
     (move y eax)
     DONE))
 (define-move-vop move-to-word/integer :move
@@ -203,11 +203,12 @@
     (cond ((and (sc-is x signed-reg unsigned-reg)
                 (not (location= x y)))
            ;; Uses 7 bytes, but faster on the Pentium
-           (inst lea y (make-ea :dword :index x :scale 4)))
+           (inst lea y (make-ea :dword :index x
+                                :scale (ash 1 n-fixnum-tag-bits))))
           (t
            ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
            (move y x)
-           (inst shl y 2)))))
+           (inst shl y n-fixnum-tag-bits)))))
 (define-move-vop move-from-word/fixnum :move
   (signed-reg unsigned-reg) (any-reg descriptor-reg))
 
@@ -251,10 +252,10 @@
       ;; The assembly routines test the sign flag from this one, so if
       ;; you change stuff here, make sure the sign flag doesn't get
       ;; overwritten before the CALL!
-      (inst test x #.(ash lowtag-mask (- n-word-bits n-fixnum-tag-bits 1)))
+      (inst test x #.(ash lowtag-mask n-positive-fixnum-bits))
       ;; Faster but bigger then SHL Y 2. The cost of doing this speculatively
       ;; is noise compared to bignum consing if that is needed.
-      (inst lea y (make-ea :dword :index x :scale 4))
+      (inst lea y (make-ea :dword :index x :scale (ash 1 n-fixnum-tag-bits)))
       (inst jmp :z done)
       (inst mov y x)
       (inst call (make-fixup (ecase (tn-offset y)

Index: system.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/system.lisp,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -d -r1.27 -r1.28
--- system.lisp	20 Sep 2008 03:09:58 -0000	1.27
+++ system.lisp	17 Dec 2009 21:01:47 -0000	1.28
@@ -44,7 +44,7 @@
     (inst jmp :ne done)
 
     ;; Pick off fixnums.
-    (inst and al-tn 3)
+    (inst and al-tn fixnum-tag-mask)
     (inst jmp :e done)
 
     ;; must be an other immediate
@@ -142,7 +142,7 @@
   (:results (res :scs (any-reg descriptor-reg) :from (:argument 0)))
   (:generator 2
     (move res val)
-    (inst shl res (- n-widetag-bits 2))
+    (inst shl res (- n-widetag-bits n-fixnum-tag-bits))
     (inst or res (sc-case type
                    (unsigned-reg type)
                    (immediate (tn-value type))))))

Update of /cvsroot/sbcl/sbcl/src/compiler/x86-64
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv18021/src/compiler/x86-64

Modified Files:
	arith.lisp cell.lisp move.lisp system.lisp 
Log Message:
1.0.33.20: MORE CONSTANTIFICATION

Use FIXNUM-TAG-MASK and N-FIXNUM-TAG-BITS where appropriate.


Index: arith.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/arith.lisp,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -d -r1.31 -r1.32
--- arith.lisp	28 Jun 2009 21:37:05 -0000	1.31
+++ arith.lisp	17 Dec 2009 21:01:48 -0000	1.32
@@ -509,8 +509,9 @@
     (inst cqo)
     (inst idiv eax y)
     (if (location= quo eax)
-        (inst shl eax 3)
-        (inst lea quo (make-ea :qword :index eax :scale 8)))
+        (inst shl eax n-fixnum-tag-bits)
+        (inst lea quo (make-ea :qword :index eax
+                               :scale (ash 1 n-fixnum-tag-bits))))
     (move rem edx)))
 
 (define-vop (fast-truncate-c/fixnum=>fixnum fast-safe-arith-op)
@@ -537,8 +538,9 @@
         (setf y-arg (register-inline-constant :qword (fixnumize y))))
     (inst idiv eax y-arg)
     (if (location= quo eax)
-        (inst shl eax 3)
-        (inst lea quo (make-ea :qword :index eax :scale 8)))
+        (inst shl eax n-fixnum-tag-bits)
+        (inst lea quo (make-ea :qword :index eax
+                               :scale (ash 1 n-fixnum-tag-bits))))
     (move rem edx)))
 
 (define-vop (fast-truncate/unsigned=>unsigned fast-safe-arith-op)

Index: cell.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/cell.lisp,v
retrieving revision 1.32
retrieving revision 1.33
diff -u -d -r1.32 -r1.33
--- cell.lisp	25 Jun 2009 15:37:06 -0000	1.32
+++ cell.lisp	17 Dec 2009 21:01:48 -0000	1.33
@@ -530,7 +530,7 @@
   (:generator 5
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst shl tmp 3)
+    (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
     (inst mov value (make-ea-for-raw-slot object index tmp))))
 
@@ -563,7 +563,7 @@
   (:generator 5
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst shl tmp 3)
+    (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
     (inst mov (make-ea-for-raw-slot object index tmp) value)
     (move result value)))
@@ -626,7 +626,7 @@
   (:generator 5
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst shl tmp 3)
+    (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
     (inst movss value (make-ea-for-raw-slot object index tmp))))
 
@@ -659,7 +659,7 @@
   (:generator 5
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst shl tmp 3)
+    (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
     (inst movss (make-ea-for-raw-slot object index tmp) value)
     (move result value)))
@@ -703,7 +703,7 @@
   (:generator 5
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst shl tmp 3)
+    (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
     (inst movsd value (make-ea-for-raw-slot object index tmp))))
 
@@ -736,7 +736,7 @@
   (:generator 5
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst shl tmp 3)
+    (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
     (inst movsd (make-ea-for-raw-slot object index tmp) value)
     (move result value)))
@@ -780,7 +780,7 @@
   (:generator 5
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst shl tmp 3)
+    (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
     (inst movq value (make-ea-for-raw-slot object index tmp))))
 
@@ -813,7 +813,7 @@
   (:generator 5
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst shl tmp 3)
+    (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
     (move result value)
     (inst movq (make-ea-for-raw-slot object index tmp) value)))
@@ -857,7 +857,7 @@
   (:generator 5
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst shl tmp 3)
+    (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
     (inst movdqu value (make-ea-for-raw-slot object index tmp -8))))
 
@@ -890,7 +890,7 @@
   (:generator 5
     (loadw tmp object 0 instance-pointer-lowtag)
     (inst shr tmp n-widetag-bits)
-    (inst shl tmp 3)
+    (inst shl tmp n-fixnum-tag-bits)
     (inst sub tmp index)
     (move result value)
     (inst movdqu (make-ea-for-raw-slot object index tmp -8) value)))

Index: move.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/move.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- move.lisp	18 Jul 2009 17:53:00 -0000	1.13
+++ move.lisp	17 Dec 2009 21:01:48 -0000	1.14
@@ -238,7 +238,7 @@
   (:note "fixnum untagging")
   (:generator 1
     (move y x)
-    (inst sar y  (1- n-lowtag-bits))))
+    (inst sar y n-fixnum-tag-bits)))
 (define-move-vop move-to-word/fixnum :move
   (any-reg descriptor-reg) (signed-reg unsigned-reg))
 
@@ -266,12 +266,12 @@
                    :from (:argument 0) :to (:result 0) :target y) eax)
   (:generator 4
     (move eax x)
-    (inst test al-tn 7)                 ; a symbolic constant for this
-    (inst jmp :z FIXNUM)                ; would be nice
+    (inst test al-tn fixnum-tag-mask)
+    (inst jmp :z FIXNUM)
     (loadw y eax bignum-digits-offset other-pointer-lowtag)
     (inst jmp DONE)
     FIXNUM
-    (inst sar eax (1- n-lowtag-bits))
+    (inst sar eax n-fixnum-tag-bits)
     (move y eax)
     DONE))
 (define-move-vop move-to-word/integer :move
@@ -291,11 +291,12 @@
     (cond ((and (sc-is x signed-reg unsigned-reg)
                 (not (location= x y)))
            ;; Uses 7 bytes, but faster on the Pentium
-           (inst lea y (make-ea :qword :index x :scale 8)))
+           (inst lea y (make-ea :qword :index x
+                                :scale (ash 1 n-fixnum-tag-bits))))
           (t
            ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes
            (move y x)
-           (inst shl y (1- n-lowtag-bits))))))
+           (inst shl y n-fixnum-tag-bits)))))
 (define-move-vop move-from-word/fixnum :move
   (signed-reg unsigned-reg) (any-reg descriptor-reg))
 
@@ -346,7 +347,7 @@
   (:generator 20
     (aver (not (location= x y)))
     (let ((done (gen-label)))
-      (inst mov y #.(ash lowtag-mask (- n-word-bits n-fixnum-tag-bits 1)))
+      (inst mov y #.(ash lowtag-mask n-positive-fixnum-bits))
       ;; The assembly routines test the sign flag from this one, so if
       ;; you change stuff here, make sure the sign flag doesn't get
       ;; overwritten before the CALL!
@@ -354,7 +355,7 @@
       ;; Faster but bigger then SHL Y 4. The cost of doing this
       ;; speculatively should be noise compared to bignum consing if
       ;; that is needed and saves one branch.
-      (inst lea y (make-ea :qword :index x :scale 8))
+      (inst lea y (make-ea :qword :index x :scale (ash 1 n-fixnum-tag-bits)))
       (inst jmp :z done)
       (inst mov y x)
       (inst lea temp-reg-tn

Index: system.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/system.lisp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- system.lisp	17 May 2008 11:02:29 -0000	1.10
+++ system.lisp	17 Dec 2009 21:01:48 -0000	1.11
@@ -44,7 +44,7 @@
     (inst jmp :ne DONE)
 
     ;; Pick off fixnums.
-    (inst and al-tn 7)
+    (inst and al-tn fixnum-tag-mask)
     (inst jmp :e DONE)
 
     ;; must be an other immediate

Update of /cvsroot/sbcl/sbcl/src/compiler/hppa
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv18021/src/compiler/hppa

Modified Files:
	move.lisp system.lisp 
Log Message:
1.0.33.20: MORE CONSTANTIFICATION

Use FIXNUM-TAG-MASK and N-FIXNUM-TAG-BITS where appropriate.


Index: move.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/hppa/move.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- move.lisp	18 Jul 2009 17:53:00 -0000	1.6
+++ move.lisp	17 Dec 2009 21:01:47 -0000	1.7
@@ -169,7 +169,7 @@
   (:results (y :scs (signed-reg unsigned-reg)))
   (:note "integer to untagged word coercion")
   (:generator 3
-    (inst sra x 2 y)
+    (inst sra x n-fixnum-tag-bits y)
     (inst extru x 31 2 zero-tn :=)
     (loadw y x bignum-digits-offset other-pointer-lowtag)))
 
@@ -184,7 +184,7 @@
   (:result-types tagged-num)
   (:note "fixnum tagging")
   (:generator 1
-    (inst sll x 2 y)))
+    (inst sll x n-fixnum-tag-bits y)))
 
 (define-move-vop move-from-word/fixnum :move
   (signed-reg unsigned-reg) (any-reg descriptor-reg))
@@ -206,7 +206,7 @@
       ;; If we are left with zero, it will fit in a fixnum.  So branch around
       ;; the bignum-construction, doing the shift in the delay slot.
       (inst comb := temp zero-tn done)
-      (inst sll x 2 y)
+      (inst sll x n-fixnum-tag-bits y)
       ;; Make a single-digit bignum.
       (with-fixed-allocation
           (y nil temp bignum-widetag (1+ bignum-digits-offset) nil)
@@ -226,9 +226,9 @@
   (:temporary (:scs (non-descriptor-reg) :from (:argument 0)) x temp)
   (:generator 20
     (move arg x)
-    (inst srl x 29 temp)
+    (inst srl x n-positive-fixnum-bits temp)
     (inst comb := temp zero-tn done)
-    (inst sll x 2 y)
+    (inst sll x n-fixnum-tag-bits y)
     (pseudo-atomic (:extra (pad-data-block (+ bignum-digits-offset 2)))
       (set-lowtag other-pointer-lowtag alloc-tn y)
       (inst xor temp temp temp)

Index: system.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/hppa/system.lisp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- system.lisp	10 Jan 2009 11:19:22 -0000	1.7
+++ system.lisp	17 Dec 2009 21:01:47 -0000	1.8
@@ -29,7 +29,7 @@
     (inst li (logxor other-pointer-lowtag fun-pointer-lowtag) temp2)
     (inst xor temp1 temp2 temp1)
     (inst comb := temp1 zero-tn FUNCTION-PTR)
-    (inst li 3 temp1)  ; pick off fixnums
+    (inst li fixnum-tag-mask temp1)  ; pick off fixnums
     (inst li 1 temp2)
     (inst and temp1 object result)
     (inst comb := result zero-tn DONE)
@@ -129,7 +129,7 @@
   (:results (res :scs (any-reg descriptor-reg)))
   (:policy :fast-safe)
   (:generator 1
-    (inst zdep ptr 29 29 res)))
+    (inst zdep ptr n-positive-fixnum-bits n-positive-fixnum-bits res)))
 
 (define-vop (make-other-immediate-type)
   (:args (val :scs (any-reg descriptor-reg))

Update of /cvsroot/sbcl/sbcl/src/compiler/alpha
In directory sfp-cvsdas-3.v30.ch3.sourceforge.com:/tmp/cvs-serv18021/src/compiler/alpha

Modified Files:
	system.lisp 
Log Message:
1.0.33.20: MORE CONSTANTIFICATION

Use FIXNUM-TAG-MASK and N-FIXNUM-TAG-BITS where appropriate.


Index: system.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/alpha/system.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- system.lisp	14 Feb 2008 16:40:47 -0000	1.13
+++ system.lisp	17 Dec 2009 21:01:47 -0000	1.14
@@ -116,7 +116,7 @@
     (inst and t1 widetag-mask t1)
     (sc-case data
       (any-reg
-       (inst sll data (- n-widetag-bits 2) t2)
+       (inst sll data (- n-widetag-bits n-fixnum-tag-bits) t2)
        (inst bis t1 t2 t1))
       (immediate
        (let ((c (ash (tn-value data) n-widetag-bits)))