merged three Alexey Dejneka sbcl-devel patches..
.."bug 49-b*" 2001-09-30
.."bug 81" 2001-09-30
.."compiler/interpreter disagreement" 2001-10-02
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
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
** 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
specified-type required-type)))
specified-type)))
\f
+(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*)
(t
'let))
,vars
- ,@(if crocks
- `((destructuring-bind ,@crocks
- ,@forms))
- forms)))))))
+ ,@(loop-build-destructuring-bindings crocks
+ forms)))))))
answer)))
(defun loop-iteration-driver ()
(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))
'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*
'(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*)))))
\f
;;;; debuggers' little helpers
(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
--- /dev/null
+;;;; 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)
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))))
;;; 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"
projects / sbcl.git / commitdiff