[Openmcl-devel] ARRAY-%%TYPEP patch; fixing random memory faults

[Gilbert Baumann]

Hello,

please find a patch to CCL::ARRAY-%%TYPEP below. It would cause
memory faults at times as the dimension vector of an ARRAY-CTYPE is
read past where it is good.

This bug is hard to reproduce because more often than not there
actually is some memory mapped past this vector and because what is
read isn't even looked at.

--
Gilbert.

diff -wcr /Users/gilbert/ccl/ccl-1.12/level-1/l1-typesys.lisp ./ccl-1.12/level-1/l1-typesys.lisp
*** /Users/gilbert/ccl/ccl-1.12/level-1/l1-typesys.lisp	2020-04-19 23:32:56.000000000 +0200
--- ./ccl-1.12/level-1/l1-typesys.lisp	2023-02-11 01:03:19.000000000 +0100
***************
*** 3742,3778 ****
  (defun array-%%typep (object type)
    (let* ((typecode (typecode object)))
      (declare (type (unsigned-byte 8) typecode))
      (and (array-typecode-p typecode)
           (ecase (array-ctype-complexp type)
             ((t) (not (simple-array-p object)))
             ((nil) (simple-array-p object))
             ((* :maybe) t))
           (let* ((ctype-dimensions (array-ctype-dimensions type)))
             (or (eq ctype-dimensions '*)
  	       (if (eql typecode target::subtag-arrayH)
  		   (let* ((rank (%svref object target::arrayH.rank-cell)))
  		     (declare (fixnum rank))
  		     (and (eql rank (length ctype-dimensions))
  			  (do* ((i 0 (1+ i))
  				(dim target::arrayH.dim0-cell (1+ dim))
! 				(want (array-ctype-dimensions type) (cdr want))
! 				(got (%svref object dim) (%svref object dim)))
  			       ((eql i rank) t)
  			    (unless (or (eq (car want) '*)
! 					(eql (%car want) (the fixnum got)))
  			      (return nil)))))
  		   (and (null (cdr ctype-dimensions))
  			(or (eq (%car ctype-dimensions) '*)
  			    (eql (%car ctype-dimensions)
                                   (if (eql typecode target::subtag-vectorH)
                                     (%svref object target::vectorH.physsize-cell)
                                     (uvsize object))))))))
  	 (or (eq (array-ctype-element-type type) *wild-type*)
  	     (eql (array-ctype-typecode type)
  		  (if (> typecode target::subtag-vectorH)
                        typecode
                        (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref object target::arrayH.flags-cell)))))
  	     (type= (array-ctype-specialized-element-type type)
  		    (specifier-type (array-element-type object)))))))
  
  
--- 3742,3777 ----
  (defun array-%%typep (object type)
    (let* ((typecode (typecode object)))
      (declare (type (unsigned-byte 8) typecode))
      (and (array-typecode-p typecode)
           (ecase (array-ctype-complexp type)
             ((t) (not (simple-array-p object)))
             ((nil) (simple-array-p object))
             ((* :maybe) t))
           (let* ((ctype-dimensions (array-ctype-dimensions type)))
             (or (eq ctype-dimensions '*)
  	       (if (eql typecode target::subtag-arrayH)
  		   (let* ((rank (%svref object target::arrayH.rank-cell)))
  		     (declare (fixnum rank))
  		     (and (eql rank (length ctype-dimensions))
  			  (do* ((i 0 (1+ i))
  				(dim target::arrayH.dim0-cell (1+ dim))
! 				(want (array-ctype-dimensions type) (cdr want)))
  			       ((eql i rank) t)
  			    (unless (or (eq (car want) '*)
! 					(eql (%car want) (the fixnum (%svref object dim))))
  			      (return nil)))))
  		   (and (null (cdr ctype-dimensions))
  			(or (eq (%car ctype-dimensions) '*)
  			    (eql (%car ctype-dimensions)
                                   (if (eql typecode target::subtag-vectorH)
                                     (%svref object target::vectorH.physsize-cell)
                                     (uvsize object))))))))
  	 (or (eq (array-ctype-element-type type) *wild-type*)
  	     (eql (array-ctype-typecode type)
  		  (if (> typecode target::subtag-vectorH)
                        typecode
                        (ldb target::arrayH.flags-cell-subtag-byte (the fixnum (%svref object target::arrayH.flags-cell)))))
  	     (type= (array-ctype-specialized-element-type type)
  		    (specifier-type (array-element-type object)))))))