# HG changeset patch # User Aidan Kehoe # Date 1295790997 0 # Node ID fd441b85d76087b9b14340ff1ed090b3c3abc1da # Parent b4ef3128160cd912415eee1f987c2b9fe631c5fc Loop at macroexpansion time when sanity-checking :start, :end keyword args. 2011-01-23 Aidan Kehoe * automated/lisp-tests.el: When sanity-checking :start and :end keyword arguments, loop at macroexpansion time, not runtime, allowing us to pick up any compiler macros and giving a clearer *Test-Log* buffer. diff -r b4ef3128160c -r fd441b85d760 tests/ChangeLog --- a/tests/ChangeLog Sun Jan 23 13:13:54 2011 +0000 +++ b/tests/ChangeLog Sun Jan 23 13:56:37 2011 +0000 @@ -1,3 +1,10 @@ +2011-01-23 Aidan Kehoe + + * automated/lisp-tests.el: + When sanity-checking :start and :end keyword arguments, loop at + macroexpansion time, not runtime, allowing us to pick up any + compiler macros and giving a clearer *Test-Log* buffer. + 2011-01-23 Aidan Kehoe * automated/lisp-tests.el (test-fun): diff -r b4ef3128160c -r fd441b85d760 tests/automated/lisp-tests.el --- a/tests/automated/lisp-tests.el Sun Jan 23 13:13:54 2011 +0000 +++ b/tests/automated/lisp-tests.el Sun Jan 23 13:56:37 2011 +0000 @@ -2682,115 +2682,154 @@ (string (make-string string-length (or (decode-char 'ucs #x20ac) ?\xFF))) (item 'cons)) - (dolist (function '(count position find delete* remove* reduce)) - (Check-Error args-out-of-range - (funcall function item list - :start (1+ list-length) :end (1+ list-length))) - (Check-Error wrong-type-argument - (funcall function item list - :start -1 :end list-length)) - (Check-Error args-out-of-range - (funcall function item list :end (* 2 list-length))) - (Check-Error args-out-of-range - (funcall function item vector - :start (1+ vector-length) :end (1+ vector-length))) - (Check-Error wrong-type-argument - (funcall function item vector :start -1)) - (Check-Error args-out-of-range - (funcall function item vector :end (* 2 vector-length))) - (Check-Error args-out-of-range - (funcall function item bit-vector - :start (1+ vector-length) :end (1+ vector-length))) - (Check-Error wrong-type-argument - (funcall function item bit-vector :start -1)) - (Check-Error args-out-of-range - (funcall function item bit-vector :end (* 2 vector-length))) - (Check-Error args-out-of-range - (funcall function item string - :start (1+ string-length) :end (1+ string-length))) - (Check-Error wrong-type-argument - (funcall function item string :start -1)) - (Check-Error args-out-of-range - (funcall function item string :end (* 2 string-length)))) - (dolist (function '(delete-duplicates remove-duplicates)) - (Check-Error args-out-of-range - (funcall function (copy-sequence list) - :start (1+ list-length) :end (1+ list-length))) - (Check-Error wrong-type-argument - (funcall function (copy-sequence list) - :start -1 :end list-length)) - (Check-Error args-out-of-range - (funcall function (copy-sequence list) - :end (* 2 list-length))) - (Check-Error args-out-of-range - (funcall function (copy-sequence vector) - :start (1+ vector-length) :end (1+ vector-length))) - (Check-Error wrong-type-argument - (funcall function (copy-sequence vector) :start -1)) - (Check-Error args-out-of-range - (funcall function (copy-sequence vector) - :end (* 2 vector-length))) - (Check-Error args-out-of-range - (funcall function (copy-sequence bit-vector) - :start (1+ vector-length) :end (1+ vector-length))) - (Check-Error wrong-type-argument - (funcall function (copy-sequence bit-vector) :start -1)) - (Check-Error args-out-of-range - (funcall function (copy-sequence bit-vector) - :end (* 2 vector-length))) - (Check-Error args-out-of-range - (funcall function (copy-sequence string) - :start (1+ string-length) :end (1+ string-length))) - (Check-Error wrong-type-argument - (funcall function (copy-sequence string) :start -1)) - (Check-Error args-out-of-range - (funcall function (copy-sequence string) - :end (* 2 string-length)))) - (dolist (function '(replace mismatch search)) - (Check-Error args-out-of-range - (funcall function (copy-sequence list) (copy-sequence list) - :start1 (1+ list-length) :end1 (1+ list-length))) - (Check-Error wrong-type-argument - (funcall function (copy-sequence list) (copy-sequence list) - :start1 -1 :end1 list-length)) - (Check-Error args-out-of-range - (funcall function (copy-sequence list) (copy-sequence list) - :end1 (* 2 list-length))) - (Check-Error args-out-of-range - (funcall function (copy-sequence vector) - (copy-sequence vector) :start1 (1+ vector-length) - :end1 (1+ vector-length))) - (Check-Error wrong-type-argument - (funcall function (copy-sequence vector) - (copy-sequence vector) :start1 -1)) - (Check-Error args-out-of-range - (funcall function (copy-sequence vector) - (copy-sequence vector) - :end1 (* 2 vector-length))) - (Check-Error args-out-of-range - (funcall function (copy-sequence bit-vector) - (copy-sequence bit-vector) - :start1 (1+ vector-length) - :end1 (1+ vector-length))) - (Check-Error wrong-type-argument - (funcall function (copy-sequence bit-vector) - (copy-sequence bit-vector) :start1 -1)) - (Check-Error args-out-of-range - (funcall function (copy-sequence bit-vector) - (copy-sequence bit-vector) - :end1 (* 2 vector-length))) - (Check-Error args-out-of-range - (funcall function (copy-sequence string) - (copy-sequence string) - :start1 (1+ string-length) - :end1 (1+ string-length))) - (Check-Error wrong-type-argument - (funcall function (copy-sequence string) - (copy-sequence string) :start1 -1)) - (Check-Error args-out-of-range - (funcall function (copy-sequence string) - (copy-sequence string) - :end1 (* 2 string-length)))))) + (macrolet + ((construct-item-sequence-checks (&rest functions) + (cons + 'progn + (mapcan + #'(lambda (function) + `((Check-Error args-out-of-range + (,function item list + :start (1+ list-length) + :end (1+ list-length))) + (Check-Error wrong-type-argument + (,function item list :start -1 + :end list-length)) + (Check-Error args-out-of-range + (,function item list :end (* 2 list-length))) + (Check-Error args-out-of-range + (,function item vector + :start (1+ vector-length) + :end (1+ vector-length))) + (Check-Error wrong-type-argument + (,function item vector :start -1)) + (Check-Error args-out-of-range + (,function item vector + :end (* 2 vector-length))) + (Check-Error args-out-of-range + (,function item bit-vector + :start (1+ vector-length) + :end (1+ vector-length))) + (Check-Error wrong-type-argument + (,function item bit-vector :start -1)) + (Check-Error args-out-of-range + (,function item bit-vector + :end (* 2 vector-length))) + (Check-Error args-out-of-range + (,function item string + :start (1+ string-length) + :end (1+ string-length))) + (Check-Error wrong-type-argument + (,function item string :start -1)) + (Check-Error args-out-of-range + (,function item string + :end (* 2 string-length))))) + functions))) + (construct-one-sequence-checks (&rest functions) + (cons + 'progn + (mapcan + #'(lambda (function) + `((Check-Error args-out-of-range + (,function (copy-sequence list) + :start (1+ list-length) + :end (1+ list-length))) + (Check-Error wrong-type-argument + (,function (copy-sequence list) + :start -1 :end list-length)) + (Check-Error args-out-of-range + (,function (copy-sequence list) + :end (* 2 list-length))) + (Check-Error args-out-of-range + (,function (copy-sequence vector) + :start (1+ vector-length) + :end (1+ vector-length))) + (Check-Error wrong-type-argument + (,function (copy-sequence vector) :start -1)) + (Check-Error args-out-of-range + (,function (copy-sequence vector) + :end (* 2 vector-length))) + (Check-Error args-out-of-range + (,function (copy-sequence bit-vector) + :start (1+ vector-length) + :end (1+ vector-length))) + (Check-Error wrong-type-argument + (,function (copy-sequence bit-vector) + :start -1)) + (Check-Error args-out-of-range + (,function (copy-sequence bit-vector) + :end (* 2 vector-length))) + (Check-Error args-out-of-range + (,function (copy-sequence string) + :start (1+ string-length) + :end (1+ string-length))) + (Check-Error wrong-type-argument + (,function (copy-sequence string) :start -1)) + (Check-Error args-out-of-range + (,function (copy-sequence string) + :end (* 2 string-length))))) + functions))) + (construct-two-sequence-checks (&rest functions) + (cons + 'progn + (mapcan + #'(lambda (function) + `((Check-Error args-out-of-range + (,function (copy-sequence list) + (copy-sequence list) + :start1 (1+ list-length) + :end1 (1+ list-length))) + (Check-Error wrong-type-argument + (,function (copy-sequence list) + (copy-sequence list) + :start1 -1 :end1 list-length)) + (Check-Error args-out-of-range + (,function (copy-sequence list) + (copy-sequence list) + :end1 (* 2 list-length))) + (Check-Error args-out-of-range + (,function (copy-sequence vector) + (copy-sequence vector) + :start1 (1+ vector-length) + :end1 (1+ vector-length))) + (Check-Error wrong-type-argument + (,function + (copy-sequence vector) + (copy-sequence vector) :start1 -1)) + (Check-Error args-out-of-range + (,function (copy-sequence vector) + (copy-sequence vector) + :end1 (* 2 vector-length))) + (Check-Error args-out-of-range + (,function (copy-sequence bit-vector) + (copy-sequence bit-vector) + :start1 (1+ vector-length) + :end1 (1+ vector-length))) + (Check-Error wrong-type-argument + (,function (copy-sequence bit-vector) + (copy-sequence bit-vector) + :start1 -1)) + (Check-Error args-out-of-range + (,function (copy-sequence bit-vector) + (copy-sequence bit-vector) + :end1 (* 2 vector-length))) + (Check-Error args-out-of-range + (,function (copy-sequence string) + (copy-sequence string) + :start1 (1+ string-length) + :end1 (1+ string-length))) + (Check-Error wrong-type-argument + (,function (copy-sequence string) + (copy-sequence string) :start1 -1)) + (Check-Error args-out-of-range + (,function (copy-sequence string) + (copy-sequence string) + :end1 (* 2 string-length))))) + functions)))) + (construct-item-sequence-checks count position find delete* remove* + reduce) + (construct-one-sequence-checks delete-duplicates remove-duplicates) + (construct-two-sequence-checks replace mismatch search)))) (let* ((list (list 1 2 3 4 5 6 7 120 'hi-there '#:everyone)) (vector (map 'vector #'identity list))