[Git][cmucl/cmucl][master] Fix #4 again, but for negative indices.

[Raymond Toy]

Raymond Toy pushed to branch master at cmucl / cmucl


Commits:
5a1ecf1a by Raymond Toy at 2015-08-01T13:24:07Z
Fix #4 again, but for negative indices.

o Add declaration for LIST-ELT* that the index is a kerrnel:index.
o Clean up ELT to directly call LIST-ELT* instead of having an inlined
  version.
o Fix typo: issue.5 is really issue.4.
o Add tests for invalid indices for ELT and (SETF ELT) for both lists
  and vectors.

- - - - -


2 changed files:

- src/code/seq.lisp
- tests/issues.lisp


Changes:

=====================================
src/code/seq.lisp
=====================================
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -139,7 +139,8 @@
      (make-sequence-of-type (result-type-or-lose type) length))))
   
 (defun list-elt* (sequence index)
-  (declare (type list sequence))
+  (declare (type list sequence)
+	   (type kernel:index index))
   (do ((count index (1- count))
        (list sequence (cdr list)))
       ((= count 0)
@@ -152,13 +153,7 @@
   "Returns the element of SEQUENCE specified by INDEX."
   (etypecase sequence
     (list
-     (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))))
+     (list-elt* sequence index))
     (vector
      (when (>= index (length sequence))
        (signal-index-too-large-error sequence index))


=====================================
tests/issues.lisp
=====================================
--- a/tests/issues.lisp
+++ b/tests/issues.lisp
@@ -24,20 +24,46 @@
    '(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))))
+(define-test issue.4
+  (:tag :issues)
+  ;; Compile up two versions of elt.  F-LIST should get transformed to
+  ;; LISP::LISP-ELT*, and F-VEC should be converted to AREF.  Both of
+  ;; thse should signal errors.
+  (let ((f-list (compile nil '(lambda (list n)
+				(declare (type list list)
+					 (optimize (speed 1) (safety 1) (compilation-speed 1)
+						   (space 1) (debug 1)))
+			       (elt list n))))
+	(f-vec (compile nil '(lambda (vec n)
+			       (declare (type (simple-array * (*)) vec)
+					(optimize (speed 1) (safety 1) (compilation-speed 1)
+						  (space 1) (debug 1)))
+			      (elt vec n)))))
+    ;; Errors because the index is beyond the end of the sequence
+    (assert-error 'lisp::index-too-large-error (funcall f-list (list 0 1 2) 3))
+    (assert-error 'type-error (funcall f-vec (make-array 3 :initial-contents '(0 1 2)) 3))
+    ;; Errors because the index is negative.
+    (assert-error 'type-error (funcall f-list (list 0 1 2) -1))
+    (assert-error 'type-error (funcall f-vec (make-array 3 :initial-contents '(0 1 2)) -1))))
+
+(define-test issue.4.setters
+  (:tag :issues)
+  ;; Compile up two versions of (SETF ELT).  F-LIST should get transformed to
+  ;; %SETELT, and F-VEC should be converted to (SETF AREF).  Both of
+  ;; thse should signal errors.
+  (let ((s-list (compile nil '(lambda (list n new)
+				(declare (type list list))
+				(setf (elt list n) new))))
+	(s-vec (compile nil '(lambda (vec n new)
+			       (declare (type (simple-array * (*)) vec))
+			       (setf (elt vec n) new)))))
+    ;; Errors because the index is beyond the end of the sequence
+    (assert-error 'type-error (funcall s-list (list 0 1 2) 3 99))
+    (assert-error 'type-error (funcall s-vec (make-array 3 :initial-contents '(0 1 2)) 3 99))
+    ;; Errors because the index is negative.
+    (assert-error 'type-error (funcall s-list (list 0 1 2) -1 99))
+    (assert-error 'type-error (funcall s-vec (make-array 3 :initial-contents '(0 1 2)) -1 99))))
+
 
 ;; Functions for testing issue-3
 (defun sqr (x)



View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/commit/5a1ecf1aa15fd6b5a3b4bac0c5f3d82a8d5621c2
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20150801/cf2fc642/attachment.html>