From 2d75f4246b8451a9c2c95cd36673d98c82c9845f Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Thu, 4 Oct 2001 22:16:54 +0000 Subject: [PATCH] 0.pre7.42: merged three Alexey Dejneka sbcl-devel patches.. .."bug 49-b*" 2001-09-30 .."bug 81" 2001-09-30 .."compiler/interpreter disagreement" 2001-10-02 --- BUGS | 20 -------------------- NEWS | 5 +++-- src/code/loop.lisp | 16 +++++++++++----- src/compiler/srctran.lisp | 16 +++++++++------- tests/compiler-1.impure-cload.lisp | 12 ++++++++++++ tests/loop.impure.lisp | 35 +++++++++++++++++++++++++++++++++++ tests/loop.pure.lisp | 7 +++++++ version.lisp-expr | 2 +- 8 files changed, 78 insertions(+), 35 deletions(-) create mode 100644 tests/loop.impure.lisp diff --git a/BUGS b/BUGS index 19edc1c..00127a1 100644 --- a/BUGS +++ b/BUGS @@ -387,15 +387,6 @@ WORKAROUND: c: SYMBOL-MACROLET should signal PROGRAM-ERROR if something it binds is declared SPECIAL inside. -49: - LOOP bugs reported by Peter Van Eynde July 25, 2000: - b: a messy one involving package iteration: -interpreted Form: (LET ((PACKAGE (MAKE-PACKAGE "LOOP-TEST"))) (INTERN "blah" PACKAGE) (LET ((BLAH2 (INTERN "blah2" PACKAGE))) (EXPORT BLAH2 PACKAGE)) (LIST (SORT (LOOP FOR SYM BEING EACH PRESENT-SYMBOL OF PACKAGE FOR SYM-NAME = (SYMBOL-NAME SYM) COLLECT SYM-NAME) (FUNCTION STRING<)) (SORT (LOOP FOR SYM BEING EACH EXTERNAL-SYMBOL OF PACKAGE FOR SYM-NAME = (SYMBOL-NAME SYM) COLLECT SYM-NAME) (FUNCTION STRING<)))) -Should be: (("blah" "blah2") ("blah2")) -SBCL: (("blah") ("blah2")) - * (LET ((X 1)) (LOOP FOR I BY (INCF X) FROM X TO 10 COLLECT I)) - doesn't work -- SBCL's LOOP says BY isn't allowed in a FOR clause. - 50: type system errors reported by Peter Van Eynde July 25, 2000: a: (SUBTYPEP 'BIGNUM 'INTEGER) => NIL, NIL @@ -706,17 +697,6 @@ Error in function C::GET-LAMBDA-TO-COMPILE: 80: (fixed early Feb 2001 by MNA) -81: - As reported by wbuss@TELDA.NET (Wolfhard Buss) on cmucl-help - 2001-02-14, - According to CLHS - (loop with (a . b) of-type float = '(0.0 . 1.0) - and (c . d) of-type float = '(2.0 . 3.0) - return (list a b c d)) - should evaluate to (0.0 1.0 2.0 3.0). cmucl-18c disagrees and - invokes the debugger: "B is not of type list". - SBCL does the same thing. - 82: Functions are assigned names based on the context in which they're defined. This is less than ideal for the functions which are diff --git a/NEWS b/NEWS index 8cba07a..f8973bc 100644 --- a/NEWS +++ b/NEWS @@ -890,8 +890,9 @@ changes in sbcl-0.7.0 relative to sbcl-0.6.13: ** bogus entries in BUGS ** DIRECTORY when similar filenames are present ** DEFGENERIC with :METHOD options - ** problem with (MAKE-STRING N :INITIAL-ELEMENT #\SPACE)) - ?? bugs 49b and 81 + ** bug 126, in (MAKE-STRING N :INITIAL-ELEMENT #\SPACE)) + ** bug in the optimization of ARRAY-ELEMENT-TYPE + ** LOOP bugs 49b and 81 ?? Old operator names in the style DEF-FOO are now deprecated in favor of new corresponding names DEFINE-FOO, for consistency with the naming convention used in the ANSI standard). This mostly affects diff --git a/src/code/loop.lisp b/src/code/loop.lisp index 1df85e1..ff657b4 100644 --- a/src/code/loop.lisp +++ b/src/code/loop.lisp @@ -770,6 +770,12 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. specified-type required-type))) specified-type))) +(defun loop-build-destructuring-bindings (crocks forms) + (if crocks + `((destructuring-bind ,(car crocks) ,(cadr crocks) + ,@(loop-build-destructuring-bindings (cddr crocks) forms))) + forms)) + (defun loop-translate (*loop-source-code* *loop-macro-environment* *loop-universe*) @@ -824,10 +830,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (t 'let)) ,vars - ,@(if crocks - `((destructuring-bind ,@crocks - ,@forms)) - forms))))))) + ,@(loop-build-destructuring-bindings crocks + forms))))))) answer))) (defun loop-iteration-driver () @@ -1906,6 +1910,7 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. (below (loop-for-arithmetic :below)) (to (loop-for-arithmetic :to)) (upto (loop-for-arithmetic :upto)) + (by (loop-for-arithmetic :by)) (being (loop-for-being))) :iteration-keywords '((for (loop-do-for)) (as (loop-do-for)) @@ -1944,7 +1949,8 @@ a LET-like macro, and a SETQ-like macro, which perform LOOP-style destructuring. 'loop-package-symbols-iteration-path w :preposition-groups '((:of :in)) :inclusive-permitted nil - :user-data '(:symbol-types (:internal))) + :user-data '(:symbol-types (:internal + :external))) w)) (defparameter *loop-ansi-universe* diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 9df0d78..35b35b1 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -3307,21 +3307,23 @@ '(eql nil) `(cons (eql ,(car list)) ,(consify (rest list))))) (get-element-type (a) - (let ((element-type (type-specifier - (array-type-specialized-element-type a)))) - (cond ((symbolp element-type) + (let ((element-type + (type-specifier (array-type-specialized-element-type a)))) + (cond ((eq element-type '*) + (specifier-type 'type-specifier)) + ((symbolp element-type) (make-member-type :members (list element-type))) ((consp element-type) (specifier-type (consify element-type))) (t (error "can't understand type ~S~%" element-type)))))) (cond ((array-type-p array-type) - (get-element-type array-type)) - ((union-type-p array-type) + (get-element-type array-type)) + ((union-type-p array-type) (apply #'type-union (mapcar #'get-element-type (union-type-types array-type)))) - (t - *universal-type*))))) + (t + *universal-type*))))) ;;;; debuggers' little helpers diff --git a/tests/compiler-1.impure-cload.lisp b/tests/compiler-1.impure-cload.lisp index 2082d0f..75484ce 100644 --- a/tests/compiler-1.impure-cload.lisp +++ b/tests/compiler-1.impure-cload.lisp @@ -100,4 +100,16 @@ (assert (eql (bar "this is a test") :string)) (assert (eql (bar (make-hash-table)) :t)) +;;; bug reported by Brian Spilsbury sbcl-devel 2001-09-30, fixed by +;;; Alexey Dejneka patch sbcl-devel 2001-10-02 +(defun pixarray-element-size (pixarray) + (let ((eltype (array-element-type pixarray))) + (cond ((eq eltype 'bit) 1) + ((and (listp eltype) + (eq (first eltype) 'unsigned-byte)) + (second eltype)) + (t + (error "Invalid pixarray: ~S." pixarray))))) +(assert (eql 1 (pixarray-element-size #*110))) + (sb-ext:quit :unix-status 104) ; success diff --git a/tests/loop.impure.lisp b/tests/loop.impure.lisp new file mode 100644 index 0000000..1440165 --- /dev/null +++ b/tests/loop.impure.lisp @@ -0,0 +1,35 @@ +;;;; miscellaneous tests of LOOP-related stuff + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package "CL-USER") + +;;; Bug 49b, reported by Peter Van Eynde 2000-07-25, was fixed by +;;; Alexey Dejneka's patch on sbcl-devel 2001-09-30. +;;; +;;; (This test is impure because we create a scratch package to work with.) +(let ((package (make-package "loop-test-scratch"))) + (intern "blah" package) + (let ((blah2 (intern "blah2" package))) + (export blah2 package)) + (assert (equal '("blah" "blah2") + (sort (loop for sym being each present-symbol of package + for sym-name = (symbol-name sym) + collect sym-name) + #'string<))) + (assert (equal '("blah2") + (sort (loop for sym being each external-symbol of package for + sym-name = (symbol-name sym) collect sym-name) + (function string<))))) + +;;; success +(quit :unix-status 104) diff --git a/tests/loop.pure.lisp b/tests/loop.pure.lisp index 4aa64ab..46a38e8 100644 --- a/tests/loop.pure.lisp +++ b/tests/loop.pure.lisp @@ -22,3 +22,10 @@ collect key) #'string<)) '(key1 key2))) + +;;; Bug 81, reported by Wolfhard Buss on cmucl-help 2001-02-14, was +;;; fixed by Alexey Dejneka's patch on sbcl-devel 2001-09-30. +(assert (equal '(0.0 1.0 2.0 3.0) + (loop with (a . b) of-type float = '(0.0 . 1.0) + and (c . d) of-type float = '(2.0 . 3.0) + return (list a b c d)))) diff --git a/version.lisp-expr b/version.lisp-expr index ff4ecc1..b89c5a1 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; for internal versions, especially for internal versions off the ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.pre7.41" +"0.pre7.42" -- 1.7.10.4