Date: Fri, 6 Aug 2021 20:54:36 GMT From: Kirill Ponomarev <krion@FreeBSD.org> To: ports-committers@FreeBSD.org, dev-commits-ports-all@FreeBSD.org, dev-commits-ports-branches@FreeBSD.org Subject: git: 0de4843c5329 - 2021Q3 - lang/sbcl: Fix an error in REPLACE for arguments of type (VECTOR CHARACTER *) Message-ID: <202108062054.176Ksa84062232@gitrepo.freebsd.org>
next in thread | raw e-mail | index | archive | help
The branch 2021Q3 has been updated by krion: URL: https://cgit.FreeBSD.org/ports/commit/?id=0de4843c5329a834685ba4dfb8bb512b622cc9ac commit 0de4843c5329a834685ba4dfb8bb512b622cc9ac Author: Kirill Ponomarev <krion@FreeBSD.org> AuthorDate: 2021-08-06 20:50:43 +0000 Commit: Kirill Ponomarev <krion@FreeBSD.org> CommitDate: 2021-08-06 20:54:31 +0000 lang/sbcl: Fix an error in REPLACE for arguments of type (VECTOR CHARACTER *) Reported by: jrm (cherry picked from commit 969aedb5b1a5200865ef81bdf5fccb998a810f20) --- lang/sbcl/Makefile | 1 + lang/sbcl/files/patch_seq.lisp | 143 ++++++++++++++++++++++++++++++ lang/sbcl/files/patch_tests_seq.pure.lisp | 21 +++++ 3 files changed, 165 insertions(+) diff --git a/lang/sbcl/Makefile b/lang/sbcl/Makefile index 2ee01f02b9bf..beaa1ee7940e 100644 --- a/lang/sbcl/Makefile +++ b/lang/sbcl/Makefile @@ -5,6 +5,7 @@ PORTNAME= sbcl DISTVERSION= 2.1.7 DISTVERSIONSUFFIX= -source +PORTREVISION= 1 PORTEPOCH= 1 CATEGORIES= lang lisp MASTER_SITES= SF/${PORTNAME}/${PORTNAME}/${DISTVERSION} \ diff --git a/lang/sbcl/files/patch_seq.lisp b/lang/sbcl/files/patch_seq.lisp new file mode 100644 index 000000000000..a8b45f2311d0 --- /dev/null +++ b/lang/sbcl/files/patch_seq.lisp @@ -0,0 +1,143 @@ +--- work/sbcl-2.1.7/src/code/seq.lisp 2021-07-30 10:42:09.000000000 +0200 ++++ /home/krion/sbcl/src/code/seq.lisp 2021-08-06 22:34:09.026438000 +0200 +@@ -722,52 +722,53 @@ + collect `(eq ,tag ,(sb-vm:saetp-typecode saetp))))) + + ;;;; REPLACE +-(defun vector-replace (vector1 vector2 start1 start2 end1 diff) +- (declare ((or (eql -1) index) start1 start2 end1) +- (optimize (sb-c::insert-array-bounds-checks 0)) +- ((integer -1 1) diff)) +- (let ((tag1 (%other-pointer-widetag vector1)) +- (tag2 (%other-pointer-widetag vector2))) +- (macrolet ((copy (&body body) +- `(do ((index1 start1 (+ index1 diff)) +- (index2 start2 (+ index2 diff))) +- ((= index1 end1)) +- (declare (fixnum index1 index2)) +- ,@body))) +- (when (= tag1 tag2) +- (when (= tag1 sb-vm:simple-vector-widetag) +- (copy (setf (svref vector1 index1) (svref vector2 index2))) +- (return-from vector-replace vector1)) +- (let ((copier (sb-vm::blt-copier-for-widetag tag1))) +- (when (functionp copier) +- ;; VECTOR1 = destination, VECTOR2 = source, but copier wants FROM, TO +- (funcall copier vector2 start2 vector1 start1 (- end1 start1)) +- (return-from vector-replace vector1)))) +- (let ((getter (the function (svref %%data-vector-reffers%% tag2))) +- (setter (the function (svref %%data-vector-setters%% tag1)))) +- (copy (funcall setter vector1 index1 (funcall getter vector2 index2)))))) +- vector1) + + ;;; If we are copying around in the same vector, be careful not to copy the + ;;; same elements over repeatedly. We do this by copying backwards. ++;;; Bounding indices were checked for validity by DEFINE-SEQUENCE-TRAVERSER. + (defmacro vector-replace-from-vector () +- `(let ((nelts (min (- target-end target-start) +- (- source-end source-start)))) +- (with-array-data ((data1 target-sequence) (start1 target-start) (end1)) +- (declare (ignore end1)) +- (let ((end1 (the fixnum (+ start1 nelts)))) +- (if (and (eq target-sequence source-sequence) +- (> target-start source-start)) +- (let ((end (the fixnum (1- end1)))) +- (vector-replace data1 data1 +- end +- (the fixnum (- end +- (- target-start source-start))) +- (1- start1) +- -1)) +- (with-array-data ((data2 source-sequence) (start2 source-start) (end2)) +- (declare (ignore end2)) +- (vector-replace data1 data2 start1 start2 end1 1))))) ++ `(locally ++ (declare (optimize (safety 0))) ++ (let ((nelts (min (- target-end target-start) ++ (- source-end source-start)))) ++ (when (plusp nelts) ++ (with-array-data ((data1 target-sequence) (start1 target-start) (end1)) ++ (progn end1) ++ (with-array-data ((data2 source-sequence) (start2 source-start) (end2)) ++ (progn end2) ++ (let ((tag1 (%other-pointer-widetag data1)) ++ (tag2 (%other-pointer-widetag data2))) ++ (block replace ++ (when (= tag1 tag2) ++ (when (= tag1 sb-vm:simple-vector-widetag) ; rely on the transform ++ (replace (truly-the simple-vector data1) ++ (truly-the simple-vector data2) ++ :start1 start1 :end1 (truly-the index (+ start1 nelts)) ++ :start2 start2 :end2 (truly-the index (+ start2 nelts))) ++ (return-from replace)) ++ (let ((copier (sb-vm::blt-copier-for-widetag tag1))) ++ (when (functionp copier) ++ ;; these copiers figure out which direction to step. ++ ;; arg order is FROM, TO which is the opposite of REPLACE. ++ (funcall copier data2 start2 data1 start1 nelts) ++ (return-from replace)))) ++ ;; General case is just like the code emitted by TRANSFORM-REPLACE ++ ;; but using the getter and setter. ++ (let ((getter (the function (svref %%data-vector-reffers%% tag2))) ++ (setter (the function (svref %%data-vector-setters%% tag1)))) ++ (cond ((and (eq data1 data2) (> start1 start2)) ++ (do ((i (the (or (eql -1) index) (+ start1 nelts -1)) (1- i)) ++ (j (the (or (eql -1) index) (+ start2 nelts -1)) (1- j))) ++ ((< i start1)) ++ (declare (index i j)) ++ (funcall setter data1 i (funcall getter data2 j)))) ++ (t ++ (do ((i start1 (1+ i)) ++ (j start2 (1+ j)) ++ (end (the index (+ start1 nelts)))) ++ ((>= i end)) ++ (declare (index i j)) ++ (funcall setter data1 i (funcall getter data2 j)))))))))))) + target-sequence)) + + (defmacro list-replace-from-list () +@@ -819,44 +820,6 @@ + target-sequence) + (declare (fixnum target-index source-index)) + (setf (aref target-sequence target-index) (car source-sequence)))) +- +-;;;; The support routines for REPLACE are used by compiler transforms, so we +-;;;; worry about dealing with END being supplied or defaulting to NIL +-;;;; at this level. +- +-(defun list-replace-from-list* (target-sequence source-sequence target-start +- target-end source-start source-end) +- (when (null target-end) (setq target-end (length target-sequence))) +- (when (null source-end) (setq source-end (length source-sequence))) +- (list-replace-from-list)) +- +-(defun list-replace-from-vector* (target-sequence source-sequence target-start +- target-end source-start source-end) +- (when (null target-end) (setq target-end (length target-sequence))) +- (when (null source-end) (setq source-end (length source-sequence))) +- (list-replace-from-vector)) +- +-(defun vector-replace-from-list* (target-sequence source-sequence target-start +- target-end source-start source-end) +- (when (null target-end) (setq target-end (length target-sequence))) +- (when (null source-end) (setq source-end (length source-sequence))) +- (vector-replace-from-list)) +- +-(defun vector-replace-from-vector* (target-sequence source-sequence +- target-start target-end source-start +- source-end) +- (when (null target-end) (setq target-end (length target-sequence))) +- (when (null source-end) (setq source-end (length source-sequence))) +- (vector-replace-from-vector)) +- +-#+sb-unicode +-(defun simple-character-string-replace-from-simple-character-string* +- (target-sequence source-sequence +- target-start target-end source-start source-end) +- (declare (type (simple-array character (*)) target-sequence source-sequence)) +- (when (null target-end) (setq target-end (length target-sequence))) +- (when (null source-end) (setq source-end (length source-sequence))) +- (vector-replace-from-vector)) + + (define-sequence-traverser replace + (target-sequence1 source-sequence2 &rest args &key start1 end1 start2 end2) diff --git a/lang/sbcl/files/patch_tests_seq.pure.lisp b/lang/sbcl/files/patch_tests_seq.pure.lisp new file mode 100644 index 000000000000..059e6d57fa3e --- /dev/null +++ b/lang/sbcl/files/patch_tests_seq.pure.lisp @@ -0,0 +1,21 @@ +--- work/sbcl-2.1.7/tests/seq.pure.lisp 2021-07-30 10:42:10.000000000 +0200 ++++ /home/krion/sbcl/tests/seq.pure.lisp 2021-08-06 22:34:09.303934000 +0200 +@@ -584,3 +584,18 @@ + ;; Try all other numeric array types + (dolist (y arrays) + (assert (equalp x y))))))) ++ ++;; lp#1938598 ++(with-test (:name :vector-replace-self) ++ ;; example 1 ++ (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) ++ (declare (notinline replace)) ++ (vector-push-extend #\_ string) ++ ;; also test it indirectly ++ (replace string string :start1 1 :start2 0)) ++ ;; example 2 ++ (let ((string (make-array 0 :adjustable t :fill-pointer 0 :element-type 'character))) ++ (declare (notinline replace)) ++ (loop for char across "tset" do (vector-push-extend char string)) ++ (replace string string :start2 1 :start1 2) ++ (assert (string= string "tsse"))))
Want to link to this message? Use this URL: <https://mail-archive.FreeBSD.org/cgi/mid.cgi?202108062054.176Ksa84062232>