Never transform ELT to NTH

The initial problem is that elt derives types on constant lists
without adding a NIL, which can be returned by NTH.
Always check bounds instead.
There's no performance advantage in not signaling an error.

src/code/seq.lisp

@@ -292,18 +292,23 @@
              (and (csubtypep type (specifier-type 'vector))
                   (not (csubtypep type (specifier-type '(and vector (not simple-array))))))))))
 
-(declaim (ftype (function (sequence index) nil) signal-index-too-large-error))
+(declaim (ftype (function (sequence index &optional t) nil) signal-index-too-large-error))
-(define-error-wrapper signal-index-too-large-error (sequence index)
+(define-error-wrapper signal-index-too-large-error (sequence index &optional rest)
-  (let* ((length (length sequence))
+  (if rest
-         (max-index (and (plusp length)
+      (error 'index-too-large-error
-                         (1- length))))
+             :datum index
-    (error 'index-too-large-error
+             :sequence rest
-           :datum index
+             :expected-type `(integer 0 (,rest)))
-           :sequence sequence
+      (let* ((length (length sequence))
-           :expected-type (if max-index
+             (max-index (and (plusp length)
-                              `(integer 0 ,max-index)
+                             (1- length))))
-                              ;; This seems silly, is there something better?
+        (error 'index-too-large-error
-                              '(integer 0 (0))))))
+               :datum index
+               :sequence sequence
+               :expected-type (if max-index
+                                  `(integer 0 ,max-index)
+                                  ;; This seems silly, is there something better?
+                                  '(integer 0 (0)))))))
 
 (declaim (ftype (function (t t t) nil) sequence-bounding-indices-bad-error))
 (define-error-wrapper sequence-bounding-indices-bad-error (sequence start end)
@@ -342,17 +347,33 @@
                 (zerop (length sequence))
                 (sb-sequence:emptyp sequence)))
 
+(declaim (maybe-inline elt-list %setelt-list))
+(defun elt-list (list index)
+  (declare (explicit-check)
+           (optimize speed))
+  (prog ((result list)
+         (i index))
+     (when (typep index '(and unsigned-byte fixnum))
+       (go loop))
+   bad
+     (signal-index-too-large-error list index)
+   loop
+     (unless (listp result)
+       (go bad))
+     (if (plusp (truly-the fixnum i))
+         (psetq i (1- i)
+                result (cdr result))
+         (if (atom result)
+             (go bad)
+             (return (car result))))
+     (go loop)))
+
 (defun elt (sequence index)
   "Return the element of SEQUENCE specified by INDEX."
-  (declare (explicit-check sequence))
+  (declare (explicit-check sequence)
+           (inline elt-list))
   (seq-dispatch-checking sequence
-      (do ((count index (1- count))
+      (elt-list sequence index)
-           (list sequence (cdr list)))
-          ((= count 0)
-           (if (atom list)
-               (signal-index-too-large-error sequence index)
-               (car list)))
-        (declare (type index count)))
       (locally
           (declare (optimize (sb-c:insert-array-bounds-checks 0)))
         (when (>= index (length sequence))
@@ -360,18 +381,31 @@
         (aref sequence index))
       (sb-sequence:elt sequence index)))
 
+(defun %setelt-list (list index newval)
+  (declare (explicit-check)
+           (optimize speed))
+  (prog ((result list)
+         (i index))
+     (when (typep index '(and unsigned-byte fixnum))
+       (go loop))
+   bad
+     (signal-index-too-large-error list index)
+   loop
+     (unless (listp result)
+       (go bad))
+     (if (plusp (truly-the fixnum i))
+         (psetq i (1- i)
+                result (cdr result))
+         (if (atom result)
+             (go bad)
+             (return (setf (car result) newval))))
+     (go loop)))
+
 (defun %setelt (sequence index newval)
   "Store NEWVAL as the component of SEQUENCE specified by INDEX."
   (declare (explicit-check sequence))
   (seq-dispatch-checking sequence
-      (do ((count index (1- count))
+      (%setelt-list sequence index newval)
-           (seq sequence))
-          ((= count 0) (rplaca seq newval) newval)
-        (declare (fixnum count))
-        (let ((cdr (cdr seq)))
-          (if (atom cdr)
-              (signal-index-too-large-error sequence index)
-              (setq seq cdr))))
       (if (>= index (length sequence))
           (signal-index-too-large-error sequence index)
           (locally
@@ -383,9 +417,9 @@
   "Return an integer that is the length of SEQUENCE."
   (declare (explicit-check))
   (seq-dispatch-checking sequence
-                (length sequence)
+      (length sequence)
-                (length sequence)
+      (length sequence)
-                (sb-sequence:length sequence)))
+      (sb-sequence:length sequence)))
 
 (defun make-sequence (result-type length &key (initial-element nil iep))
   "Return a sequence of the given RESULT-TYPE and LENGTH, with

src/code/target-error.lisp

@@ -1470,21 +1470,25 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
    (lambda (condition stream)
      (let ((sequence (slot-value condition 'sequence))
            (index (type-error-datum condition)))
-       (if (vectorp sequence)
+       (cond ((integerp sequence)
-           (format stream "Invalid index ~D for ~S~@[ with fill-pointer ~D~]~
+              (format stream "Invalid index ~d for a &rest list of length ~d."
+                      index sequence))
+             ((vectorp sequence)
+              (format stream "Invalid index ~D for ~S~@[ with fill-pointer ~D~]~
 ~@[, ~:@_should be a non-negative integer below ~D~]."
-                   index
+                      index
-                   (type-of sequence)
+                      (type-of sequence)
-                   (and (array-has-fill-pointer-p sequence)
+                      (and (array-has-fill-pointer-p sequence)
-                        (fill-pointer sequence))
+                           (fill-pointer sequence))
-                   (let ((l (length sequence))) (if (> l 0) l)))
+                      (let ((l (length sequence))) (if (> l 0) l))))
-           (format stream
+             (t
-                   "The index ~D is too large for a ~a of length ~D."
+              (format stream
-                   index
+                      "The index ~D is too large for a ~a of length ~D."
-                   (if (listp sequence)
+                      index
-                       "list"
+                      (if (listp sequence)
-                       "sequence")
+                          "list"
-                   (length sequence)))))))
+                          "sequence")
+                      (length sequence))))))))
 
 (define-condition bounding-indices-bad-error (reference-condition type-error)
   ((object :reader bounding-indices-bad-object :initarg :object))

src/cold/exports.lisp

@@ -2386,7 +2386,9 @@ is a good idea, but see SB-SYS re. blurring of boundaries.")
            "SIMPLE-BASE-STRING="
            #+sb-unicode "SIMPLE-CHARACTER-STRING="
            "%SP-STRING-COMPARE" "%SP-STRING="
-           "%SETNTH" "%SETELT"
+           "%SETNTH"
+           "%SETELT" "%SETELT-LIST"
+           "ELT-LIST"
            "%SET-ROW-MAJOR-AREF" "%SET-FILL-POINTER"
            "%SET-FDEFINITION" "%SCHARSET"
            "%RPLACD" "%RPLACA" "%PUT" "%CHARSET"

src/compiler/fndb.lisp

@@ -620,9 +620,15 @@
 ;;;; from the "Sequences" chapter:
 
 (defknown elt ((read-only proper-sequence) index) t (foldable unsafely-flushable))
+(defknown elt-list ((read-only proper-list) index) t (foldable unsafely-flushable))
+
+(defknown %setelt ((modifying sequence) index t) t ()
+  :derive-type #'result-type-last-arg)
+(defknown %setelt-list ((modifying sequence) index t) t ()
+  :derive-type #'result-type-last-arg)
 
 (defknown subseq ((read-only proper-sequence) index &optional sequence-end) consed-sequence
-  (flushable foldable-read-only))
+    (flushable foldable-read-only))
 
 (defknown vector-subseq ((read-only vector) index sequence-end) (simple-array * (*))
   (flushable foldable-read-only no-verify-arg-count))
@@ -2176,6 +2182,7 @@
 
 (defknown %rest-values (t t t t) * (always-translatable))
 (defknown %rest-ref (t t t t &optional boolean) * (always-translatable))
+(defknown %rest-elt (t t t t &optional boolean) * (always-translatable))
 (defknown %rest-length (t t t) * (always-translatable))
 (defknown %rest-null (t t t t) * (always-translatable))
 (defknown %rest-true (t t t) * (always-translatable))
@@ -2297,10 +2304,11 @@
     function (flushable no-verify-arg-count))
 (defknown array-bounding-indices-bad-error (t t t) nil (no-verify-arg-count))
 (defknown sequence-bounding-indices-bad-error (t t t) nil (no-verify-arg-count))
+(defknown sb-impl::signal-index-too-large-error (sequence index &optional t) nil)
 (defknown %find-position
     (t sequence t index sequence-end (function (t)) (function (t t)))
-  (values t (or index null))
+    (values t (or index null))
-  (flushable foldable call no-verify-arg-count))
+    (flushable foldable call no-verify-arg-count))
 (defknown (%find-position-if %find-position-if-not)
   ((function ((nth-arg 1 :sequence t :key (nth-arg 5))))
    sequence t index sequence-end (function ((nth-arg 1 :sequence t))))
@@ -2391,8 +2399,6 @@
 (defknown (%rplaca %rplacd) ((modifying cons) t) t ()
   :derive-type #'result-type-last-arg)
 (defknown %put (symbol t t) t (no-verify-arg-count))
-(defknown %setelt ((modifying sequence) index t) t ()
-  :derive-type #'result-type-last-arg)
 (defknown %svset ((modifying simple-vector) index t) t ())
 (defknown (setf bit) (bit (modifying (array bit)) &rest index) bit ())
 (defknown (setf sbit) (bit (modifying (simple-array bit)) &rest index) bit ())

src/compiler/seqtran.lisp

@@ -403,16 +403,14 @@
 (deftransform elt ((s i) (simple-array t) *)
   '(aref s i))
 
-(deftransform elt ((s i) (list t) * :policy (< safety 3))
+(deftransform elt ((s i) (list t))
-  (when (eql (lvar-type s) (specifier-type 'null))
+  '(elt-list s i))
-    (give-up-ir1-transform))
-  '(nth i s))
 
 (deftransform %setelt ((s i v) ((simple-array * (*)) t t) *)
   '(setf (aref s i) v))
 
-(deftransform %setelt ((s i v) (list t t) * :policy (< safety 3))
+(deftransform %setelt ((s i v) (list t t))
-  '(setf (car (nthcdr i s)) v))
+  '(%setelt-list s i v))
 
 (deftransform %check-vector-sequence-bounds ((vector start end)
                                              (vector t t) *

src/compiler/srctran.lisp

@@ -8336,7 +8336,7 @@
                       ;; isn't good anywhere else either.
                       (lvar-fun-is (combination-fun dest)
                                    '(%rest-values %rest-ref %rest-length
-                                     %rest-null %rest-true %rest-listify))
+                                     %rest-null %rest-true %rest-listify %rest-elt))
                       ;; If the home lambda is different and isn't DX, it might
                       ;; escape -- in which case using the more context isn't safe.
                       (dx-node-p dest))))
@@ -8390,12 +8390,10 @@
         (bug "no &REST context for FAST-REST-NTH"))))
 
 (define-source-transform elt (seq n)
-  (if (policy *lexenv* (= safety 3))
+  (multiple-value-bind (context count) (possible-rest-arg-context seq)
-      (values nil t)
+    (if context
-      (multiple-value-bind (context count) (possible-rest-arg-context seq)
+        `(%rest-elt ,n ,seq ,context ,count)
-        (if context
+        (values nil t))))
-            `(%rest-ref ,n ,seq ,context ,count)
-            (values nil t)))))
 
 ;;; CAxR -> %REST-REF
 (defun source-transform-car (list nth)
@@ -8522,6 +8520,18 @@
         (t
          `(and (< (the index n) count) (%more-arg context n)))))
 
+(deftransform %rest-elt ((n list context count &optional length-checked-p))
+  (cond ((not (rest-var-more-context-ok list))
+         `(elt-list list n))
+        ((and length-checked-p
+              (constant-lvar-p length-checked-p)
+              (lvar-value length-checked-p))
+         `(%more-arg context n))
+        (t
+         `(if (< (the index n) count)
+              (%more-arg context n)
+              (sb-impl::signal-index-too-large-error nil n count)))))
+
 (deftransform %rest-length ((list context count))
   (if (rest-var-more-context-ok list)
       'count

tests/seq.impure.lisp

@@ -419,10 +419,9 @@
       (:optimize :safe)
       `(lambda (x) (elt x 3))
     (("foo") (condition 'type-error))
+    (('(1 2)) (condition 'type-error))
     (("foob") #\b))
-  (locally
+  (assert-error (elt (list 1 2 3) 3) type-error))
-      (declare (optimize (safety 3)))
-    (assert-error (elt (list 1 2 3) 3) type-error)))
 
 ;;; confusion in the refactoring led to this signalling an unbound
 ;;; variable, not a type error.

tests/seq.pure.lisp

@@ -416,8 +416,7 @@
 
 (with-test (:name :&more-elt-index-too-large)
   (checked-compile-and-assert
-      (:optimize `(:filter ,(lambda (&key safety &allow-other-keys)
+      (:optimize :safe)
-                              (= safety 3))))
       `(lambda (&rest args)
          (elt args 0))
     (() (condition 'sb-kernel:index-too-large-error))))