carbon2-commit: Loop at macroexpansion time when sanity-checking :start, :end keyword args.

changeset: 5405:fd441b85d760 user: Aidan Kehoe <kehoea(a)parhasard.net&gt; date: Sun Jan 23 13:56:37 2011 +0000 files: tests/ChangeLog tests/automated/lisp-tests.el description: Loop at macroexpansion time when sanity-checking :start, :end keyword args. 2011-01-23 Aidan Kehoe <kehoea(a)parhasard.net&gt; * 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 <kehoea(a)parhasard.net&gt; + + * 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(a)parhasard.net&gt; * 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)) _______________________________________________ XEmacs-Patches mailing list XEmacs-Patches(a)xemacs.org http://lists.xemacs.org/mailman/listinfo/xemacs-patches