[cmucl/cmucl][master] Fix #4: ELT signals error on invalid index on lists - cmucl-cvs - mailman3.common-lisp.net

14 Jun 2015

Raymond Toy pushed to branch master at cmucl / cmucl
Commits:
1ca0a557 by Raymond Toy at 2015-06-14T08:31:14Z
Fix #4: ELT signals error on invalid index on lists
code/seq.lisp:
o Define internal LIST-ELT* function that executes ELT on lists,
  signaling an error if the index is invalid.
compiler/seqtran.lisp:
o Change the deftransform for ELT to use LIST-ELT* instead of NTH.
tests/issues.lisp:
o Add test for this issue.
- - - - -
3 changed files:
- src/code/seq.lisp
- src/compiler/seqtran.lisp
- tests/issues.lisp
Changes:
=====================================
src/code/seq.lisp
=====================================

--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -138,6 +138,16 @@
     (t
      (make-sequence-of-type (result-type-or-lose type) length))))
+(defun list-elt* (sequence index)
+  (declare (type list sequence))
+  (do ((count index (1- count))
+       (list sequence (cdr list)))
+      ((= count 0)
+       (if (endp list)
+	   (signal-index-too-large-error sequence index)
+	   (car list)))
+    (declare (type (integer 0) count))))
+
 (defun elt (sequence index)
   "Returns the element of SEQUENCE specified by INDEX."
   (etypecase sequence
=====================================
src/compiler/seqtran.lisp
=====================================
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -107,8 +107,8 @@
 (deftransform elt ((s i) ((simple-array * (*)) *) * :when :both)
   '(aref s i))
-(deftransform elt ((s i) (list *) * :when :both :policy (< safety 3))
-  '(nth i s))
+(deftransform elt ((s i) (list *) * :when :both)
+  '(lisp::list-elt* s i))
(deftransform %setelt ((s i v) ((simple-array * (*)) * *) * :when :both)
   '(%aset s i v))
=====================================
tests/issues.lisp
=====================================
--- a/tests/issues.lisp
+++ b/tests/issues.lisp
@@ -23,3 +23,18 @@
   (assert-equal
    '(square x)
    (funcall (compiler-macro-function 'square) '(funcall #'square x) nil)))
+
+(define-test issue.5
+    (:tag :issues)
+  (assert-true
+   (handler-case
+       (let ((f (compile nil '(lambda (list)
+			       (declare (type list list)
+				(optimize (speed 1) (safety 1) (compilation-speed 1) (space 1) (debug 1)))
+			       (elt list 3)))))
+	 (funcall f (list 0 1 2)))
+     ;; ELT should signal an error in this case.
+     (lisp::index-too-large-error ()
+       t)
+     (t ()
+       nil))))
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/1ca0a5571183b014a50fad56be...

    