Mercurial > hg > xemacs-beta
changeset 5347:fd441b85d760
Loop at macroexpansion time when sanity-checking :start, :end keyword args.
2011-01-23 Aidan Kehoe <kehoea@parhasard.net>
* 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.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Sun, 23 Jan 2011 13:56:37 +0000 |
| parents | b4ef3128160c |
| children | 39304a35b6b3 |
| files | tests/ChangeLog tests/automated/lisp-tests.el |
| diffstat | 2 files changed, 155 insertions(+), 109 deletions(-) [+] |
line wrap: on
line diff
--- 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 <kehoea@parhasard.net> + + * 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 <kehoea@parhasard.net> * automated/lisp-tests.el (test-fun):
--- 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))