(DECLARE (TYPE (SIMPLE-ARRAY SINGLE-FLOAT) X))
..))
..)
- is redundant. However, it doesn't. As a quick fix to work around
- the problem, sbcl-0.6.8.10 was patched to automatically add the
- appropriate declarations in the macroexpansion of TYPECASE and
- related macros (thanks to Martin Atzmueller porting Juan Jose
- Garcia Ripoll's CMU CL patch). But the underlying compiler problem
- really should be fixed instead, and at that time the workarounds
- in the TYPECASE-ish expansions should be removed.
+ is redundant. However, as reported by Juan Jose Garcia Ripoll for
+ CMU CL, it sometimes doesn't. Adding declarations is a pretty good
+ workaround for the problem for now, but can't be done by the TYPECASE
+ macros themselves, since it's too hard for the macro to detect
+ assignments to the variable within the clause.
+ Note: The compiler *is* smart enough to do the type inference in
+ many cases. This case, derived from a couple of MACROEXPAND-1
+ calls on Ripoll's original test case,
+ (DEFUN NEGMAT (A)
+ (DECLARE (OPTIMIZE SPEED (SAFETY 0)))
+ (COND ((TYPEP A '(SIMPLE-ARRAY SINGLE-FLOAT)) NIL
+ (LET ((LENGTH (ARRAY-TOTAL-SIZE A)))
+ (LET ((I 0) (G2554 LENGTH))
+ (DECLARE (TYPE REAL G2554) (TYPE REAL I))
+ (TAGBODY
+ SB-LOOP::NEXT-LOOP
+ (WHEN (>= I G2554) (GO SB-LOOP::END-LOOP))
+ (SETF (ROW-MAJOR-AREF A I) (- (ROW-MAJOR-AREF A I)))
+ (GO SB-LOOP::NEXT-LOOP)
+ SB-LOOP::END-LOOP))))))
+ demonstrates the problem; but the problem goes away if the TAGBODY
+ and GO forms are removed (leaving the SETF in ordinary, non-looping
+ code), or if the TAGBODY and GO forms are retained, but the
+ assigned value becomes 0.0 instead of (- (ROW-MAJOR-AREF A I)).
+
KNOWN BUGS RELATED TO THE IR1 INTERPRETER
(eval-when (:compile-toplevel :load-toplevel :execute)
-;;; CASE-BODY (interface)
-;;;
-;;; CASE-BODY returns code for all the standard "case" macros. Name is
-;;; the macro name, and keyform is the thing to case on. Multi-p
+;;; CASE-BODY returns code for all the standard "case" macros. NAME is
+;;; the macro name, and KEYFORM is the thing to case on. MULTI-P
;;; indicates whether a branch may fire off a list of keys; otherwise,
;;; a key that is a list is interpreted in some way as a single key.
-;;; When multi-p, test is applied to the value of keyform and each key
-;;; for a given branch; otherwise, test is applied to the value of
-;;; keyform and the entire first element, instead of each part, of the
-;;; case branch. When errorp, no t or otherwise branch is permitted,
-;;; and an ERROR form is generated. When proceedp, it is an error to
-;;; omit errorp, and the ERROR form generated is executed within a
-;;; RESTART-CASE allowing keyform to be set and retested.
+;;; When MULTI-P, TEST is applied to the value of KEYFORM and each key
+;;; for a given branch; otherwise, TEST is applied to the value of
+;;; KEYFORM and the entire first element, instead of each part, of the
+;;; case branch. When ERRORP, no T or OTHERWISE branch is permitted,
+;;; and an ERROR form is generated. When PROCEEDP, it is an error to
+;;; omit ERRORP, and the ERROR form generated is executed within a
+;;; RESTART-CASE allowing KEYFORM to be set and retested.
(defun case-body (name keyform cases multi-p test errorp proceedp needcasesp)
(unless (or cases (not needcasesp))
(warn "no clauses in ~S" name))
(clauses ())
(keys ()))
(dolist (case cases)
- (cond ((atom case)
- (error "~S -- Bad clause in ~S." case name))
- ((memq (car case) '(t otherwise))
- (if errorp
- (error 'simple-program-error
- :format-control "No default clause is allowed in ~S: ~S"
- :format-arguments (list name case))
- (push `(t nil ,@(rest case)) clauses)))
- ((and multi-p (listp (first case)))
- (setf keys (append (first case) keys))
- (push `((or ,@(mapcar #'(lambda (key)
+ (unless (list-of-length-at-least-p case 1)
+ (error "~S -- bad clause in ~S" case name))
+ (destructuring-bind (keyoid &rest forms) case
+ (cond ((memq keyoid '(t otherwise))
+ (if errorp
+ (error 'simple-program-error
+ :format-control
+ "No default clause is allowed in ~S: ~S"
+ :format-arguments (list name case))
+ (push `(t nil ,@forms) clauses)))
+ ((and multi-p (listp keyoid))
+ (setf keys (append keyoid keys))
+ (push `((or ,@(mapcar (lambda (key)
`(,test ,keyform-value ',key))
- (first case)))
- nil ,@(rest case))
- clauses))
- (t
- (push (first case) keys)
- (push `((,test ,keyform-value
- ',(first case)) nil ,@(rest case)) clauses))))
+ keyoid))
+ nil
+ ,@forms)
+ clauses))
+ (t
+ (push keyoid keys)
+ (push `((,test ,keyform-value ',keyoid)
+ nil
+ ,@forms)
+ clauses)))))
(case-body-aux name keyform keyform-value clauses keys errorp proceedp
`(,(if multi-p 'member 'or) ,@keys))))
-
-;;; MNA: typecase-implicit-declarations patch
-
-;;; TYPECASE-BODY (interface)
-;;;
-;;; TYPECASE-BODY returns code for all the standard "typecase" macros.
-;;; Name is the macro name, and keyform is the thing to case on.
-;;; test is applied to the value of keyform and the entire first element,
-;;; instead of each part, of the case branch.
-;;; When errorp, no t or otherwise branch is permitted,
-;;; and an ERROR form is generated. When proceedp, it is an error to
-;;; omit errorp, and the ERROR form generated is executed within a
-;;; RESTART-CASE allowing keyform to be set and retested.
-(defun typecase-body (name keyform cases test errorp proceedp needcasesp)
- (unless (or cases (not needcasesp))
- (warn "no clauses in ~S" name))
- (let* ((keyform-symbol-p (symbolp keyform))
- (keyform-value (unless keyform-symbol-p
- (gensym)))
- (clauses ())
- (keys ()))
- (dolist (case cases)
- (cond ((atom case)
- (error "~S -- Bad clause in ~S." case name))
- ((memq (car case) '(t otherwise))
- (if errorp
- (error 'simple-program-error
- :format-control "No default clause is allowed in ~S: ~S"
- :format-arguments (list name case))
- (push `(t nil ,@(rest case)) clauses)))
- (t
- (push (first case) keys)
- (push (if keyform-symbol-p
- `((,test ,keyform ',(first case)) nil
- (locally
- ;; this will cause a compiler-warning ... disabled
- ;; for now.
- ;; (declare (type ,(first case) ,keyform))
- ,@(rest case)))
- `((,test ,keyform-value ',(first case)) nil
- ,@(rest case)))
- clauses))))
- (if keyform-symbol-p
- (typecase-symbol-body-aux name keyform clauses keys errorp proceedp
- (cons 'or keys))
- (case-body-aux name keyform keyform-value clauses keys errorp proceedp
- (cons 'or keys)))))
-
-;;; TYPECASE-SYMBOL-BODY-AUX provides the expansion once CASE-BODY has groveled
-;;; all the cases, iff keyform is a symbol.
-(defun typecase-symbol-body-aux (name keyform clauses keys
- errorp proceedp expected-type)
- (if proceedp
- (let ((block (gensym))
- (again (gensym)))
- `(block ,block
- (tagbody
- ,again
- (return-from
- ,block
- (cond ,@(nreverse clauses)
- (t
- (setf ,keyform
- (case-body-error
- ',name ',keyform ,keyform
- ',expected-type ',keys)))
- (go ,again))))))
- `(progn
- (cond
- ,@(nreverse clauses)
- ,@(if errorp
- `((t (error 'sb!conditions::case-failure
- :name ',name
- :datum ,keyform
- :expected-type ',expected-type
- :possibilities ',keys))))))))
-
;;; CASE-BODY-AUX provides the expansion once CASE-BODY has groveled
;;; all the cases. Note: it is not necessary that the resulting code
;;; signal case-failure conditions, but that's what KMP's prototype
"TYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
is true."
- (typecase-body 'typecase keyform cases 'typep nil nil nil))
+ (case-body 'typecase keyform cases nil 'typep nil nil nil))
(defmacro-mundanely ctypecase (keyform &body cases)
#!+sb-doc
"CTYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
is true. If no form is satisfied then a correctable error is signalled."
- (typecase-body 'ctypecase keyform cases 'typep t t t))
+ (case-body 'ctypecase keyform cases nil 'typep t t t))
(defmacro-mundanely etypecase (keyform &body cases)
#!+sb-doc
"ETYPECASE Keyform {(Type Form*)}*
Evaluates the Forms in the first clause for which TYPEP of Keyform and Type
is true. If no form is satisfied then an error is signalled."
- (typecase-body 'etypecase keyform cases 'typep t nil t))
+ (case-body 'etypecase keyform cases nil 'typep t nil t))
\f
;;;; WITH-FOO i/o-related macros
(declare (type (simple-array ,element-type-specifier 1) array))
(data-vector-ref array index)))))
-;;; MNA: open-coded-simple-array patch
(deftransform data-vector-ref ((array index)
(simple-array t))
(let ((array-type (continuation-type array)))
- ;; FIXME: How could this happen? Doesn't the limitation to arg
- ;; type SIMPLE-ARRAY guarantee that ARRAY-TYPE is an ARRAY-TYPE?
(unless (array-type-p array-type)
(give-up-ir1-transform))
(let ((dims (array-type-dimensions array-type)))
- (when (and (consp dims) (= (length dims) 1))
+ (when (or (atom dims) (= (length dims) 1))
(give-up-ir1-transform))
- (let* ((el-type (array-type-element-type array-type))
- (total-size (if (or (atom dims) (member '* dims))
- '*
- (reduce #'* dims)))
- (type-sp `(simple-array ,(type-specifier el-type)
- (,total-size))))
- (if (atom dims)
- `(let ((a (truly-the ,type-sp (%array-simp array))))
- (data-vector-ref a index))
- `(let ((a (truly-the ,type-sp (%array-data-vector array))))
- (data-vector-ref a index)))))))
+ (let ((el-type (array-type-element-type array-type))
+ (total-size (if (member '* dims)
+ '*
+ (reduce #'* dims))))
+ `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type)
+ (,total-size))
+ (%array-data-vector array))
+ index)))))
(deftransform hairy-data-vector-set ((array index new-value)
(array t t)
index
new-value)))))
-;;; MNA: open-coded-simple-array patch
(deftransform data-vector-set ((array index new-value)
- (simple-array t t))
+ (simple-array t t))
(let ((array-type (continuation-type array)))
- ;; FIXME: How could this happen? Doesn't the limitation to arg
- ;; type SIMPLE-ARRAY guarantee that ARRAY-TYPE is an ARRAY-TYPE?
(unless (array-type-p array-type)
(give-up-ir1-transform))
(let ((dims (array-type-dimensions array-type)))
- (when (and (consp dims) (= (length dims) 1))
- (give-up-ir1-transform))
- (let* ((el-type (array-type-element-type array-type))
- (total-size (if (or (atom dims) (member '* dims))
- '*
- (reduce #'* dims)))
- (type-sp `(simple-array ,(type-specifier el-type)
- (,total-size))))
- (if (atom dims)
- `(let ((a (truly-the ,type-sp (%array-simp array))))
- (data-vector-set a index new-value))
- `(let ((a (truly-the ,type-sp (%array-data-vector array))))
- (data-vector-set a index new-value)))))))
+ (when (or (atom dims) (= (length dims) 1))
+ (give-up-ir1-transform))
+ (let ((el-type (array-type-element-type array-type))
+ (total-size (if (member '* dims)
+ '*
+ (reduce #'* dims))))
+ `(data-vector-set (truly-the (simple-array ,(type-specifier el-type)
+ (,total-size))
+ (%array-data-vector array))
+ index
+ new-value)))))
;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8)
;;;
projects / sbcl.git / commitdiff