Steel Bank Common Lisp

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

Modified Files:
	c-call.lisp 
Log Message:
1.0.24.48: Do explicit sign-extension of small signed alien return values

        * gcc 4.3 has a different interpretation of the ABI, and
          zero-extends signed chars, shorts and (on x86-64) ints.


Index: c-call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/c-call.lisp,v
retrieving revision 1.42
retrieving revision 1.43
diff -u -d -r1.42 -r1.43
--- c-call.lisp	20 Sep 2008 03:09:58 -0000	1.42
+++ c-call.lisp	26 Jan 2009 01:54:47 -0000	1.43
@@ -78,6 +78,12 @@
             (values 'unsigned-byte-32 'unsigned-reg))
       (my-make-wired-tn ptype reg-sc (result-reg-offset num-results)))))
 
+(define-alien-type-method (integer :naturalize-gen) (type alien)
+  (if (and (alien-integer-type-signed type)
+           (<= (alien-type-bits type) 16))
+      `(sign-extend ,alien ,(alien-type-bits type))
+      alien))
+
 (define-alien-type-method (system-area-pointer :result-tn) (type state)
   (declare (ignore type))
   (let ((num-results (result-state-num-results state)))
@@ -181,6 +187,45 @@
                                     ,@(new-args))))))
         (sb!c::give-up-ir1-transform))))
 
+;;; The ABI is vague about how signed sub-word integer return values
+;;; are handled, but since gcc versions >=4.3 no longer do sign
+;;; extension in the callee, we need to do it in the caller.
+(defknown sign-extend ((signed-byte 16) t) fixnum
+    (foldable flushable movable))
+
+(define-vop (sign-extend)
+  (:translate sign-extend)
+  (:policy :fast-safe)
+  ;; Need to wire this to EAX since in x86 some dword registers don't
+  ;; have a matching word or byte register.
+  (:args (val :scs (signed-reg) :target eax))
+  (:temporary (:sc signed-reg :offset eax-offset :from :eval :to :result) eax)
+  (:arg-types fixnum (:constant fixnum))
+  (:info size)
+  (:results (res :scs (signed-reg)))
+  (:result-types fixnum)
+  (:ignore eax)
+  (:generator 1
+   (inst movsx res
+         (make-random-tn :kind :normal
+                         :sc (sc-or-lose (ecase size
+                                           (8 'byte-reg)
+                                           (16 'word-reg)))
+                         :offset (tn-offset val)))))
+
+#-sb-xc-host
+(defun sign-extend (x size)
+  (declare (type fixnum x))
+  (ecase size
+    (8 (sign-extend x size))
+    (16 (sign-extend x size))))
+
+#+sb-xc-host
+(defun sign-extend (x size)
+  (if (logbitp (1- size) x)
+      (dpb x (byte size 0) -1)
+      x))
+
 (define-vop (foreign-symbol-sap)
   (:translate foreign-symbol-sap)
   (:policy :fast-safe)

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

Modified Files:
	NEWS version.lisp-expr 
Log Message:
1.0.24.48: Do explicit sign-extension of small signed alien return values

        * gcc 4.3 has a different interpretation of the ABI, and
          zero-extends signed chars, shorts and (on x86-64) ints.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1464
retrieving revision 1.1465
diff -u -d -r1.1464 -r1.1465
--- NEWS	21 Jan 2009 17:29:08 -0000	1.1464
+++ NEWS	26 Jan 2009 01:54:47 -0000	1.1465
@@ -30,6 +30,8 @@
     unquoted symbol. Regression from 1.0.22.8. (reported by Ariel Badichi)
   * bug fix: named ENUMs in multiply-referenced alien record types no longer
     cause an implied type redefinition.  Regression from 1.0.21.29.
+  * bug fix: sign-extension of small signed return values now works with C
+    code compiled with gcc 4.3 or newer. (reported by Liam Healy)
   * improvements to the Windows port:
     ** SB-BSD-SOCKETS now works from saved cores as well. (reported by Stephen
        Westfold, thanks to Rudi Schlatte)

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4284
retrieving revision 1.4285
diff -u -d -r1.4284 -r1.4285
--- version.lisp-expr	21 Jan 2009 17:29:08 -0000	1.4284
+++ version.lisp-expr	26 Jan 2009 01:54:47 -0000	1.4285
@@ -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.24.47"
+"1.0.24.48"

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

Modified Files:
	c-call.lisp 
Log Message:
1.0.24.48: Do explicit sign-extension of small signed alien return values

        * gcc 4.3 has a different interpretation of the ABI, and
          zero-extends signed chars, shorts and (on x86-64) ints.


Index: c-call.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/c-call.lisp,v
retrieving revision 1.24
retrieving revision 1.25
diff -u -d -r1.24 -r1.25
--- c-call.lisp	17 Mar 2008 17:13:41 -0000	1.24
+++ c-call.lisp	26 Jan 2009 01:54:47 -0000	1.25
@@ -74,8 +74,6 @@
     (0 eax-offset)
     (1 edx-offset)))
 
-;; XXX The return handling probably doesn't conform to the ABI
-
 (define-alien-type-method (integer :result-tn) (type state)
   (let ((num-results (result-state-num-results state)))
     (setf (result-state-num-results state) (1+ num-results))
@@ -88,7 +86,7 @@
 (define-alien-type-method (integer :naturalize-gen) (type alien)
   (if (and (alien-integer-type-signed type)
            (<= (alien-type-bits type) 32))
-      `(sign-extend ,alien)
+      `(sign-extend ,alien ,(alien-type-bits type))
       alien))
 
 (define-alien-type-method (system-area-pointer :result-tn) (type state)
@@ -191,34 +189,41 @@
                                     ,@(new-args))))))
         (sb!c::give-up-ir1-transform))))
 
-;;; The ABI specifies that signed short/int's are returned as 32-bit
-;;; values. Negative values need to be sign-extended to 64-bits (done
-;;; in a :NATURALIZE-GEN alien-type-method).
-(defknown sign-extend ((signed-byte 32)) fixnum
-          (foldable flushable movable))
+;;; The ABI is vague about how signed sub-word integer return values
+;;; are handled, but since gcc versions >=4.3 no longer do sign
+;;; extension in the callee, we need to do it in the caller.
+(defknown sign-extend ((signed-byte 32) t) fixnum
+    (foldable flushable movable))
 
 (define-vop (sign-extend)
   (:translate sign-extend)
   (:policy :fast-safe)
   (:args (val :scs (signed-reg)))
-  (:arg-types fixnum)
+  (:arg-types fixnum (:constant fixnum))
+  (:info size)
   (:results (res :scs (signed-reg)))
   (:result-types fixnum)
   (:generator 1
    (inst movsxd res
          (make-random-tn :kind :normal
-                         :sc (sc-or-lose 'dword-reg)
+                         :sc (sc-or-lose (ecase size
+                                           (8 'byte-reg)
+                                           (16 'word-reg)
+                                           (32 'dword-reg)))
                          :offset (tn-offset val)))))
 
 #-sb-xc-host
-(defun sign-extend (x)
-  (declare (type (signed-byte 32) x))
-  (sign-extend x))
+(defun sign-extend (x size)
+  (declare (type fixnum x))
+  (ecase size
+    (8 (sign-extend x size))
+    (16 (sign-extend x size))
+    (32 (sign-extend x size))))
 
 #+sb-xc-host
-(defun sign-extend (x)
-  (if (logbitp 31 x)
-      (dpb x (byte 32 0) -1)
+(defun sign-extend (x size)
+  (if (logbitp (1- size) x)
+      (dpb x (byte size 0) -1)
       x))
 
 (define-vop (foreign-symbol-sap)

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

Modified Files:
	host-alieneval.lisp 
Log Message:
1.0.24.47: Fix 1.0.21.29 regression with enums in structs.

This is not the most elegant of fixes, but arrange to return the old
structure where applicable, and make incompatible mentions cause a 
CERROR with clobber continue semantics, to parallel what I think is the 
logic in the union/struct case.


Index: host-alieneval.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/host-alieneval.lisp,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -d -r1.45 -r1.46
--- host-alieneval.lisp	5 Jan 2009 08:55:20 -0000	1.45
+++ host-alieneval.lisp	21 Jan 2009 17:29:08 -0000	1.46
@@ -658,8 +658,16 @@
                  (auxiliary-alien-type :enum name env)
                (when old-p
                  (unless (alien-type-= result old)
-                   (warn "redefining alien enum ~S" name))))
-             (setf (auxiliary-alien-type :enum name env) result))
+                   (cerror "Continue, clobbering the old definition"
+                           "Incompatible alien enum type definition: ~S" name)
+                   (setf (alien-type-from old) (alien-type-from result)
+                         (alien-type-to old) (alien-type-to result)
+                         (alien-type-kind old) (alien-type-kind result)
+                         (alien-type-offset old) (alien-type-offset result)
+                         (alien-type-signed old) (alien-type-signed result)))
+                 (setf result old))
+               (unless old-p
+                 (setf (auxiliary-alien-type :enum name env) result))))
            result))
         (name
          (multiple-value-bind (result found)

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

Modified Files:
	foreign.test.sh 
Log Message:
1.0.24.47: Fix 1.0.21.29 regression with enums in structs.

This is not the most elegant of fixes, but arrange to return the old
structure where applicable, and make incompatible mentions cause a 
CERROR with clobber continue semantics, to parallel what I think is the 
logic in the union/struct case.


Index: foreign.test.sh
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/foreign.test.sh,v
retrieving revision 1.39
retrieving revision 1.40
diff -u -d -r1.39 -r1.40
--- foreign.test.sh	5 Jan 2009 08:55:20 -0000	1.39
+++ foreign.test.sh	21 Jan 2009 17:29:08 -0000	1.40
@@ -14,7 +14,9 @@
 # absolutely no warranty. See the COPYING and CREDITS files for
 # more information.
 
+. ./expect.sh
 . ./subr.sh
+
 use_test_subdirectory
 
 echo //entering foreign.test.sh
@@ -371,5 +373,28 @@
 EOF
 check_status_maybe_lose "struct offsets" $?
 
+cat > $TEST_FILESTEM.alien.enum.lisp <<EOF
+(define-alien-type foo-flag
+  (enum foo-flag-
+    (:a 1)
+    (:b 2)))
+
+(define-alien-type bar
+  (struct bar
+    (foo-flag foo-flag)))
+
+(define-alien-type barp
+  (* bar))
+
+(defun foo (x)
+  (declare (type (alien barp) x))
+  x)
+
+(defun bar (x)
+  (declare (type (alien barp) x))
+  x)
+EOF
+expect_clean_compile $TEST_FILESTEM.alien.enum.lisp
+
 # success convention for script
 exit $EXIT_TEST_WIN

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

Modified Files:
	NEWS version.lisp-expr 
Log Message:
1.0.24.47: Fix 1.0.21.29 regression with enums in structs.

This is not the most elegant of fixes, but arrange to return the old
structure where applicable, and make incompatible mentions cause a 
CERROR with clobber continue semantics, to parallel what I think is the 
logic in the union/struct case.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1463
retrieving revision 1.1464
diff -u -d -r1.1463 -r1.1464
--- NEWS	17 Jan 2009 10:56:47 -0000	1.1463
+++ NEWS	21 Jan 2009 17:29:08 -0000	1.1464
@@ -28,6 +28,8 @@
     longer reuses the functional from the previous expansion site.
   * bug fix: DEFTYPE no longer breaks on bodies consisting of a single
     unquoted symbol. Regression from 1.0.22.8. (reported by Ariel Badichi)
+  * bug fix: named ENUMs in multiply-referenced alien record types no longer
+    cause an implied type redefinition.  Regression from 1.0.21.29.
   * improvements to the Windows port:
     ** SB-BSD-SOCKETS now works from saved cores as well. (reported by Stephen
        Westfold, thanks to Rudi Schlatte)

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4283
retrieving revision 1.4284
diff -u -d -r1.4283 -r1.4284
--- version.lisp-expr	17 Jan 2009 10:56:48 -0000	1.4283
+++ version.lisp-expr	21 Jan 2009 17:29:08 -0000	1.4284
@@ -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.24.46"
+"1.0.24.47"

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

Modified Files:
	win32-sockets.lisp 
Log Message:
1.0.24.46: SB-BSD-SOCKETS workingness from saved cores on Windows

 * Need to call WSA-STARTUP on init.

 * Reported by Stephen Westfold, fix by Rudi Schlatte.


Index: win32-sockets.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-bsd-sockets/win32-sockets.lisp,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- win32-sockets.lisp	30 May 2006 12:03:00 -0000	1.3
+++ win32-sockets.lisp	17 Jan 2009 10:56:48 -0000	1.4
@@ -68,8 +68,16 @@
 (defun make-wsa-version (major minor)
   (dpb minor (byte 8 8) major))
 
-(defvar *wsa-startup-call*
-  (wsa-startup (make-wsa-version 2 2)))
+(defvar *wsa-startup-call* nil)
+
+(defun call-wsa-startup ()
+  (setf *wsa-startup-call* (wsa-startup (make-wsa-version 2 2))))
+
+;;; Startup!
+(call-wsa-startup)
+
+;;; Ensure startup for saved cores as well.
+(push 'call-wsa-startup sb-ext:*init-hooks*)
 
 ;; not implemented on win32
 (defconstant af-local 0)

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

Modified Files:
	NEWS version.lisp-expr 
Log Message:
1.0.24.46: SB-BSD-SOCKETS workingness from saved cores on Windows

 * Need to call WSA-STARTUP on init.

 * Reported by Stephen Westfold, fix by Rudi Schlatte.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1462
retrieving revision 1.1463
diff -u -d -r1.1462 -r1.1463
--- NEWS	15 Jan 2009 09:19:31 -0000	1.1462
+++ NEWS	17 Jan 2009 10:56:47 -0000	1.1463
@@ -28,6 +28,9 @@
     longer reuses the functional from the previous expansion site.
   * bug fix: DEFTYPE no longer breaks on bodies consisting of a single
     unquoted symbol. Regression from 1.0.22.8. (reported by Ariel Badichi)
+  * improvements to the Windows port:
+    ** SB-BSD-SOCKETS now works from saved cores as well. (reported by Stephen
+       Westfold, thanks to Rudi Schlatte)
 
 changes in sbcl-1.0.24 relative to 1.0.23:
   * new feature: ARRAY-STORAGE-VECTOR provides access to the underlying data

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4282
retrieving revision 1.4283
diff -u -d -r1.4282 -r1.4283
--- version.lisp-expr	17 Jan 2009 10:43:57 -0000	1.4282
+++ version.lisp-expr	17 Jan 2009 10:56:48 -0000	1.4283
@@ -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.24.45"
+"1.0.24.46"

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

Modified Files:
	version.lisp-expr 
Log Message:
1.0.24.45: handle IO errors in LDB and when saving the core

 * In LDB, if users response cannot be read, assume y.

 * Check fwrite() called when saving the core, and report the error.

 * Patch by Daniel Lowe.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4281
retrieving revision 1.4282
diff -u -d -r1.4281 -r1.4282
--- version.lisp-expr	16 Jan 2009 12:13:40 -0000	1.4281
+++ version.lisp-expr	17 Jan 2009 10:43:57 -0000	1.4282
@@ -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.24.44"
+"1.0.24.45"

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

Modified Files:
	monitor.c print.c save.c 
Log Message:
1.0.24.45: handle IO errors in LDB and when saving the core

 * In LDB, if users response cannot be read, assume y.

 * Check fwrite() called when saving the core, and report the error.

 * Patch by Daniel Lowe.


Index: monitor.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/monitor.c,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- monitor.c	11 Dec 2008 20:38:32 -0000	1.37
+++ monitor.c	17 Jan 2009 10:43:57 -0000	1.38
@@ -302,9 +302,13 @@
 
     printf("Really quit? [y] ");
     fflush(stdout);
-    fgets(buf, sizeof(buf), ldb_in);
-    if (buf[0] == 'y' || buf[0] == 'Y' || buf[0] == '\n')
+    if (fgets(buf, sizeof(buf), ldb_in)) {
+        if (buf[0] == 'y' || buf[0] == 'Y' || buf[0] == '\n')
+            exit(1);
+    } else {
+        printf("\nUnable to read response, assuming y.\n");
         exit(1);
+    }
 }
 
 static void

Index: print.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/print.c,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -d -r1.31 -r1.32
--- print.c	19 Feb 2008 10:18:08 -0000	1.31
+++ print.c	17 Jan 2009 10:43:57 -0000	1.32
@@ -195,12 +195,15 @@
             printf("More? [y] ");
             fflush(stdout);
 
-            fgets(buffer, sizeof(buffer), stdin);
-
-            if (buffer[0] == 'n' || buffer[0] == 'N')
-                throw_to_monitor();
-            else
+            if (fgets(buffer, sizeof(buffer), stdin)) {
+                if (buffer[0] == 'n' || buffer[0] == 'N')
+                    throw_to_monitor();
+                else
+                    cur_lines = 0;
+            } else {
+                printf("\nUnable to read response, assuming y.\n");
                 cur_lines = 0;
+            }
         }
     }
 

Index: save.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/save.c,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -d -r1.33 -r1.34
--- save.c	17 Oct 2008 12:49:37 -0000	1.33
+++ save.c	17 Jan 2009 10:43:57 -0000	1.34
@@ -56,13 +56,18 @@
         optarray[3] = options->thread_control_stack_size;
     }
 
-    fwrite(optarray, sizeof(size_t), RUNTIME_OPTIONS_WORDS, file);
+    if (RUNTIME_OPTIONS_WORDS !=
+        fwrite(optarray, sizeof(size_t), RUNTIME_OPTIONS_WORDS, file)) {
+        perror("Error writing runtime options to file");
+    }
 }
 
 static void
 write_lispobj(lispobj obj, FILE *file)
 {
-    fwrite(&obj, sizeof(lispobj), 1, file);
+    if (1 != fwrite(&obj, sizeof(lispobj), 1, file)) {
+        perror("Error writing to file");
+    }
 }
 
 static long
@@ -354,9 +359,13 @@
     write_runtime_options(file,
                           (save_runtime_options ? runtime_options : NULL));
 
-    fwrite(&core_start_pos, sizeof(os_vm_offset_t), 1, file);
-    write_lispobj(CORE_MAGIC, file);
-    fclose(file);
+    if (1 != fwrite(&core_start_pos, sizeof(os_vm_offset_t), 1, file)) {
+        perror("Error writing core starting position to file");
+        fclose(file);
+    } else {
+        write_lispobj(CORE_MAGIC, file);
+        fclose(file);
+    }
 
 #ifndef LISP_FEATURE_WIN32
     if (make_executable)
@@ -416,13 +425,20 @@
     size_t padding;
     void *padbytes;
 
-    fwrite(runtime, 1, runtime_size, output);
+    if (runtime_size != fwrite(runtime, 1, runtime_size, output)) {
+        perror("Error saving runtime");
+        return 0;
+    }
 
     padding = (os_vm_page_size - (runtime_size % os_vm_page_size)) & ~os_vm_page_size;
     if (padding > 0) {
         padbytes = successful_malloc(padding);
         memset(padbytes, 0, padding);
-        fwrite(padbytes, 1, padding, output);
+        if (padding != fwrite(padbytes, 1, padding, output)) {
+            perror("Error saving runtime");
+            free(padbytes);
+            return 0;
+        }
         free(padbytes);
     }

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

Modified Files:
	array.pure.lisp 
Log Message:
1.0.24.44: bug in INVALID-ARRAY-INDEX-ERROR, leaving EXPECTED-TYPE slot unbound

 * It's :EXPECTED-TYPE, not :TYPE. ...having compiler check calls to ERROR like
   this would be nice.

 * Marginally better test to catch this.


Index: array.pure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/array.pure.lisp,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -d -r1.33 -r1.34
--- array.pure.lisp	12 Jan 2009 11:26:42 -0000	1.33
+++ array.pure.lisp	16 Jan 2009 12:13:41 -0000	1.34
@@ -258,5 +258,6 @@
              (eval `(aref ,array 0 1 3))
            (sb-int:invalid-array-index-error (e)
              (when (and (eq array (sb-kernel::invalid-array-index-error-array e))
-                        (= 3 (type-error-datum e)))
+                        (= 3 (type-error-datum e))
+                        (equal '(integer 0 (3)) (type-error-expected-type e)))
                :right)))))))

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

Modified Files:
	array.lisp 
Log Message:
1.0.24.44: bug in INVALID-ARRAY-INDEX-ERROR, leaving EXPECTED-TYPE slot unbound

 * It's :EXPECTED-TYPE, not :TYPE. ...having compiler check calls to ERROR like
   this would be nice.

 * Marginally better test to catch this.


Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/array.lisp,v
retrieving revision 1.81
retrieving revision 1.82
diff -u -d -r1.81 -r1.82
--- array.lisp	12 Jan 2009 11:26:42 -0000	1.81
+++ array.lisp	16 Jan 2009 12:13:41 -0000	1.82
@@ -482,7 +482,7 @@
          :array array
          :axis axis
          :datum index
-         :type `(integer 0 (,bound))))
+         :expected-type `(integer 0 (,bound))))
 
 ;;; SUBSCRIPTS has a dynamic-extent list structure and is destroyed
 (defun %array-row-major-index (array subscripts

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

Modified Files:
	version.lisp-expr 
Log Message:
1.0.24.44: bug in INVALID-ARRAY-INDEX-ERROR, leaving EXPECTED-TYPE slot unbound

 * It's :EXPECTED-TYPE, not :TYPE. ...having compiler check calls to ERROR like
   this would be nice.

 * Marginally better test to catch this.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4280
retrieving revision 1.4281
diff -u -d -r1.4280 -r1.4281
--- version.lisp-expr	15 Jan 2009 09:19:31 -0000	1.4280
+++ version.lisp-expr	16 Jan 2009 12:13:40 -0000	1.4281
@@ -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.24.43"
+"1.0.24.44"

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

Modified Files:
	NEWS version.lisp-expr 
Log Message:
1.0.24.43: DEFTYPE to accept bodies consisting a single symbol

 * Regression from 1.0.22.8, reported by Ariel Badichi.


Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1461
retrieving revision 1.1462
diff -u -d -r1.1461 -r1.1462
--- NEWS	14 Jan 2009 18:37:20 -0000	1.1461
+++ NEWS	15 Jan 2009 09:19:31 -0000	1.1462
@@ -26,6 +26,8 @@
     result type VOID. (reported by Ken Olum)
   * bug fix: #235a; sequential inline expasion in different policies no
     longer reuses the functional from the previous expansion site.
+  * bug fix: DEFTYPE no longer breaks on bodies consisting of a single
+    unquoted symbol. Regression from 1.0.22.8. (reported by Ariel Badichi)
 
 changes in sbcl-1.0.24 relative to 1.0.23:
   * new feature: ARRAY-STORAGE-VECTOR provides access to the underlying data

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4279
retrieving revision 1.4280
diff -u -d -r1.4279 -r1.4280
--- version.lisp-expr	14 Jan 2009 18:37:20 -0000	1.4279
+++ version.lisp-expr	15 Jan 2009 09:19:31 -0000	1.4280
@@ -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.24.42"
+"1.0.24.43"

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

Modified Files:
	deftype.impure.lisp 
Log Message:
1.0.24.43: DEFTYPE to accept bodies consisting a single symbol

 * Regression from 1.0.22.8, reported by Ariel Badichi.


Index: deftype.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/deftype.impure.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- deftype.impure.lisp	1 Dec 2008 07:40:08 -0000	1.6
+++ deftype.impure.lisp	15 Jan 2009 09:19:32 -0000	1.7
@@ -44,3 +44,8 @@
 (assert (equal '(x) (sb-int:info :type :lambda-list 'bar)))
 (defclass bar () ())
 (assert (not (sb-int:info :type :lambda-list 'bar)))
+
+;; Need to work with plain symbols as the body.
+(defconstant whatever 't)
+(deftype anything () whatever)
+(assert (typep 42 'anything))

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

Modified Files:
	deftype.lisp 
Log Message:
1.0.24.43: DEFTYPE to accept bodies consisting a single symbol

 * Regression from 1.0.22.8, reported by Ariel Badichi.


Index: deftype.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/deftype.lisp,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -d -r1.11 -r1.12
--- deftype.lisp	1 Dec 2008 03:26:24 -0000	1.11
+++ deftype.lisp	15 Jan 2009 09:19:32 -0000	1.12
@@ -31,7 +31,7 @@
         ;; is not availble early enough.
         (if (and (not lambda-list) (not decls) (not (cdr forms))
                  (or (member (car forms) '(t nil))
-                     (eq 'quote (caar forms))))
+                     (and (consp (car forms)) (eq 'quote (caar forms)))))
             (values `(constant-type-expander ,(car forms)) doc '(sb!c:source-location))
             (with-unique-names (whole)
               (multiple-value-bind (macro-body local-decs doc)

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

Modified Files:
	ir1opt.lisp ir1tran-lambda.lisp ir1tran.lisp ir1util.lisp 
	node.lisp policy.lisp proclaim.lisp 
Log Message:
1.0.24.42: fix bug 235a

 AKA https://bugs.launchpad.net/sbcl/+bug/309141

 * Replace DEFINED-FUN-FUNCTIONAL with DEFINED-FUN-FUNCTIONALS, and reuse
   the functional only if policy matches.


Index: ir1opt.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1opt.lisp,v
retrieving revision 1.133
retrieving revision 1.134
diff -u -d -r1.133 -r1.134
--- ir1opt.lisp	21 Dec 2008 09:51:02 -0000	1.133
+++ ir1opt.lisp	14 Jan 2009 18:37:20 -0000	1.134
@@ -879,9 +879,9 @@
                             leaf
                             inlinep
                             (info :function :info name))))
-                 ;; allow backward references to this function from
-                 ;; following top level forms
-                 (setf (defined-fun-functional leaf) res)
+                 ;; Allow backward references to this function from following
+                 ;; forms. (Reused only if policy matches.)
+                 (push res (defined-fun-functionals leaf))
                  (change-ref-leaf ref res))))
         (let ((fun (defined-fun-functional leaf)))
           (if (or (not fun)
@@ -892,7 +892,8 @@
                   (with-ir1-environment-from-node call
                     (frob)
                     (locall-analyze-component *current-component*)))
-              ;; If we've already converted, change ref to the converted functional.
+              ;; If we've already converted, change ref to the converted
+              ;; functional.
               (change-ref-leaf ref fun))))
       (values (ref-leaf ref) nil))
      (t

Index: ir1tran-lambda.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran-lambda.lisp,v
retrieving revision 1.44
retrieving revision 1.45
diff -u -d -r1.44 -r1.45
--- ir1tran-lambda.lisp	12 Dec 2008 13:05:24 -0000	1.44
+++ ir1tran-lambda.lisp	14 Jan 2009 18:37:20 -0000	1.45
@@ -1016,7 +1016,7 @@
                                           :maybe-add-debug-catch t
                                           :source-name name)))
              (assert-global-function-definition-type name res)
-             (setf (defined-fun-functional defined-fun-res) res)
+             (push res (defined-fun-functionals defined-fun-res))
              (unless (eq (defined-fun-inlinep defined-fun-res) :notinline)
                (substitute-leaf-if
                 (lambda (ref)
@@ -1088,7 +1088,7 @@
              (setf (gethash name *free-funs*) res)))
           ;; If *FREE-FUNS* has a previously converted definition
           ;; for this name, then blow it away and try again.
-          ((defined-fun-functional found)
+          ((defined-fun-functionals found)
            (remhash name *free-funs*)
            (get-defined-fun name))
           (t found))))

Index: ir1tran.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1tran.lisp,v
retrieving revision 1.169
retrieving revision 1.170
diff -u -d -r1.169 -r1.170
--- ir1tran.lisp	2 Dec 2008 04:36:13 -0000	1.169
+++ ir1tran.lisp	14 Jan 2009 18:37:20 -0000	1.170
@@ -132,48 +132,51 @@
                        *universal-type*)
      :where-from where)))
 
-;;; Has the *FREE-FUNS* entry FREE-FUN become invalid?
-;;;
-;;; In CMU CL, the answer was implicitly always true, so this
-;;; predicate didn't exist.
+;;; Have some DEFINED-FUN-FUNCTIONALS of a *FREE-FUNS* entry become invalid?
+;;; Drop 'em.
 ;;;
-;;; This predicate was added to fix bug 138 in SBCL. In some obscure
-;;; circumstances, it was possible for a *FREE-FUNS* entry to contain a
-;;; DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object contained IR1
-;;; stuff (NODEs, BLOCKs...) referring to an already compiled (aka
-;;; "dead") component. When this IR1 stuff was reused in a new
-;;; component, under further obscure circumstances it could be used by
+;;; This was added to fix bug 138 in SBCL. It is possible for a *FREE-FUNS*
+;;; entry to contain a DEFINED-FUN whose DEFINED-FUN-FUNCTIONAL object
+;;; contained IR1 stuff (NODEs, BLOCKs...) referring to an already compiled
+;;; (aka "dead") component. When this IR1 stuff was reused in a new component,
+;;; under further obscure circumstances it could be used by
 ;;; WITH-IR1-ENVIRONMENT-FROM-NODE to generate a binding for
-;;; *CURRENT-COMPONENT*. At that point things got all confused, since
-;;; IR1 conversion was sending code to a component which had already
-;;; been compiled and would never be compiled again.
-(defun invalid-free-fun-p (free-fun)
+;;; *CURRENT-COMPONENT*. At that point things got all confused, since IR1
+;;; conversion was sending code to a component which had already been compiled
+;;; and would never be compiled again.
+;;;
+;;; Note: as of 1.0.24.41 this seems to happen only in XC, and the original
+;;; BUGS entry also makes it seem like this might not be an issue at all on
+;;; target.
+(defun clear-invalid-functionals (free-fun)
   ;; There might be other reasons that *FREE-FUN* entries could
   ;; become invalid, but the only one we've been bitten by so far
   ;; (sbcl-0.pre7.118) is this one:
-  (and (defined-fun-p free-fun)
-       (let ((functional (defined-fun-functional free-fun)))
-         (or (and functional
-                  (eql (functional-kind functional) :deleted))
-             (and (lambda-p functional)
-                  (or
-                   ;; (The main reason for this first test is to bail
-                   ;; out early in cases where the LAMBDA-COMPONENT
-                   ;; call in the second test would fail because links
-                   ;; it needs are uninitialized or invalid.)
-                   ;;
-                   ;; If the BIND node for this LAMBDA is null, then
-                   ;; according to the slot comments, the LAMBDA has
-                   ;; been deleted or its call has been deleted. In
-                   ;; that case, it seems rather questionable to reuse
-                   ;; it, and certainly it shouldn't be necessary to
-                   ;; reuse it, so we cheerfully declare it invalid.
-                   (null (lambda-bind functional))
-                   ;; If this IR1 stuff belongs to a dead component,
-                   ;; then we can't reuse it without getting into
-                   ;; bizarre confusion.
-                   (eql (component-info (lambda-component functional))
-                        :dead)))))))
+  (when (defined-fun-p free-fun)
+    (setf (defined-fun-functionals free-fun)
+          (delete-if (lambda (functional)
+                       (or (eq (functional-kind functional) :deleted)
+                           (when (lambda-p functional)
+                             (or
+                              ;; (The main reason for this first test is to bail
+                              ;; out early in cases where the LAMBDA-COMPONENT
+                              ;; call in the second test would fail because links
+                              ;; it needs are uninitialized or invalid.)
+                              ;;
+                              ;; If the BIND node for this LAMBDA is null, then
+                              ;; according to the slot comments, the LAMBDA has
+                              ;; been deleted or its call has been deleted. In
+                              ;; that case, it seems rather questionable to reuse
+                              ;; it, and certainly it shouldn't be necessary to
+                              ;; reuse it, so we cheerfully declare it invalid.
+                              (not (lambda-bind functional))
+                              ;; If this IR1 stuff belongs to a dead component,
+                              ;; then we can't reuse it without getting into
+                              ;; bizarre confusion.
+                              (eq (component-info (lambda-component functional))
+                                  :dead)))))
+                     (defined-fun-functionals free-fun)))
+    nil))
 
 ;;; If NAME already has a valid entry in *FREE-FUNS*, then return
 ;;; the value. Otherwise, make a new GLOBAL-VAR using information from
@@ -184,8 +187,9 @@
 (declaim (ftype (sfunction (t string) global-var) find-free-fun))
 (defun find-free-fun (name context)
   (or (let ((old-free-fun (gethash name *free-funs*)))
-        (and (not (invalid-free-fun-p old-free-fun))
-             old-free-fun))
+        (when old-free-fun
+          (clear-invalid-functionals old-free-fun)
+          old-free-fun))
       (ecase (info :function :kind name)
         ;; FIXME: The :MACRO and :SPECIAL-FORM cases could be merged.
         (:macro
@@ -1257,8 +1261,8 @@
     (when (defined-fun-p var)
       (setf (defined-fun-inline-expansion res)
             (defined-fun-inline-expansion var))
-      (setf (defined-fun-functional res)
-            (defined-fun-functional var)))
+      (setf (defined-fun-functionals res)
+            (defined-fun-functionals var)))
     ;; FIXME: Is this really right? Needs we not set the FUNCTIONAL
     ;; to the original global-var?
     res))

Index: ir1util.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/ir1util.lisp,v
retrieving revision 1.121
retrieving revision 1.122
diff -u -d -r1.121 -r1.122
--- ir1util.lisp	15 Dec 2008 09:40:07 -0000	1.121
+++ ir1util.lisp	14 Jan 2009 18:37:20 -0000	1.122
@@ -1141,6 +1141,14 @@
                    (eq (defined-fun-functional defined-fun) fun))
           (remhash name *free-funs*))))))
 
+;;; Return functional for DEFINED-FUN which has been converted in policy
+;;; corresponding to the current one, or NIL if no such functional exists.
+(defun defined-fun-functional (defined-fun)
+  (let ((policy (lexenv-%policy *lexenv*)))
+    (dolist (functional (defined-fun-functionals defined-fun))
+      (when (equal policy (lexenv-%policy (functional-lexenv functional)))
+        (return functional)))))
+
 ;;; Do stuff to delete the semantic attachments of a REF node. When
 ;;; this leaves zero or one reference, we do a type dispatch off of
 ;;; the leaf to determine if a special action is appropriate.

Index: node.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/node.lisp,v
retrieving revision 1.81
retrieving revision 1.82
diff -u -d -r1.81 -r1.82
--- node.lisp	12 Dec 2008 13:05:24 -0000	1.81
+++ node.lisp	14 Jan 2009 18:37:20 -0000	1.82
@@ -711,16 +711,16 @@
   ;; global environment.
   (inlinep nil :type inlinep)
   (inline-expansion nil :type (or cons null))
-  ;; the block-local definition of this function (either because it
-  ;; was semi-inline, or because it was defined in this block). If
-  ;; this function is not an entry point, then this may be deleted or
-  ;; LET-converted. Null if we haven't converted the expansion yet.
-  (functional nil :type (or functional null)))
+  ;; List of functionals corresponding to this DEFINED-FUN: either from the
+  ;; conversion of a NAMED-LAMBDA, or from inline-expansion (see
+  ;; RECOGNIZE-KNOWN-CALL) - we need separate functionals for each policy in
+  ;; which the function is used.
+  (functionals nil :type list))
 (defprinter (defined-fun :identity t)
   %source-name
   #!+sb-show id
   inlinep
-  (functional :test functional))
+  (functionals :test functionals))
 
 ;;;; function stuff
 
@@ -1163,7 +1163,7 @@
   (%source-name (missing-arg) :type symbol :read-only t))
 (defprinter (ref :identity t)
   #!+sb-show id
-  %source-name
+  (%source-name :test (neq %source-name '.anonymous.))
   leaf)
 
 ;;; Naturally, the IF node always appears at the end of a block.

Index: policy.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/policy.lisp,v
retrieving revision 1.21
retrieving revision 1.22
diff -u -d -r1.21 -r1.22
--- policy.lisp	1 Aug 2008 11:19:06 -0000	1.21
+++ policy.lisp	14 Jan 2009 18:37:20 -0000	1.22
@@ -89,6 +89,11 @@
 (declaim (type policy *policy*))
 (defvar *policy*)          ; initialized in cold init
 
+(defun sort-policy (policy)
+  ;; We occasionally want to compare policies using EQL, hence we
+  ;; canonize the order.
+  (sort policy #'string< :key #'car))
+
 ;;; This is to be called early in cold init to set things up, and may
 ;;; also be called again later in cold init in order to reset default
 ;;; optimization policy back to default values after toplevel PROCLAIM
@@ -111,12 +116,12 @@
           ;; Perhaps INHIBIT-NOTES?
           inhibit-warnings))
   (setf *policy*
-        (mapcar (lambda (name)
-                  ;; CMU CL didn't use 1 as the default for
-                  ;; everything, but since ANSI says 1 is the ordinary
-                  ;; value, we do.
-                  (cons name 1))
-                *policy-qualities*))
+        (sort-policy (mapcar (lambda (name)
+                               ;; CMU CL didn't use 1 as the default for
+                               ;; everything, but since ANSI says 1 is the ordinary
+                               ;; value, we do.
+                               (cons name 1))
+                             *policy-qualities*)))
   (setf *policy-restrictions* nil)
   ;; not actually POLICY, but very similar
   (setf *handled-conditions* nil

Index: proclaim.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/proclaim.lisp,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- proclaim.lisp	1 Aug 2008 11:19:06 -0000	1.37
+++ proclaim.lisp	14 Jan 2009 18:37:20 -0000	1.38
@@ -67,7 +67,7 @@
       (unless (assq (car old-entry) result)
         (push old-entry result)))
     ;; Voila.
-    result))
+    (sort-policy result)))
 
 (declaim (ftype (function (list list) list)
                 process-handle-conditions-decl))
@@ -254,7 +254,8 @@
                (process-package-lock-decl form *disabled-package-locks*)))
       ((inline notinline maybe-inline)
        (dolist (name args)
-         (proclaim-as-fun-name name) ; since implicitly it is a function
+         ; since implicitly it is a function, also scrubs *FREE-FUNS*
+         (proclaim-as-fun-name name)
          (setf (info :function :inlinep name)
                (ecase kind
                  (inline :inline)

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

Modified Files:
	compiler.impure.lisp 
Log Message:
1.0.24.42: fix bug 235a

 AKA https://bugs.launchpad.net/sbcl/+bug/309141

 * Replace DEFINED-FUN-FUNCTIONAL with DEFINED-FUN-FUNCTIONALS, and reuse
   the functional only if policy matches.


Index: compiler.impure.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/tests/compiler.impure.lisp,v
retrieving revision 1.98
retrieving revision 1.99
diff -u -d -r1.98 -r1.99
--- compiler.impure.lisp	19 Dec 2008 18:03:09 -0000	1.98
+++ compiler.impure.lisp	14 Jan 2009 18:37:20 -0000	1.99
@@ -1035,6 +1035,26 @@
        (flet ((i (x) (frob x (bug-405-foo-bar foo))))
          (i :five))))))
 
+;;; bug 235a
+(declaim (ftype (function (cons) number) bug-235a-aux))
+(declaim (inline bug-235a-aux))
+(defun bug-235a-aux (c)
+  (the number (car c)))
+(with-test (:name :bug-235a)
+  (let ((fun (compile nil
+                      `(lambda (x y)
+                         (values (locally (declare (optimize (safety 0)))
+                                   (bug-235a-aux x))
+                                 (locally (declare (optimize (safety 3)))
+                                   (bug-235a-aux y)))))))
+    (assert
+     (eq :error
+         (handler-case
+             (funcall fun '(:one) '(:two))
+           (type-error (e)
+             (assert (eq :two (type-error-datum e)))
+             (assert (eq 'number (type-error-expected-type e)))
+             :error))))))
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself

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

Modified Files:
	BUGS NEWS version.lisp-expr 
Log Message:
1.0.24.42: fix bug 235a

 AKA https://bugs.launchpad.net/sbcl/+bug/309141

 * Replace DEFINED-FUN-FUNCTIONAL with DEFINED-FUN-FUNCTIONALS, and reuse
   the functional only if policy matches.


Index: BUGS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/BUGS,v
retrieving revision 1.559
retrieving revision 1.560
diff -u -d -r1.559 -r1.560
--- BUGS	22 Dec 2008 13:38:04 -0000	1.559
+++ BUGS	14 Jan 2009 18:37:20 -0000	1.560
@@ -597,25 +597,6 @@
 
   This is probably the same bug as 162
 
-235: "type system and inline expansion"
-  a.
-  (declaim (ftype (function (cons) number) acc))
-  (declaim (inline acc))
-  (defun acc (c)
-    (the number (car c)))
-
-  (defun foo (x y)
-    (values (locally (declare (optimize (safety 0)))
-              (acc x))
-            (locally (declare (optimize (safety 3)))
-              (acc y))))
-
-  (foo '(nil) '(t)) => NIL, T.
-
-  As of 0.9.15.41 this seems to be due to ACC being inlined only once
-  inside FOO, which results in the second call reusing the FUNCTIONAL
-  resulting from the first -- which doesn't check the type.
-
 237: "Environment arguments to type functions"
   a. Functions SUBTYPEP, TYPEP, UPGRADED-ARRAY-ELEMENT-TYPE, and 
      UPGRADED-COMPLEX-PART-TYPE now have an optional environment

Index: NEWS
===================================================================
RCS file: /cvsroot/sbcl/sbcl/NEWS,v
retrieving revision 1.1460
retrieving revision 1.1461
diff -u -d -r1.1460 -r1.1461
--- NEWS	12 Jan 2009 15:00:21 -0000	1.1460
+++ NEWS	14 Jan 2009 18:37:20 -0000	1.1461
@@ -24,6 +24,8 @@
     computes the right offset for the memory copy.
   * bug fix: compilation problem involving inlined calls to aliens with
     result type VOID. (reported by Ken Olum)
+  * bug fix: #235a; sequential inline expasion in different policies no
+    longer reuses the functional from the previous expansion site.
 
 changes in sbcl-1.0.24 relative to 1.0.23:
   * new feature: ARRAY-STORAGE-VECTOR provides access to the underlying data

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4278
retrieving revision 1.4279
diff -u -d -r1.4278 -r1.4279
--- version.lisp-expr	12 Jan 2009 16:52:19 -0000	1.4278
+++ version.lisp-expr	14 Jan 2009 18:37:20 -0000	1.4279
@@ -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.24.41"
+"1.0.24.42"

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

Modified Files:
	gencgc.c 
Log Message:
1.0.24.41: add necessary disambiguating curly braces to runtime

 * When QSHOW is undefined FSHOW(...) expands into nothing, leading to unexpected
   results for code like
   
     if (gencgc_verbose)
       FSHOW(...)

   as the conditional will then apply to the next syntactic element.

 * Patch by Daniel Lowe.


Index: gencgc.c
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/runtime/gencgc.c,v
retrieving revision 1.139
retrieving revision 1.140
diff -u -d -r1.139 -r1.140
--- gencgc.c	13 Dec 2008 10:52:07 -0000	1.139
+++ gencgc.c	12 Jan 2009 16:52:19 -0000	1.140
@@ -1515,9 +1515,10 @@
     gc_assert(from_space_p(object));
     gc_assert((nwords & 0x01) == 0);
 
-    if ((nwords > 1024*1024) && gencgc_verbose)
+    if ((nwords > 1024*1024) && gencgc_verbose) {
         FSHOW((stderr, "/copy_large_unboxed_object: %d bytes\n",
                nwords*N_WORD_BYTES));
+    }
 
     /* Check whether it's a large object. */
     first_page = find_page_index((void *)object);
@@ -1586,10 +1587,11 @@
             next_page++;
         }
 
-        if ((bytes_freed > 0) && gencgc_verbose)
+        if ((bytes_freed > 0) && gencgc_verbose) {
             FSHOW((stderr,
                    "/copy_large_unboxed bytes_freed=%d\n",
                    bytes_freed));
+        }
 
         generations[from_space].bytes_allocated -=
             nwords*N_WORD_BYTES + bytes_freed;
@@ -2231,28 +2233,31 @@
         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
             if ((unsigned long)pointer !=
                 ((unsigned long)start_addr+FUN_POINTER_LOWTAG)) {
-                if (gencgc_verbose)
+                if (gencgc_verbose) {
                     FSHOW((stderr,
                            "/Wf2: %x %x %x\n",
                            pointer, start_addr, *start_addr));
+                }
                 return 0;
             }
             break;
         default:
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "/Wf3: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
         }
         break;
     case LIST_POINTER_LOWTAG:
         if ((unsigned long)pointer !=
             ((unsigned long)start_addr+LIST_POINTER_LOWTAG)) {
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "/Wl1: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
         }
         /* Is it plausible cons? */
@@ -2262,44 +2267,49 @@
              is_lisp_immediate(start_addr[1])))
             break;
         else {
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "/Wl2: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
         }
     case INSTANCE_POINTER_LOWTAG:
         if ((unsigned long)pointer !=
             ((unsigned long)start_addr+INSTANCE_POINTER_LOWTAG)) {
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "/Wi1: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
         }
         if (widetag_of(start_addr[0]) != INSTANCE_HEADER_WIDETAG) {
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "/Wi2: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
         }
         break;
     case OTHER_POINTER_LOWTAG:
         if ((unsigned long)pointer !=
             ((unsigned long)start_addr+OTHER_POINTER_LOWTAG)) {
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "/Wo1: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
         }
         /* Is it plausible?  Not a cons. XXX should check the headers. */
         if (is_lisp_pointer(start_addr[0]) || ((start_addr[0] & 3) == 0)) {
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "/Wo2: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
         }
         switch (widetag_of(start_addr[0])) {
@@ -2309,26 +2319,29 @@
 #if N_WORD_BITS == 64
         case SINGLE_FLOAT_WIDETAG:
 #endif
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "*Wo3: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
 
             /* only pointed to by function pointers? */
         case CLOSURE_HEADER_WIDETAG:
         case FUNCALLABLE_INSTANCE_HEADER_WIDETAG:
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "*Wo4: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
 
         case INSTANCE_HEADER_WIDETAG:
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "*Wo5: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
 
             /* the valid other immediate pointer objects */
@@ -2431,18 +2444,20 @@
             break;
 
         default:
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 FSHOW((stderr,
                        "/Wo6: %x %x %x\n",
                        pointer, start_addr, *start_addr));
+            }
             return 0;
         }
         break;
     default:
-        if (gencgc_verbose)
+        if (gencgc_verbose) {
             FSHOW((stderr,
                    "*W?: %x %x %x\n",
                    pointer, start_addr, *start_addr));
+        }
         return 0;
     }
 
@@ -3146,8 +3161,9 @@
             /* New areas of objects allocated have been lost so need to do a
              * full scan to be sure! If this becomes a problem try
              * increasing NUM_NEW_AREAS. */
-            if (gencgc_verbose)
+            if (gencgc_verbose) {
                 SHOW("new_areas overflow, doing full scavenge");
+            }
 
             /* Don't need to record new areas that get scavenged
              * anyway during scavenge_newspace_generation_one_scan. */
@@ -4206,8 +4222,9 @@
     generations[generation].alloc_large_unboxed_start_page = 0;
 
     if (generation >= verify_gens) {
-        if (gencgc_verbose)
+        if (gencgc_verbose) {
             SHOW("verifying");
+        }
         verify_gc();
         verify_dynamic_space();
     }
@@ -4435,8 +4452,9 @@
 {
     page_index_t page;
 
-    if (gencgc_verbose > 1)
+    if (gencgc_verbose > 1) {
         SHOW("entering gc_free_heap");
+    }
 
     for (page = 0; page < page_table_pages; page++) {
         /* Skip free pages which should already be zero filled. */

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

Modified Files:
	version.lisp-expr 
Log Message:
1.0.24.41: add necessary disambiguating curly braces to runtime

 * When QSHOW is undefined FSHOW(...) expands into nothing, leading to unexpected
   results for code like
   
     if (gencgc_verbose)
       FSHOW(...)

   as the conditional will then apply to the next syntactic element.

 * Patch by Daniel Lowe.


Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4277
retrieving revision 1.4278
diff -u -d -r1.4277 -r1.4278
--- version.lisp-expr	12 Jan 2009 16:20:37 -0000	1.4277
+++ version.lisp-expr	12 Jan 2009 16:52:19 -0000	1.4278
@@ -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.24.40"
+"1.0.24.41"

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

Modified Files:
	tn.lisp 
Log Message:
1.0.24.40: fix regression from 1.0.24.37

 * TNs with KIND :CONSTANT don't have leaves if they represent load
   time values.

 * Reported by Attila Lendvai.


Index: tn.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/tn.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- tn.lisp	19 Sep 2008 19:06:01 -0000	1.16
+++ tn.lisp	12 Jan 2009 16:20:37 -0000	1.17
@@ -445,6 +445,16 @@
   (aver (eq (tn-kind tn) :constant))
   (constant-value (tn-leaf tn)))
 
+(defun immediate-tn-p (tn)
+  (declare (type tn tn))
+  (let ((leaf (tn-leaf tn)))
+    ;; Leaves with KIND :CONSTANT can have NIL as the leaf if they
+    ;; represent load time values.
+    (and leaf
+         (eq (tn-kind tn) :constant)
+         (eq (immediate-constant-sc (constant-value leaf))
+             (sc-number-or-lose 'sb!vm::immediate)))))
+
 ;;; Force TN to be allocated in a SC that doesn't need to be saved: an
 ;;; unbounded non-save-p SC. We don't actually make it a real "restricted" TN,
 ;;; but since we change the SC to an unbounded one, we should always succeed in

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

Modified Files:
	pred.lisp 
Log Message:
1.0.24.40: fix regression from 1.0.24.37

 * TNs with KIND :CONSTANT don't have leaves if they represent load
   time values.

 * Reported by Attila Lendvai.


Index: pred.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86/pred.lisp,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- pred.lisp	11 Jan 2009 18:39:08 -0000	1.10
+++ pred.lisp	12 Jan 2009 16:20:37 -0000	1.11
@@ -91,10 +91,6 @@
         (let ((scn (sc-number-or-lose representation)))
           (labels ((make-tn ()
                      (make-representation-tn ptype scn))
-                   (immediate-tn-p (tn)
-                     (and (eq (sb!c::tn-kind tn) :constant)
-                          (eq (sb!c::immediate-constant-sc (tn-value tn))
-                              (sc-number-or-lose 'immediate))))
                    (frob-tn (tn)
                      (if (immediate-tn-p tn)
                          tn

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

Modified Files:
	package-data-list.lisp-expr version.lisp-expr 
Log Message:
1.0.24.40: fix regression from 1.0.24.37

 * TNs with KIND :CONSTANT don't have leaves if they represent load
   time values.

 * Reported by Attila Lendvai.


Index: package-data-list.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/package-data-list.lisp-expr,v
retrieving revision 1.483
retrieving revision 1.484
diff -u -d -r1.483 -r1.484
--- package-data-list.lisp-expr	12 Jan 2009 15:00:21 -0000	1.483
+++ package-data-list.lisp-expr	12 Jan 2009 16:20:37 -0000	1.484
@@ -276,7 +276,9 @@
                "GET-VECTOR-SUBTYPE"
                "GET-TOPLEVELISH-FILE-INFO"
                "HALT"
-               "IF-EQ" "INLINE-SYNTACTIC-CLOSURE-LAMBDA"
+               "IF-EQ"
+               "IMMEDIATE-TN-P"
+               "INLINE-SYNTACTIC-CLOSURE-LAMBDA"
                "INSERT-STEP-CONDITIONS"
                "IR2-COMPONENT-CONSTANTS" "IR2-CONVERT"
                "IR2-PHYSENV-NUMBER-STACK-P"

Index: version.lisp-expr
===================================================================
RCS file: /cvsroot/sbcl/sbcl/version.lisp-expr,v
retrieving revision 1.4276
retrieving revision 1.4277
diff -u -d -r1.4276 -r1.4277
--- version.lisp-expr	12 Jan 2009 15:00:21 -0000	1.4276
+++ version.lisp-expr	12 Jan 2009 16:20:37 -0000	1.4277
@@ -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.24.39"
+"1.0.24.40"

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

Modified Files:
	pred.lisp 
Log Message:
1.0.24.40: fix regression from 1.0.24.37

 * TNs with KIND :CONSTANT don't have leaves if they represent load
   time values.

 * Reported by Attila Lendvai.


Index: pred.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/pred.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- pred.lisp	11 Jan 2009 18:39:08 -0000	1.5
+++ pred.lisp	12 Jan 2009 16:20:37 -0000	1.6
@@ -103,10 +103,6 @@
         (let ((scn (sc-number-or-lose representation)))
           (labels ((make-tn ()
                      (make-representation-tn ptype scn))
-                   (immediate-tn-p (tn)
-                     (and (eq (sb!c::tn-kind tn) :constant)
-                          (eq (sb!c::immediate-constant-sc (tn-value tn))
-                              (sc-number-or-lose 'immediate))))
                    (frob-tn (tn)
                      (if (immediate-tn-p tn)
                          tn