From e049902f5e7c30501d2dbb7a41d058a0c717fc1f Mon Sep 17 00:00:00 2001 From: Alexey Dejneka Date: Sun, 19 Jan 2003 09:40:15 +0000 Subject: [PATCH] 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. --- BUGS | 11 ++++++++++ NEWS | 9 +++++--- OPTIMIZATIONS | 45 +++++++++++++++++++++++++++++++++++++--- src/code/defstruct.lisp | 37 +++++++++++++++++++-------------- src/compiler/info-functions.lisp | 9 ++------ src/compiler/locall.lisp | 2 +- tests/defstruct.impure.lisp | 15 +++++++++++++- tests/eval.impure.lisp | 8 +++++-- version.lisp-expr | 2 +- 9 files changed, 105 insertions(+), 33 deletions(-) diff --git a/BUGS b/BUGS index 8d0ae414d..c9216c72b 100644 --- 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: + a: 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. + 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 @@ -910,6 +916,11 @@ WORKAROUND: (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, diff --git a/NEWS b/NEWS index 80a1c6374..755c12ea2 100644 --- 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 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 diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS index 7f45bee38..c3c07e83f 100644 --- a/OPTIMIZATIONS +++ b/OPTIMIZATIONS @@ -42,9 +42,6 @@ (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)) @@ -96,3 +93,45 @@ uses generic arithmetic (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 e5327913c..01ed4b24d 100644 --- 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 -;;; 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))) @@ -1252,7 +1252,8 @@ `(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) @@ -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 - (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)) @@ -1284,7 +1286,8 @@ ;; 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)))) @@ -1313,7 +1316,8 @@ (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= @@ -1330,7 +1334,7 @@ (arglist arg) (vars arg) (types (get-slot arg))) - + (when opt (arglist '&optional) (dolist (arg opt) @@ -1383,18 +1387,21 @@ (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) - (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. diff --git a/src/compiler/info-functions.lisp b/src/compiler/info-functions.lisp index 07ffdd600..18ff9b5a8 100644 --- 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." - ;; 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 - (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)) - (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) diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp index e16d8d60b..620d28540 100644 --- 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 - ;; 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. diff --git a/tests/defstruct.impure.lisp b/tests/defstruct.impure.lisp index 0582be520..3fe5c5ee8 100644 --- 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)) +;;; 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-)) @@ -40,7 +53,7 @@ ;;; 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) diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp index 9b8a0b6d2..f7803ffa5 100644 --- 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))) + +;;; Bug reported by Paul Dietz: CONSTANTP on a self-evaluating object +;;; must return T + +(assert (constantp (find-class 'symbol))) +(assert (constantp #p"")) ;;; success (sb-ext:quit :unix-status 104) - - diff --git a/version.lisp-expr b/version.lisp-expr index 0a72f43ce..ce86c22b1 100644 --- 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".) -"0.7.11.9" +"0.7.11.10" -- 2.11.4.GIT