0.7.11.10:

        Fixed some bugs revealed by Paul Dietz' test suite:
        ** BOA constructor with &AUX argument without a default value does
           not cause a type error;
        ** CONSTANTP now returns true for all self-evaluating objects.

diff --git a/BUGS b/BUGS
index 8d0ae41..c9216c7 100644 (file)
--- a/BUGS
+++ b/BUGS
@@ -43,6 +43,7 @@ KNOWN BUGS OF NO SPECIAL CLASS:
   SBCL to wager that this (undefined in ANSI) operation would be safe.
 
 3:
   SBCL to wager that this (undefined in ANSI) operation would be safe.
 
 3:

+  a:

   ANSI specifies that a type mismatch in a structure slot
   initialization value should not cause a warning.
 WORKAROUND:
   ANSI specifies that a type mismatch in a structure slot
   initialization value should not cause a warning.
 WORKAROUND:

@@ -78,6 +79,11 @@ WORKAROUND:
   Such code should compile without complaint and work correctly either
   on SBCL or on any other completely compliant Common Lisp system.
 
   Such code should compile without complaint and work correctly either
   on SBCL or on any other completely compliant Common Lisp system.
 

+  b: &AUX argument in a boa-constructor without a default value means
+     "do not initilize this slot" and does not cause type error. But
+     an error may be signalled at read time and it would be good if
+     SBCL did it.
+

 6:
   bogus warnings about undefined functions for magic functions like
   SB!C::%%DEFUN and SB!C::%DEFCONSTANT when cross-compiling files
 6:
   bogus warnings about undefined functions for magic functions like
   SB!C::%%DEFUN and SB!C::%DEFCONSTANT when cross-compiling files

@@ -910,6 +916,11 @@ WORKAROUND:
 
      (see bug 203)
 
 
      (see bug 203)
 

+  c. (defun foo (x y)
+       (locally (declare (type fixnum x y))
+         (+ x (* 2 y))))
+     (foo 1.1 2) => 5.1
+

 194: "no error from (THE REAL '(1 2 3)) in some cases"
   fixed parts:
     a. In sbcl-0.7.7.9, 
 194: "no error from (THE REAL '(1 2 3)) in some cases"
   fixed parts:
     a. In sbcl-0.7.7.9, 

diff --git a/NEWS b/NEWS
index 80a1c63..755c12e 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -1494,9 +1494,12 @@ changes in sbcl-0.7.12 relative to sbcl-0.7.11:
   * fixed bug 62: constraints were not propagated into a loop.
   * fixed bug in embedded calls of SORT (reported and investigated by
     Wolfgang Jenkner).
   * fixed bug 62: constraints were not propagated into a loop.
   * fixed bug in embedded calls of SORT (reported and investigated by
     Wolfgang Jenkner).

-  * fixed bugs identified by Paul F. Dietz related to printing and
-    reading of arrays with some dimensions having length 0.  (thanks
-    to Gerd Moellmann)
+  * fixed some bugs revealed by Paul Dietz' test suite:
+    ** printing and reading of arrays with some dimensions having
+       length 0 (thanks to Gerd Moellmann);
+    ** BOA constructor with &AUX argument without a default value does
+       not cause a type error;
+    ** CONSTANTP now returns true for all self-evaluating objects.

 
 planned incompatible changes in 0.7.x:
   * (not done yet, but planned:) When the profiling interface settles
 
 planned incompatible changes in 0.7.x:
   * (not done yet, but planned:) When the profiling interface settles

diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS
index 7f45bee..c3c07e8 100644 (file)
--- a/OPTIMIZATIONS
+++ b/OPTIMIZATIONS
@@ -42,9 +42,6 @@
     (length v)))
 
 * IR1 does not optimize away (MAKE-LIST N).
     (length v)))
 
 * IR1 does not optimize away (MAKE-LIST N).

-
-* IR1 thinks that the type of V in (LENGTH V) is (OR LIST SIMPLE-VECTOR), not
-  SIMPLE-VECTOR.

 --------------------------------------------------------------------------------
 (defun bar (v1 v2)
   (declare (optimize (speed 3) (safety 0) (space 2))
 --------------------------------------------------------------------------------
 (defun bar (v1 v2)
   (declare (optimize (speed 3) (safety 0) (space 2))

@@ -96,3 +93,45 @@ uses generic arithmetic
                 (incf x)))))))
    (format t "~A~%" x)))
 --------------------------------------------------------------------------------
                 (incf x)))))))
    (format t "~A~%" x)))
 --------------------------------------------------------------------------------

+(defun foo (x)
+  (declare (optimize speed (debug 0)))
+  (if (< x 0) x (foo (1- x))))
+
+SBCL generates a full call of FOO (but CMUCL does not).
+--------------------------------------------------------------------------------
+(defun foo (d)
+  (declare (optimize (speed 3) (safety 0) (debug 0)))
+  (declare (type (double-float 0d0 1d0) d))
+  (loop for i fixnum from 1 to 5
+     for x1 double-float = (sin d) ;;; !!!
+     do (loop for j fixnum from 1 to 4
+             sum x1 double-float)))
+
+Without the marked declaration Python will use boxed representation for X1.
+
+This is equivalent to
+
+(let ((x nil))
+  (setq x 0d0)
+  ;; use of X as DOUBLE-FLOAT
+)
+
+The initial binding is effectless, and without it X is of type
+DOUBLE-FLOAT. Unhopefully, IR1 does not optimize away effectless
+SETs/bindings, and IR2 does not perform type inference.
+--------------------------------------------------------------------------------
+(defun foo (x)
+  (if (= (cond ((irgh x) 0)
+               ((buh x) 1)
+               (t 2))
+         0)
+      :yes
+      :no))
+
+This code could be optimized to
+
+(defun foo (x)
+  (cond ((irgh x) :yes)
+        ((buh x) :no)
+        (t :no)))
+--------------------------------------------------------------------------------

diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp
index e532791..01ed4b2 100644 (file)
--- a/src/code/defstruct.lisp
+++ b/src/code/defstruct.lisp
@@ -1239,7 +1239,7 @@
 ;;;     structures can have arbitrary subtypes of VECTOR, not necessarily
 ;;;     SIMPLE-VECTOR.)
 ;;;   * STRUCTURE structures can have raw slots that must also be
 ;;;     structures can have arbitrary subtypes of VECTOR, not necessarily
 ;;;     SIMPLE-VECTOR.)
 ;;;   * STRUCTURE structures can have raw slots that must also be

-;;;     allocated and indirectly referenced. 
+;;;     allocated and indirectly referenced.

 (defun create-vector-constructor (dd cons-name arglist vars types values)
   (let ((temp (gensym))
        (etype (dd-element-type dd)))
 (defun create-vector-constructor (dd cons-name arglist vars types values)
   (let ((temp (gensym))
        (etype (dd-element-type dd)))

@@ -1252,7 +1252,8 @@
                     `(setf (aref ,temp ,(cdr x))  ',(car x)))
                   (find-name-indices dd))
         ,@(mapcar (lambda (dsd value)
                     `(setf (aref ,temp ,(cdr x))  ',(car x)))
                   (find-name-indices dd))
         ,@(mapcar (lambda (dsd value)

-                    `(setf (aref ,temp ,(dsd-index dsd)) ,value))
+                    (unless (eq value '.do-not-initialize-slot.)
+                         `(setf (aref ,temp ,(dsd-index dsd)) ,value)))

                   (dd-slots dd) values)
         ,temp))))
 (defun create-list-constructor (dd cons-name arglist vars types values)
                   (dd-slots dd) values)
         ,temp))))
 (defun create-list-constructor (dd cons-name arglist vars types values)

@@ -1260,7 +1261,8 @@
     (dolist (x (find-name-indices dd))
       (setf (elt vals (cdr x)) `',(car x)))
     (loop for dsd in (dd-slots dd) and val in values do
     (dolist (x (find-name-indices dd))
       (setf (elt vals (cdr x)) `',(car x)))
     (loop for dsd in (dd-slots dd) and val in values do

-      (setf (elt vals (dsd-index dsd)) val))
+      (setf (elt vals (dsd-index dsd))
+            (if (eq val '.do-not-initialize-slot.) 0 val)))

 
     `(defun ,cons-name ,arglist
        (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))
 
     `(defun ,cons-name ,arglist
        (declare ,@(mapcar (lambda (var type) `(type ,type ,var)) vars types))

@@ -1284,7 +1286,8 @@
                     ;; because the slot might be :READ-ONLY, so we
                     ;; whip up new LAMBDA representations of slot
                     ;; setters for the occasion.)
                     ;; because the slot might be :READ-ONLY, so we
                     ;; whip up new LAMBDA representations of slot
                     ;; setters for the occasion.)

-                    `(,(slot-setter-lambda-form dd dsd) ,value ,instance))
+                     (unless (eq value '.do-not-initialize-slot.)
+                       `(,(slot-setter-lambda-form dd dsd) ,value ,instance)))

                   (dd-slots dd)
                   values)
         ,instance))))
                   (dd-slots dd)
                   values)
         ,instance))))

@@ -1313,7 +1316,8 @@
       (parse-lambda-list (second boa))
     (collect ((arglist)
              (vars)
       (parse-lambda-list (second boa))
     (collect ((arglist)
              (vars)

-             (types))
+             (types)
+              (skipped-vars))

       (labels ((get-slot (name)
                 (let ((res (find name (dd-slots defstruct)
                                  :test #'string=
       (labels ((get-slot (name)
                 (let ((res (find name (dd-slots defstruct)
                                  :test #'string=

@@ -1330,7 +1334,7 @@
          (arglist arg)
          (vars arg)
          (types (get-slot arg)))
          (arglist arg)
          (vars arg)
          (types (get-slot arg)))

-       
+

        (when opt
          (arglist '&optional)
          (dolist (arg opt)
        (when opt
          (arglist '&optional)
          (dolist (arg opt)

@@ -1383,18 +1387,21 @@
        (when auxp
          (arglist '&aux)
          (dolist (arg aux)
        (when auxp
          (arglist '&aux)
          (dolist (arg aux)

-           (let* ((arg (if (consp arg) arg (list arg)))
-                  (var (first arg)))
-             (arglist arg)
-             (vars var)
-             (types (get-slot var))))))
+            (arglist arg)
+            (if (proper-list-of-length-p arg 2)
+              (let ((var (first arg)))
+                (vars var)
+                (types (get-slot var)))
+              (skipped-vars (if (consp arg) (first arg) arg))))))

 
       (funcall creator defstruct (first boa)
               (arglist) (vars) (types)
 
       (funcall creator defstruct (first boa)
               (arglist) (vars) (types)

-              (mapcar (lambda (slot)
-                        (or (find (dsd-name slot) (vars) :test #'string=)
-                            (dsd-default slot)))
-                      (dd-slots defstruct))))))
+               (loop for slot in (dd-slots defstruct)
+                     for name = (dsd-name slot)
+                     collect (if (find name (skipped-vars) :test #'string=)
+                                 '.do-not-initialize-slot.
+                                 (or (find (dsd-name slot) (vars) :test #'string=)
+                                     (dsd-default slot))))))))

 
 ;;; Grovel the constructor options, and decide what constructors (if
 ;;; any) to create.
 
 ;;; Grovel the constructor options, and decide what constructors (if
 ;;; any) to create.

diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp
index 07ffdd6..18ff9b5 100644 (file)
--- a/src/compiler/info-functions.lisp
+++ b/src/compiler/info-functions.lisp
@@ -127,22 +127,17 @@
   #!+sb-doc
   "True of any Lisp object that has a constant value: types that eval to
   themselves, keywords, constants, and list whose car is QUOTE."
   #!+sb-doc
   "True of any Lisp object that has a constant value: types that eval to
   themselves, keywords, constants, and list whose car is QUOTE."

-  ;; FIXME: Should STRUCTURE-OBJECT and/or STANDARD-OBJECT be here?
-  ;; They eval to themselves..
-  ;;

   ;; FIXME: Someday it would be nice to make the code recognize foldable
   ;; functions and call itself recursively on their arguments, so that
   ;; more of the examples in the ANSI CL definition are recognized.
   ;; (e.g. (+ 3 2), (SQRT PI), and (LENGTH '(A B C)))
   (declare (ignore environment))
   (typecase object
   ;; FIXME: Someday it would be nice to make the code recognize foldable
   ;; functions and call itself recursively on their arguments, so that
   ;; more of the examples in the ANSI CL definition are recognized.
   ;; (e.g. (+ 3 2), (SQRT PI), and (LENGTH '(A B C)))
   (declare (ignore environment))
   (typecase object

-    (number t)
-    (character t)
-    (array t)

     ;; (Note that the following test on INFO catches KEYWORDs as well as
     ;; explicitly DEFCONSTANT symbols.)
     (symbol (eq (info :variable :kind object) :constant))
     ;; (Note that the following test on INFO catches KEYWORDs as well as
     ;; explicitly DEFCONSTANT symbols.)
     (symbol (eq (info :variable :kind object) :constant))

-    (list (eq (car object) 'quote))))
+    (list (eq (car object) 'quote))
+    (t t)))

 
 (declaim (ftype (function (symbol &optional (or null sb!c::lexenv))) sb!xc:macro-function))
 (defun sb!xc:macro-function (symbol &optional env)
 
 (declaim (ftype (function (symbol &optional (or null sb!c::lexenv))) sb!xc:macro-function))
 (defun sb!xc:macro-function (symbol &optional env)

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index e16d8d6..620d285 100644 (file)
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -996,7 +996,7 @@
   ;; From the user's point of view, LET-converting something that
   ;; has a name is inlining it. (The user can't see what we're doing
   ;; with anonymous things, and suppressing inlining
   ;; From the user's point of view, LET-converting something that
   ;; has a name is inlining it. (The user can't see what we're doing
   ;; with anonymous things, and suppressing inlining

-  ;; for such things can easily give Python acute indigestion, so 
+  ;; for such things can easily give Python acute indigestion, so

   ;; we don't.)
   (when (leaf-has-source-name-p clambda)
     ;; ANSI requires that explicit NOTINLINE be respected.
   ;; we don't.)
   (when (leaf-has-source-name-p clambda)
     ;; ANSI requires that explicit NOTINLINE be respected.

diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp
index 0582be5..3fe5c5e 100644 (file)
--- a/tests/defstruct.impure.lisp
+++ b/tests/defstruct.impure.lisp
@@ -23,6 +23,19 @@
 (assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
                       type-error))
 
 (assert (raises-error? (setf (person-name (make-person :name "Q")) 1)
                       type-error))
 

+;;; An &AUX variable in a boa-constructor without a default value
+;;; means "do not initialize slot" and does not cause type error
+(defstruct (boa-saux (:constructor make-boa-saux (&aux a (b 3) (c))))
+  (a #\! :type (integer 1 2))
+  (b #\? :type (integer 3 4))
+  (c #\# :type (integer 5 6)))
+(let ((s (make-boa-saux)))
+  (setf (boa-saux-a s) 1)
+  (setf (boa-saux-c s) 5)
+  (assert (eql (boa-saux-a s) 1))
+  (assert (eql (boa-saux-b s) 3))
+  (assert (eql (boa-saux-c s) 5)))
+

 ;;; basic inheritance
 (defstruct (astronaut (:include person)
                      (:conc-name astro-))
 ;;; basic inheritance
 (defstruct (astronaut (:include person)
                      (:conc-name astro-))

@@ -40,7 +53,7 @@
 
 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
 (defstruct (binop (:type list) :named (:initial-offset 2))
 
 ;;; interaction of :TYPE and :INCLUDE and :INITIAL-OFFSET
 (defstruct (binop (:type list) :named (:initial-offset 2))

-  (operator '? :type symbol)   
+  (operator '? :type symbol)

   operand-1
   operand-2)
 (defstruct (annotated-binop (:type list)
   operand-1
   operand-2)
 (defstruct (annotated-binop (:type list)

diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp
index 9b8a0b6..f7803ff 100644 (file)
--- a/tests/eval.impure.lisp
+++ b/tests/eval.impure.lisp
@@ -91,8 +91,12 @@
 (symbol-macrolet ((foo (symbol-macrolet-bar 1)))
   (defmacro symbol-macrolet-bar (x) `(+ ,x 1))
   (assert (= foo 2)))
 (symbol-macrolet ((foo (symbol-macrolet-bar 1)))
   (defmacro symbol-macrolet-bar (x) `(+ ,x 1))
   (assert (= foo 2)))

+
+;;; Bug reported by Paul Dietz: CONSTANTP on a self-evaluating object
+;;; must return T
+
+(assert (constantp (find-class 'symbol)))
+(assert (constantp #p""))

 \f
 ;;; success
 (sb-ext:quit :unix-status 104)
 \f
 ;;; success
 (sb-ext:quit :unix-status 104)

-
-    

diff --git a/version.lisp-expr b/version.lisp-expr
index 0a72f43..ce86c22 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 

-"0.7.11.9"
+"0.7.11.10"