double-float array access errors (speed 3) (safety 0) code

[xrme]

From Matt Kaufmann and J Moore:

Tested on current master; the behavior seems to go back to April 2019 at least.

; Without the following declaim form, there is no error.
; The errors even disappear if either the speed is 2 or the safety is 1.
(declaim (optimize (speed 3) (safety 0)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Array initialization
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defvar *a2x2*)
(defvar *b2x2*)
(defun init ()
  (setq *a2x2* (make-array (list 2 2)
                           :element-type 'double-float
                           :initial-contents '((1.0D0 2.0D0)
                                               (3.0D0 4.0D0))))
  (setq *b2x2* (make-array (list 2 2)
                           :element-type 'double-float
                           :initial-contents '((5.0D0 6.0D0)
                                               (7.0D0 8.0D0)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Test 1: Erroneous array value with incf
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun f1 (a b)
  (declare (type (array double-float (* *)) a b))
  (incf (aref a 0 0)
        (aref b 0 0)))

; BUG: The following call of f1 returns an array (but shouldn't)!
(init)
(f1 *a2x2* *b2x2*)

; But the bug goes away merely by calling PRINT:

(defun f1-print (a b)
  (declare (type (array double-float (* *)) a b))
  (incf (aref a 0 0)
        (print (aref b 0 0))))

(init)
(f1-print *a2x2* *b2x2*) ; returns scalars, as expected

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
; Test 2: Error (fault during read) for loop with setf
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun f2 (a b)
  (declare (type (array double-float (* *)) a b))
  (loop for j from 0 to 0 do
        (loop for k from 0 to 0 do
              (setf (aref a 0 j)
                    (aref b k j)))))

(init)
(f2 *a2x2* *b2x2*)
; ? (f2 *a2x2* *b2x2*)
; > Error: Fault during read of memory address #x13
; > While executing: F2, in process listener(1).
; > Type :POP to abort, :R for a list of available restarts.
; > Type :? for other options.
; 1 > 

(defun f2-print (a b)
  (declare (type (array double-float (* *)) a b))
  (loop for j from 0 to 0 do
        (loop for k from 0 to 0 do
              (setf (aref a 0 j)
                    (print (aref b k j))))))

(init)
(f2-print *a2x2* *b2x2*) ; no error

[xrme]

Fixed by #495