From c7bcc4faed97a8697a1af01948e7bd0a818543dd Mon Sep 17 00:00:00 2001 From: sds <sds@localhost> Date: Wed, 12 Aug 2009 19:45:53 +0000 Subject: [PATCH] untabify --- ansi-tests/abort.lsp | 6 +- ansi-tests/abs.lsp | 58 +- ansi-tests/acons.lsp | 8 +- ansi-tests/acos.lsp | 82 +- ansi-tests/acosh.lsp | 82 +- ansi-tests/add-method.lsp | 58 +- ansi-tests/adjoin.lsp | 44 +- ansi-tests/adjust-array.lsp | 418 ++-- ansi-tests/adjustable-array-p.lsp | 12 +- ansi-tests/allocate-instance.lsp | 36 +- ansi-tests/and.lsp | 18 +- ansi-tests/ansi-aux-macros.lsp | 18 +- ansi-tests/ansi-aux.lsp | 898 ++++---- ansi-tests/append.lsp | 30 +- ansi-tests/apply.lsp | 20 +- ansi-tests/apropos-list.lsp | 62 +- ansi-tests/apropos.lsp | 52 +- ansi-tests/aref.lsp | 24 +- ansi-tests/arithmetic-error.lsp | 28 +- ansi-tests/array-aux.lsp | 202 +- ansi-tests/array-dimension.lsp | 10 +- ansi-tests/array-dimensions.lsp | 10 +- ansi-tests/array-displacement.lsp | 72 +- ansi-tests/array-element-type.lsp | 2 +- ansi-tests/array-in-bounds-p.lsp | 22 +- ansi-tests/array-rank.lsp | 2 +- ansi-tests/array-row-major-index.lsp | 6 +- ansi-tests/array-t.lsp | 6 +- ansi-tests/array-total-size.lsp | 2 +- ansi-tests/array.lsp | 6 +- ansi-tests/ash.lsp | 30 +- ansi-tests/asin.lsp | 82 +- ansi-tests/asinh.lsp | 78 +- ansi-tests/assert.lsp | 24 +- ansi-tests/assoc-if-not.lsp | 48 +- ansi-tests/assoc-if.lsp | 44 +- ansi-tests/assoc.lsp | 82 +- ansi-tests/atan.lsp | 122 +- ansi-tests/atanh.lsp | 110 +- ansi-tests/atom-errors.lsp | 2 +- ansi-tests/atom.lsp | 4 +- ansi-tests/backquote-aux.lsp | 30 +- ansi-tests/beyond-ansi/ba-aux.lsp | 28 +- ansi-tests/beyond-ansi/ba-test-package.lsp | 2 +- .../errors-data-and-control-flow-3.lsp | 2 +- .../beyond-ansi/errors-eval-compile.lsp | 142 +- ansi-tests/beyond-ansi/load-ba.lsp | 2 +- ansi-tests/bit-and.lsp | 150 +- ansi-tests/bit-andc1.lsp | 150 +- ansi-tests/bit-andc2.lsp | 150 +- ansi-tests/bit-aux.lsp | 20 +- ansi-tests/bit-eqv.lsp | 150 +- ansi-tests/bit-ior.lsp | 150 +- ansi-tests/bit-nand.lsp | 150 +- ansi-tests/bit-nor.lsp | 150 +- ansi-tests/bit-not.lsp | 42 +- ansi-tests/bit-orc1.lsp | 152 +- ansi-tests/bit-orc2.lsp | 152 +- ansi-tests/bit-vector-p.lsp | 6 +- ansi-tests/bit-vector.lsp | 12 +- ansi-tests/bit-xor.lsp | 150 +- ansi-tests/bit.lsp | 34 +- ansi-tests/block.lsp | 2 +- ansi-tests/boole.lsp | 118 +- ansi-tests/boundp.lsp | 4 +- ansi-tests/broadcast-stream-streams.lsp | 2 +- ansi-tests/butlast.lsp | 38 +- ansi-tests/byte.lsp | 14 +- ansi-tests/call-arguments-limit.lsp | 2 +- ansi-tests/call-next-method.lsp | 28 +- ansi-tests/case.lsp | 28 +- ansi-tests/catch.lsp | 14 +- ansi-tests/ccase.lsp | 32 +- ansi-tests/ceiling-aux.lsp | 164 +- ansi-tests/ceiling.lsp | 136 +- ansi-tests/cell-error-name.lsp | 10 +- ansi-tests/cerror.lsp | 24 +- ansi-tests/change-class.lsp | 152 +- ansi-tests/char-aux.lsp | 368 +-- ansi-tests/char-compare.lsp | 242 +- ansi-tests/char-schar.lsp | 36 +- ansi-tests/character.lsp | 62 +- ansi-tests/check-type.lsp | 34 +- ansi-tests/cis.lsp | 36 +- ansi-tests/cl-symbol-names.lsp | 26 +- ansi-tests/cl-symbols-aux.lsp | 24 +- ansi-tests/cl-symbols.lsp | 62 +- ansi-tests/cl-test-package.lsp | 12 +- ansi-tests/class-name.lsp | 10 +- ansi-tests/clear-input.lsp | 4 +- ansi-tests/clear-output.lsp | 12 +- ansi-tests/clrhash.lsp | 12 +- ansi-tests/coerce.lsp | 90 +- ansi-tests/compile-and-load.lsp | 36 +- ansi-tests/compile-file.lsp | 142 +- ansi-tests/compile.lsp | 24 +- ansi-tests/complement.lsp | 46 +- ansi-tests/complex.lsp | 42 +- ansi-tests/compute-applicable-methods.lsp | 44 +- ansi-tests/compute-restarts.lsp | 90 +- ansi-tests/concatenate.lsp | 60 +- ansi-tests/concatenated-stream-streams.lsp | 24 +- ansi-tests/cond.lsp | 22 +- ansi-tests/condition.lsp | 14 +- ansi-tests/conjugate.lsp | 18 +- ansi-tests/cons-aux.lsp | 458 ++-- ansi-tests/cons-test-01.lsp | 94 +- ansi-tests/cons-test-05.lsp | 140 +- ansi-tests/cons.lsp | 6 +- ansi-tests/consp.lsp | 2 +- ansi-tests/constantly.lsp | 6 +- ansi-tests/constantp.lsp | 20 +- ansi-tests/continue.lsp | 6 +- ansi-tests/copy-alist.lsp | 18 +- ansi-tests/copy-list.lsp | 2 +- ansi-tests/copy-pprint-dispatch.lsp | 74 +- ansi-tests/copy-readtable.lsp | 2 +- ansi-tests/copy-seq.lsp | 152 +- ansi-tests/copy-symbol.lsp | 78 +- ansi-tests/copy-tree.lsp | 16 +- ansi-tests/cos.lsp | 102 +- ansi-tests/cosh.lsp | 82 +- ansi-tests/count-if-not.lsp | 246 +-- ansi-tests/count-if.lsp | 272 +-- ansi-tests/count.lsp | 258 +-- ansi-tests/ctypecase.lsp | 26 +- ansi-tests/cxr.lsp | 82 +- ansi-tests/data-and-control-flow.lsp | 10 +- ansi-tests/decf.lsp | 58 +- ansi-tests/declaim.lsp | 2 +- ansi-tests/declaration.lsp | 16 +- ansi-tests/decode-universal-time.lsp | 90 +- ansi-tests/defclass-01.lsp | 146 +- ansi-tests/defclass-02.lsp | 126 +- ansi-tests/defclass-03.lsp | 110 +- ansi-tests/defclass-aux.lsp | 346 +-- ansi-tests/defclass-errors.lsp | 30 +- ansi-tests/defclass-forward-reference.lsp | 182 +- ansi-tests/defconstant.lsp | 20 +- .../defgeneric-method-combination-and.lsp | 152 +- .../defgeneric-method-combination-append.lsp | 158 +- .../defgeneric-method-combination-list.lsp | 150 +- .../defgeneric-method-combination-max.lsp | 150 +- .../defgeneric-method-combination-min.lsp | 150 +- .../defgeneric-method-combination-nconc.lsp | 174 +- .../defgeneric-method-combination-or.lsp | 152 +- .../defgeneric-method-combination-plus.lsp | 150 +- .../defgeneric-method-combination-progn.lsp | 212 +- ansi-tests/defgeneric.lsp | 304 +-- ansi-tests/define-compiler-macro.lsp | 128 +- ansi-tests/define-condition-aux.lsp | 100 +- ansi-tests/define-condition.lsp | 320 +-- .../define-method-combination-long-form.lsp | 14 +- ansi-tests/define-method-combination.lsp | 40 +- ansi-tests/define-modify-macro.lsp | 50 +- ansi-tests/define-setf-expander.lsp | 74 +- ansi-tests/define-symbol-macro.lsp | 16 +- ansi-tests/defmacro.lsp | 168 +- ansi-tests/defmethod.lsp | 44 +- ansi-tests/defpackage.lsp | 636 +++--- ansi-tests/defparameter.lsp | 20 +- ansi-tests/defsetf.lsp | 30 +- ansi-tests/deftype.lsp | 66 +- ansi-tests/defun.lsp | 78 +- ansi-tests/defvar.lsp | 16 +- ansi-tests/delete-file.lsp | 12 +- ansi-tests/delete-package.lsp | 192 +- ansi-tests/deposit-field.lsp | 74 +- ansi-tests/describe.lsp | 44 +- ansi-tests/destructuring-bind.lsp | 26 +- ansi-tests/directory-namestring.lsp | 18 +- ansi-tests/directory.lsp | 22 +- ansi-tests/disassemble.lsp | 8 +- ansi-tests/dispatch-macro-characters.lsp | 40 +- ansi-tests/divide.lsp | 238 +- ansi-tests/do-all-symbols.lsp | 22 +- ansi-tests/do-external-symbols.lsp | 28 +- ansi-tests/do-symbols.lsp | 46 +- ansi-tests/do.lsp | 60 +- ansi-tests/documentation.lsp | 302 +-- ansi-tests/dolist.lsp | 26 +- ansi-tests/dostar.lsp | 60 +- ansi-tests/dotimes.lsp | 24 +- ansi-tests/dpb.lsp | 74 +- ansi-tests/dynamic-extent.lsp | 58 +- ansi-tests/ecase.lsp | 14 +- ansi-tests/echo-stream-input-stream.lsp | 14 +- ansi-tests/echo-stream-output-stream.lsp | 14 +- ansi-tests/elt.lsp | 118 +- ansi-tests/encode-universal-time.lsp | 140 +- ansi-tests/enough-namestring.lsp | 42 +- ansi-tests/ensure-directories-exist.lsp | 100 +- ansi-tests/ensure-generic-function.lsp | 76 +- ansi-tests/environment-functions.lsp | 14 +- ansi-tests/epsilons.lsp | 90 +- ansi-tests/equal.lsp | 34 +- ansi-tests/equalp.lsp | 194 +- ansi-tests/error.lsp | 4 +- ansi-tests/etypecase.lsp | 44 +- ansi-tests/eval-and-compile.lsp | 2 +- ansi-tests/eval-when.lsp | 28 +- ansi-tests/eval.lsp | 6 +- ansi-tests/evenp.lsp | 56 +- ansi-tests/every.lsp | 192 +- ansi-tests/exp-aux.lsp | 4 +- ansi-tests/exp.lsp | 18 +- ansi-tests/export.lsp | 66 +- ansi-tests/expt.lsp | 120 +- ansi-tests/fboundp.lsp | 22 +- ansi-tests/fceiling-aux.lsp | 24 +- ansi-tests/fceiling.lsp | 152 +- ansi-tests/fdefinition.lsp | 24 +- ansi-tests/features.lsp | 4 +- ansi-tests/ffloor-aux.lsp | 24 +- ansi-tests/ffloor.lsp | 152 +- ansi-tests/file-author.lsp | 30 +- ansi-tests/file-error.lsp | 30 +- ansi-tests/file-length.lsp | 138 +- ansi-tests/file-namestring.lsp | 18 +- ansi-tests/file-position.lsp | 130 +- ansi-tests/file-string-length.lsp | 42 +- ansi-tests/file-write-date.lsp | 54 +- ansi-tests/fill-pointer.lsp | 18 +- ansi-tests/fill.lsp | 294 +-- ansi-tests/find-all-symbols.lsp | 86 +- ansi-tests/find-class.lsp | 190 +- ansi-tests/find-if-not.lsp | 258 +-- ansi-tests/find-if.lsp | 260 +-- ansi-tests/find-method.lsp | 14 +- ansi-tests/find-package.lsp | 72 +- ansi-tests/find-symbol.lsp | 50 +- ansi-tests/find.lsp | 266 +-- ansi-tests/finish-output.lsp | 12 +- ansi-tests/flet.lsp | 206 +- ansi-tests/float.lsp | 86 +- ansi-tests/floor-aux.lsp | 164 +- ansi-tests/floor.lsp | 136 +- ansi-tests/fmakunbound.lsp | 58 +- ansi-tests/force-output.lsp | 12 +- ansi-tests/format-a.lsp | 114 +- ansi-tests/format-ampersand.lsp | 94 +- ansi-tests/format-b.lsp | 608 ++--- ansi-tests/format-brace.lsp | 62 +- ansi-tests/format-c.lsp | 122 +- ansi-tests/format-circumflex.lsp | 12 +- ansi-tests/format-conditional.lsp | 48 +- ansi-tests/format-d.lsp | 660 +++--- ansi-tests/format-f.lsp | 500 ++--- ansi-tests/format-justify.lsp | 164 +- ansi-tests/format-logical-block.lsp | 4 +- ansi-tests/format-o.lsp | 612 ++--- ansi-tests/format-p.lsp | 24 +- ansi-tests/format-page.lsp | 20 +- ansi-tests/format-paren.lsp | 114 +- ansi-tests/format-percent.lsp | 54 +- ansi-tests/format-r.lsp | 324 +-- ansi-tests/format-s.lsp | 154 +- ansi-tests/format-slash.lsp | 16 +- ansi-tests/format-t.lsp | 234 +- ansi-tests/format-tilde.lsp | 62 +- ansi-tests/format-underscore.lsp | 78 +- ansi-tests/format-x.lsp | 622 +++--- ansi-tests/formatter-c.lsp | 142 +- ansi-tests/fresh-line.lsp | 10 +- ansi-tests/fround-aux.lsp | 28 +- ansi-tests/fround.lsp | 152 +- ansi-tests/ftruncate-aux.lsp | 28 +- ansi-tests/ftruncate.lsp | 152 +- ansi-tests/funcall.lsp | 12 +- ansi-tests/function-lambda-expression.lsp | 8 +- ansi-tests/function.lsp | 26 +- ansi-tests/functionp.lsp | 26 +- ansi-tests/gcd-aux.lsp | 4 +- ansi-tests/gcd.lsp | 66 +- ansi-tests/gensym.lsp | 2 +- ansi-tests/gentemp.lsp | 138 +- ansi-tests/get-internal-time.lsp | 16 +- ansi-tests/get-macro-character.lsp | 128 +- ansi-tests/get-properties.lsp | 12 +- ansi-tests/get-setf-expansion.lsp | 16 +- ansi-tests/get-universal-time.lsp | 26 +- ansi-tests/get.lsp | 30 +- ansi-tests/getf.lsp | 30 +- ansi-tests/gethash.lsp | 126 +- ansi-tests/handler-bind.lsp | 42 +- ansi-tests/handler-case.lsp | 68 +- ansi-tests/hash-table-aux.lsp | 128 +- ansi-tests/hash-table-count.lsp | 12 +- ansi-tests/hash-table-p.lsp | 10 +- ansi-tests/hash-table-rehash-size.lsp | 18 +- ansi-tests/hash-table-rehash-threshold.lsp | 18 +- ansi-tests/hash-table-size.lsp | 2 +- ansi-tests/hash-table-test.lsp | 20 +- ansi-tests/hash-table.lsp | 18 +- ansi-tests/host-namestring.lsp | 22 +- ansi-tests/if.lsp | 20 +- ansi-tests/ignorable.lsp | 22 +- ansi-tests/ignore-errors.lsp | 4 +- ansi-tests/ignore.lsp | 10 +- ansi-tests/imagpart.lsp | 30 +- ansi-tests/import.lsp | 158 +- ansi-tests/in-package.lsp | 44 +- ansi-tests/incf.lsp | 58 +- ansi-tests/input-stream-p.lsp | 8 +- ansi-tests/integer-length.lsp | 40 +- ansi-tests/integerp.lsp | 8 +- ansi-tests/interactive-stream-p.lsp | 6 +- ansi-tests/intern.lsp | 148 +- ansi-tests/intersection.lsp | 186 +- ansi-tests/invoke-debugger.lsp | 20 +- ansi-tests/isqrt.lsp | 42 +- ansi-tests/keyword.lsp | 24 +- ansi-tests/keywordp.lsp | 6 +- ansi-tests/labels.lsp | 140 +- ansi-tests/lambda-list-keywords.lsp | 18 +- ansi-tests/lambda.lsp | 40 +- ansi-tests/last.lsp | 4 +- ansi-tests/lcm.lsp | 64 +- ansi-tests/ldb.lsp | 58 +- ansi-tests/ldiff.lsp | 56 +- ansi-tests/length.lsp | Bin 3900 -> 4061 bytes ansi-tests/let.lsp | 58 +- ansi-tests/letstar.lsp | 76 +- ansi-tests/list-all-packages.lsp | 16 +- ansi-tests/list-length.lsp | 4 +- ansi-tests/list.lsp | 14 +- ansi-tests/listen.lsp | 2 +- .../load-logical-pathname-translations.lsp | 8 +- ansi-tests/load.lsp | 84 +- ansi-tests/locally.lsp | 2 +- ansi-tests/log.lsp | 136 +- ansi-tests/logand.lsp | 54 +- ansi-tests/logandc1.lsp | 42 +- ansi-tests/logandc2.lsp | 42 +- ansi-tests/logbitp.lsp | 40 +- ansi-tests/logcount.lsp | 28 +- ansi-tests/logeqv.lsp | 58 +- ansi-tests/logical-pathname.lsp | 16 +- ansi-tests/logior.lsp | 48 +- ansi-tests/lognand.lsp | 42 +- ansi-tests/lognor.lsp | 42 +- ansi-tests/lognot.lsp | 16 +- ansi-tests/logorc1.lsp | 44 +- ansi-tests/logorc2.lsp | 44 +- ansi-tests/logtest.lsp | 16 +- ansi-tests/logxor.lsp | 60 +- ansi-tests/loop.lsp | 44 +- ansi-tests/loop1.lsp | 52 +- ansi-tests/loop10.lsp | 100 +- ansi-tests/loop11.lsp | 84 +- ansi-tests/loop12.lsp | 118 +- ansi-tests/loop13.lsp | 32 +- ansi-tests/loop14.lsp | 256 +-- ansi-tests/loop15.lsp | 58 +- ansi-tests/loop16.lsp | 58 +- ansi-tests/loop17.lsp | 6 +- ansi-tests/loop2.lsp | 50 +- ansi-tests/loop3.lsp | 52 +- ansi-tests/loop4.lsp | 14 +- ansi-tests/loop5.lsp | 86 +- ansi-tests/loop6.lsp | 82 +- ansi-tests/loop7.lsp | 114 +- ansi-tests/loop8.lsp | 16 +- ansi-tests/loop9.lsp | 118 +- ansi-tests/macro-function.lsp | 80 +- ansi-tests/macroexpand-1.lsp | 42 +- ansi-tests/macroexpand.lsp | 40 +- ansi-tests/macrolet.lsp | 136 +- ansi-tests/make-array.lsp | 346 +-- ansi-tests/make-broadcast-stream.lsp | 12 +- ansi-tests/make-concatenated-stream.lsp | 80 +- ansi-tests/make-condition.lsp | 38 +- ansi-tests/make-echo-stream.lsp | 182 +- ansi-tests/make-instance.lsp | 102 +- ansi-tests/make-instances-obsolete.lsp | 18 +- ansi-tests/make-list.lsp | 14 +- ansi-tests/make-load-form-saving-slots.lsp | 112 +- ansi-tests/make-load-form.lsp | 120 +- ansi-tests/make-package.lsp | 362 +-- ansi-tests/make-pathname.lsp | 104 +- ansi-tests/make-random-element-of.lsp | 94 +- ansi-tests/make-random-state.lsp | 36 +- ansi-tests/make-sequence.lsp | 234 +- ansi-tests/make-string-input-stream.lsp | 24 +- ansi-tests/make-string-output-stream.lsp | 8 +- ansi-tests/make-string.lsp | 74 +- ansi-tests/make-symbol.lsp | 48 +- ansi-tests/make-two-way-stream.lsp | 122 +- ansi-tests/makunbound.lsp | 6 +- ansi-tests/map-into.lsp | 214 +- ansi-tests/map.lsp | 102 +- ansi-tests/mapc.lsp | 32 +- ansi-tests/mapcan.lsp | 40 +- ansi-tests/mapcar.lsp | 66 +- ansi-tests/mapcon.lsp | 30 +- ansi-tests/maphash.lsp | 70 +- ansi-tests/mapl.lsp | 86 +- ansi-tests/maplist.lsp | 58 +- ansi-tests/mask-field.lsp | 58 +- ansi-tests/max.lsp | 110 +- ansi-tests/member-if-not.lsp | 62 +- ansi-tests/member-if.lsp | 56 +- ansi-tests/member.lsp | 72 +- ansi-tests/merge-pathnames.lsp | 42 +- ansi-tests/merge.lsp | 174 +- ansi-tests/min.lsp | 110 +- ansi-tests/minus.lsp | 156 +- ansi-tests/minusp.lsp | 28 +- ansi-tests/misc-cmucl-type-prop.lsp | 186 +- ansi-tests/misc.lsp | 636 +++--- ansi-tests/mismatch.lsp | 104 +- ansi-tests/modules.lsp | 6 +- ansi-tests/muffle-warning.lsp | 6 +- ansi-tests/multiple-value-bind.lsp | 26 +- ansi-tests/multiple-value-list.lsp | 14 +- ansi-tests/multiple-value-prog1.lsp | 26 +- ansi-tests/multiple-value-setq.lsp | 34 +- ansi-tests/name-char.lsp | 78 +- ansi-tests/namestring.lsp | 40 +- ansi-tests/nbutlast.lsp | 20 +- ansi-tests/nconc.lsp | 24 +- ansi-tests/nintersection.lsp | 138 +- ansi-tests/no-next-method.lsp | 18 +- ansi-tests/not-and-null.lsp | 8 +- ansi-tests/notany.lsp | 188 +- ansi-tests/notevery.lsp | 186 +- ansi-tests/nreconc.lsp | 8 +- ansi-tests/nreverse.lsp | 54 +- ansi-tests/nset-difference.lsp | 80 +- ansi-tests/nset-exclusive-or.lsp | 194 +- ansi-tests/nstring-capitalize.lsp | 70 +- ansi-tests/nstring-downcase.lsp | 76 +- ansi-tests/nstring-upcase.lsp | 80 +- ansi-tests/nsublis.lsp | 86 +- ansi-tests/nsubst-if-not.lsp | 16 +- ansi-tests/nsubst-if.lsp | 22 +- ansi-tests/nsubst.lsp | 40 +- ansi-tests/nsubstitute-if-not.lsp | 442 ++-- ansi-tests/nsubstitute-if.lsp | 424 ++-- ansi-tests/nsubstitute.lsp | 592 ++--- ansi-tests/nth-value.lsp | 20 +- ansi-tests/nth.lsp | 8 +- ansi-tests/nthcdr.lsp | 2 +- ansi-tests/number-comparison.lsp | 1968 ++++++++--------- ansi-tests/numbers-aux.lsp | 382 ++-- ansi-tests/numerator-denominator.lsp | 90 +- ansi-tests/nunion.lsp | 200 +- ansi-tests/oddp.lsp | 56 +- ansi-tests/oneminus.lsp | 164 +- ansi-tests/oneplus.lsp | 164 +- ansi-tests/open-stream-p.lsp | 20 +- ansi-tests/open.lsp | 758 +++---- ansi-tests/optimize.lsp | 26 +- ansi-tests/or.lsp | 4 +- ansi-tests/output-stream-p.lsp | 6 +- ansi-tests/package-aux.lsp | 174 +- ansi-tests/package-error-package.lsp | 16 +- ansi-tests/package-error.lsp | 10 +- ansi-tests/package-name.lsp | 46 +- ansi-tests/package-nicknames.lsp | 44 +- ansi-tests/package-shadowing-symbols.lsp | 26 +- ansi-tests/package-use-list.lsp | 26 +- ansi-tests/package-used-by-list.lsp | 26 +- ansi-tests/pairlis.lsp | 36 +- ansi-tests/parse-integer.lsp | 74 +- ansi-tests/parse-namestring.lsp | 42 +- ansi-tests/pathname-device.lsp | 52 +- ansi-tests/pathname-directory.lsp | 80 +- ansi-tests/pathname-host.lsp | 36 +- ansi-tests/pathname-match-p.lsp | 30 +- ansi-tests/pathname-name.lsp | 52 +- ansi-tests/pathname-type.lsp | 52 +- ansi-tests/pathname-version.lsp | 12 +- ansi-tests/pathname.lsp | 48 +- ansi-tests/pathnamep.lsp | 2 +- ansi-tests/pathnames-aux.lsp | 6 +- ansi-tests/pathnames.lsp | 2 +- ansi-tests/pattern-match.lsp | 76 +- ansi-tests/peek-char.lsp | 82 +- ansi-tests/phase.lsp | 14 +- ansi-tests/places.lsp | 42 +- ansi-tests/plus.lsp | 354 +-- ansi-tests/plusp.lsp | 28 +- ansi-tests/pop.lsp | 4 +- ansi-tests/position-if-not.lsp | 194 +- ansi-tests/position-if.lsp | 198 +- ansi-tests/position.lsp | 252 +-- ansi-tests/pprint-dispatch.lsp | 334 +-- ansi-tests/pprint-exit-if-list-exhausted.lsp | 362 +-- ansi-tests/pprint-fill.lsp | 138 +- ansi-tests/pprint-indent.lsp | 350 +-- ansi-tests/pprint-linear.lsp | 140 +- ansi-tests/pprint-logical-block.lsp | 252 +-- ansi-tests/pprint-newline.lsp | 80 +- ansi-tests/pprint-tab.lsp | 118 +- ansi-tests/pprint-tabular.lsp | 66 +- ansi-tests/pprint.lsp | 2 +- ansi-tests/prin1.lsp | 2 +- ansi-tests/princ.lsp | 2 +- ansi-tests/print-array.lsp | 386 ++-- ansi-tests/print-backquote.lsp | 60 +- ansi-tests/print-bit-vector.lsp | 24 +- ansi-tests/print-characters.lsp | 96 +- ansi-tests/print-complex.lsp | 34 +- ansi-tests/print-cons.lsp | 66 +- ansi-tests/print-floats.lsp | 506 ++--- ansi-tests/print-integers.lsp | 74 +- ansi-tests/print-length.lsp | 98 +- ansi-tests/print-level.lsp | 58 +- ansi-tests/print-lines.lsp | 22 +- ansi-tests/print-pathname.lsp | 34 +- ansi-tests/print-random-state.lsp | 18 +- ansi-tests/print-ratios.lsp | 12 +- ansi-tests/print-strings.lsp | 106 +- ansi-tests/print-structure.lsp | 36 +- ansi-tests/print-symbols.lsp | 746 +++---- ansi-tests/print-unreadable-object.lsp | 114 +- ansi-tests/print-vector.lsp | 346 +-- ansi-tests/print.lsp | 2 +- ansi-tests/printer-aux.lsp | 422 ++-- ansi-tests/probe-file.lsp | 10 +- ansi-tests/proclaim.lsp | 2 +- ansi-tests/prog.lsp | 92 +- ansi-tests/progn.lsp | 10 +- ansi-tests/progv.lsp | 38 +- ansi-tests/psetf.lsp | 192 +- ansi-tests/psetq.lsp | 22 +- ansi-tests/push.lsp | 6 +- ansi-tests/pushnew.lsp | 92 +- ansi-tests/random-aux.lsp | 198 +- ansi-tests/random-class-aux.lsp | 42 +- ansi-tests/random-int-form.lsp | 830 +++---- ansi-tests/random-intern.lsp | 26 +- ansi-tests/random-type-prop-tests-01.lsp | 12 +- ansi-tests/random-type-prop-tests-02.lsp | 40 +- ansi-tests/random-type-prop-tests-03.lsp | 6 +- ansi-tests/random-type-prop-tests-05.lsp | 230 +- ansi-tests/random-type-prop-tests-06.lsp | 24 +- ansi-tests/random-type-prop-tests-07.lsp | 140 +- ansi-tests/random-type-prop-tests-08.lsp | 270 +-- ansi-tests/random-type-prop-tests-09.lsp | 480 ++-- ansi-tests/random-type-prop-tests-10.lsp | 118 +- ansi-tests/random-type-prop-tests-structs.lsp | 32 +- ansi-tests/random-type-prop.lsp | 564 ++--- ansi-tests/random-types.lsp | 502 ++--- ansi-tests/random.lsp | 66 +- ansi-tests/rassoc-if-not.lsp | 30 +- ansi-tests/rassoc-if.lsp | 26 +- ansi-tests/rassoc.lsp | 150 +- ansi-tests/rational.lsp | 46 +- ansi-tests/rationalize.lsp | 44 +- ansi-tests/rationalp.lsp | 16 +- ansi-tests/read-byte.lsp | 158 +- ansi-tests/read-char-no-hang.lsp | 6 +- ansi-tests/read-char.lsp | 6 +- ansi-tests/read-from-string.lsp | 54 +- ansi-tests/read-preserving-whitespace.lsp | 6 +- ansi-tests/read-sequence.lsp | 78 +- ansi-tests/read-suppress.lsp | 62 +- ansi-tests/read.lsp | 6 +- ansi-tests/reader-aux.lsp | 6 +- ansi-tests/reader-test.lsp | 272 +-- ansi-tests/readtable-case.lsp | 16 +- ansi-tests/readtablep.lsp | 46 +- ansi-tests/real.lsp | 80 +- ansi-tests/realpart.lsp | 34 +- ansi-tests/reduce.lsp | 146 +- ansi-tests/reinitialize-instance.lsp | 40 +- ansi-tests/remf.lsp | 10 +- ansi-tests/remhash.lsp | 48 +- ansi-tests/remove-aux.lsp | 338 +-- ansi-tests/remove-duplicates-aux.lsp | 88 +- ansi-tests/remove-duplicates.lsp | 110 +- ansi-tests/remove-method.lsp | 42 +- ansi-tests/remove.lsp | 222 +- ansi-tests/rename-file.lsp | 228 +- ansi-tests/rename-package.lsp | 282 +-- ansi-tests/replace.lsp | 226 +- ansi-tests/restart-bind.lsp | 64 +- ansi-tests/restart-case.lsp | 68 +- ansi-tests/return.lsp | 8 +- ansi-tests/revappend.lsp | 20 +- ansi-tests/reverse.lsp | 66 +- ansi-tests/room.lsp | 16 +- ansi-tests/rotatef.lsp | 206 +- ansi-tests/round-aux.lsp | 178 +- ansi-tests/round.lsp | 136 +- ansi-tests/row-major-aref.lsp | 10 +- ansi-tests/rplaca.lsp | 10 +- ansi-tests/rplacd.lsp | 10 +- ansi-tests/rt-package.lsp | 46 +- ansi-tests/rt-test.lsp | 58 +- ansi-tests/rt.system | 10 +- ansi-tests/sbit.lsp | 24 +- ansi-tests/search-aux.lsp | 52 +- ansi-tests/search-bitvector.lsp | 150 +- ansi-tests/search-list.lsp | 130 +- ansi-tests/search-string.lsp | 122 +- ansi-tests/search-vector.lsp | 154 +- ansi-tests/set-difference.lsp | 70 +- ansi-tests/set-exclusive-or.lsp | 194 +- ansi-tests/set-macro-character.lsp | 54 +- ansi-tests/set-syntax-from-char.lsp | 738 +++---- ansi-tests/set.lsp | 4 +- ansi-tests/shadow.lsp | 346 +-- ansi-tests/shadowing-import.lsp | 144 +- ansi-tests/shared-initialize.lsp | 96 +- ansi-tests/shiftf.lsp | 16 +- ansi-tests/signum.lsp | 54 +- ansi-tests/simple-array-t.lsp | 6 +- ansi-tests/simple-array.lsp | 6 +- ansi-tests/simple-bit-vector-p.lsp | 4 +- ansi-tests/simple-bit-vector.lsp | 6 +- ansi-tests/simple-string-p.lsp | 20 +- ansi-tests/sin.lsp | 102 +- ansi-tests/sinh.lsp | 78 +- ansi-tests/slot-boundp.lsp | 22 +- ansi-tests/slot-exists-p.lsp | 22 +- ansi-tests/slot-makunbound.lsp | 60 +- ansi-tests/slot-missing.lsp | 16 +- ansi-tests/slot-unbound.lsp | 4 +- ansi-tests/slot-value.lsp | 74 +- ansi-tests/some.lsp | 190 +- ansi-tests/sort-aux.lsp | 8 +- ansi-tests/sort.lsp | 76 +- ansi-tests/special-operator-p.lsp | 22 +- ansi-tests/special.lsp | 4 +- ansi-tests/sqrt.lsp | 206 +- ansi-tests/stable-sort.lsp | 60 +- ansi-tests/standard-generic-function.lsp | 16 +- ansi-tests/store-value.lsp | 6 +- ansi-tests/stream-element-type.lsp | 96 +- ansi-tests/stream-error-stream.lsp | 2 +- ansi-tests/streamp.lsp | 16 +- ansi-tests/string-aux.lsp | 196 +- ansi-tests/string-capitalize.lsp | 40 +- ansi-tests/string-comparisons.lsp | 428 ++-- ansi-tests/string-downcase.lsp | 44 +- ansi-tests/string-left-trim.lsp | 110 +- ansi-tests/string-right-trim.lsp | 110 +- ansi-tests/string-trim.lsp | 112 +- ansi-tests/string-upcase.lsp | 46 +- ansi-tests/string.lsp | 46 +- ansi-tests/stringp.lsp | 30 +- ansi-tests/structure-00.lsp | 722 +++--- ansi-tests/structures-01.lsp | 2 +- ansi-tests/structures-02.lsp | 78 +- ansi-tests/structures-03.lsp | 86 +- ansi-tests/structures-04.lsp | 6 +- ansi-tests/sublis.lsp | 92 +- ansi-tests/subseq-aux.lsp | 152 +- ansi-tests/subseq.lsp | 152 +- ansi-tests/subsetp.lsp | 114 +- ansi-tests/subst-if-not.lsp | 20 +- ansi-tests/subst-if.lsp | 18 +- ansi-tests/subst.lsp | 40 +- ansi-tests/substitute-if-not.lsp | 522 ++--- ansi-tests/substitute-if.lsp | 562 ++--- ansi-tests/substitute.lsp | 746 +++---- ansi-tests/subtypep-array.lsp | 114 +- ansi-tests/subtypep-complex.lsp | 126 +- ansi-tests/subtypep-cons.lsp | 154 +- ansi-tests/subtypep-eql.lsp | 12 +- ansi-tests/subtypep-float.lsp | 88 +- ansi-tests/subtypep-integer.lsp | 134 +- ansi-tests/subtypep-member.lsp | 30 +- ansi-tests/subtypep-rational.lsp | 152 +- ansi-tests/subtypep-real.lsp | 148 +- ansi-tests/subtypep.lsp | 72 +- ansi-tests/svref.lsp | 10 +- ansi-tests/sxhash.lsp | 276 +-- ansi-tests/symbol-function.lsp | 12 +- ansi-tests/symbol-macrolet.lsp | 28 +- ansi-tests/synonym-stream-symbol.lsp | 6 +- ansi-tests/syntax-tokens.lsp | 66 +- ansi-tests/syntax.lsp | 396 ++-- ansi-tests/tagbody.lsp | 30 +- ansi-tests/tailp.lsp | 22 +- ansi-tests/tan.lsp | 76 +- ansi-tests/tanh.lsp | 72 +- ansi-tests/the.lsp | 42 +- ansi-tests/time.lsp | 50 +- ansi-tests/times-aux.lsp | 2 +- ansi-tests/times.lsp | 394 ++-- ansi-tests/trace.lsp | 58 +- ansi-tests/translate-logical-pathname.lsp | 30 +- ansi-tests/tree-equal.lsp | 24 +- ansi-tests/truename.lsp | 36 +- ansi-tests/truncate-aux.lsp | 174 +- ansi-tests/truncate.lsp | 136 +- ansi-tests/two-way-stream-input-stream.lsp | 14 +- ansi-tests/two-way-stream-output-stream.lsp | 14 +- ansi-tests/type-of.lsp | 62 +- ansi-tests/type.lsp | 50 +- ansi-tests/typecase.lsp | 42 +- ansi-tests/typep.lsp | 30 +- ansi-tests/types-and-class-2.lsp | 46 +- ansi-tests/types-and-class.lsp | 160 +- ansi-tests/types-aux.lsp | 110 +- ansi-tests/unbound-slot.lsp | 16 +- ansi-tests/unexport.lsp | 176 +- ansi-tests/unintern.lsp | 292 +-- ansi-tests/union.lsp | 142 +- ansi-tests/universe.lsp | 346 +-- ansi-tests/unless.lsp | 8 +- ansi-tests/unread-char.lsp | 2 +- ansi-tests/unuse-package.lsp | 288 +-- ansi-tests/unwind-protect.lsp | 52 +- .../update-instance-for-different-class.lsp | 30 +- ansi-tests/upgraded-array-element-type.lsp | 66 +- ansi-tests/upgraded-complex-part-type.lsp | 96 +- ansi-tests/use-package.lsp | 244 +- ansi-tests/use-value.lsp | 6 +- ansi-tests/user-homedir-pathname.lsp | 8 +- ansi-tests/values-list.lsp | 10 +- ansi-tests/values.lsp | 14 +- ansi-tests/vector-pop.lsp | 20 +- ansi-tests/vector-push-extend.lsp | 424 ++-- ansi-tests/vector-push.lsp | 114 +- ansi-tests/vector.lsp | 32 +- ansi-tests/warn.lsp | 74 +- ansi-tests/when.lsp | 8 +- ansi-tests/wild-pathname-p.lsp | 74 +- ansi-tests/with-accessors.lsp | 22 +- ansi-tests/with-compilation-unit.lsp | 10 +- ansi-tests/with-condition-restarts.lsp | 10 +- ansi-tests/with-hash-table-iterator.lsp | 110 +- ansi-tests/with-input-from-string.lsp | 24 +- ansi-tests/with-open-file.lsp | 16 +- ansi-tests/with-open-stream.lsp | 18 +- ansi-tests/with-output-to-string.lsp | 52 +- ansi-tests/with-package-iterator.lsp | 76 +- ansi-tests/with-slots.lsp | 72 +- ansi-tests/write-char.lsp | 14 +- ansi-tests/write-line.lsp | 30 +- ansi-tests/write-sequence.lsp | 64 +- ansi-tests/write-string.lsp | 30 +- ansi-tests/write.lsp | 6 +- ansi-tests/zerop.lsp | 52 +- 739 files changed, 35501 insertions(+), 35501 deletions(-) diff --git a/ansi-tests/abort.lsp b/ansi-tests/abort.lsp index 0c65eedc..f249953e 100644 --- a/ansi-tests/abort.lsp +++ b/ansi-tests/abort.lsp @@ -13,7 +13,7 @@ (deftest abort.2 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 @@ -31,7 +31,7 @@ (deftest abort.4 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 @@ -44,7 +44,7 @@ (deftest abort.5 (signals-error (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) diff --git a/ansi-tests/abs.lsp b/ansi-tests/abs.lsp index dcbcf20b..ca0ddc11 100644 --- a/ansi-tests/abs.lsp +++ b/ansi-tests/abs.lsp @@ -21,36 +21,36 @@ (deftest abs.1 (loop for x in *numbers* - for a = (abs x) - always (and (realp a) (not (minusp a)))) + for a = (abs x) + always (and (realp a) (not (minusp a)))) t) (deftest abs.2 (loop for x = (random-fixnum) - for a = (abs x) - repeat 10000 - unless (if (plusp x) (eql x a) (eql (- x) a)) - collect (list x a)) + for a = (abs x) + repeat 10000 + unless (if (plusp x) (eql x a) (eql (- x) a)) + collect (list x a)) nil) (deftest abs.3 (let ((bound (ash 1 300))) (loop for x = (random-from-interval bound) - for a = (abs x) - repeat 10000 - unless (if (plusp x) (eql x a) (eql (- x) a)) - collect (list x a))) + for a = (abs x) + repeat 10000 + unless (if (plusp x) (eql x a) (eql (- x) a)) + collect (list x a))) nil) (deftest abs.4 (loop for num = (random-fixnum) - for den = (random-fixnum) - for den2 = (if (zerop den) 1 den) - for r = (/ num den) - for a = (abs r) - repeat 10000 - unless (if (>= r 0) (eql r a) (eql (- r) a)) - collect (list num den2 r a)) + for den = (random-fixnum) + for den2 = (if (zerop den) 1 den) + for r = (/ num den) + for a = (abs r) + repeat 10000 + unless (if (>= r 0) (eql r a) (eql (- r) a)) + collect (list num den2 r a)) nil) (deftest abs.5 @@ -73,8 +73,8 @@ for a = (abs x) repeat 10000 unless (if (minusp x) - (eql (- x) a) - (eql x a)) + (eql (- x) a) + (eql x a)) collect (list x a))) nil) @@ -85,8 +85,8 @@ for a = (abs x) repeat 10000 unless (if (minusp x) - (eql (- x) a) - (eql x a)) + (eql (- x) a) + (eql x a)) collect (list x a))) nil) @@ -97,8 +97,8 @@ for a = (abs x) repeat 10000 unless (if (minusp x) - (eql (- x) a) - (eql x a)) + (eql (- x) a) + (eql x a)) collect (list x a))) nil) @@ -109,8 +109,8 @@ for a = (abs x) repeat 10000 unless (if (minusp x) - (eql (- x) a) - (eql x a)) + (eql (- x) a) + (eql x a)) collect (list x a))) nil) @@ -122,15 +122,15 @@ ;;; (deftest abs.10 ;;; (abs -0.0s0) ;;; -0.0s0) -;;; +;;; ;;; (deftest abs.11 ;;; (abs -0.0f0) ;;; -0.0f0) -;;; +;;; ;;; (deftest abs.12 ;;; (abs -0.0d0) ;;; -0.0d0) -;;; +;;; ;;; (deftest abs.13 ;;; (abs -0.0l0) ;;; -0.0l0) @@ -175,5 +175,5 @@ (deftest abs.22 (macrolet ((%m (z) z)) - (abs (expand-in-current-env (%m -4)))) + (abs (expand-in-current-env (%m -4)))) 4) diff --git a/ansi-tests/acons.lsp b/ansi-tests/acons.lsp index 7e563878..f6da8ea5 100644 --- a/ansi-tests/acons.lsp +++ b/ansi-tests/acons.lsp @@ -9,8 +9,8 @@ (deftest acons.1 (let* ((x (copy-tree '((c . d) (e . f)))) - (xcopy (make-scaffold-copy x)) - (result (acons 'a 'b x))) + (xcopy (make-scaffold-copy x)) + (result (acons 'a 'b x))) (and (check-scaffold-copy x xcopy) (eqt (cdr result) x) @@ -53,8 +53,8 @@ (let ((i 0) x y z) (values (acons (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) 'b) - (progn (setf z (incf i)) '((c . d)))) + (progn (setf y (incf i)) 'b) + (progn (setf z (incf i)) '((c . d)))) i x y z)) ((a . b)(c . d)) 3 1 2 3) diff --git a/ansi-tests/acos.lsp b/ansi-tests/acos.lsp index 829478e3..99446825 100644 --- a/ansi-tests/acos.lsp +++ b/ansi-tests/acos.lsp @@ -7,50 +7,50 @@ (deftest acos.1 (loop for i from -1000 to 1000 - for rlist = (multiple-value-list (acos i)) - for y = (car rlist) - always (and (null (cdr rlist)) - (numberp y))) + for rlist = (multiple-value-list (acos i)) + for y = (car rlist) + always (and (null (cdr rlist)) + (numberp y))) t) (deftest acos.2 (loop for type in '(short-float single-float double-float long-float) - collect - (let ((a (coerce 2000 type)) - (b (coerce -1000 type))) - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (acos x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (numberp y))))) + collect + (let ((a (coerce 2000 type)) + (b (coerce -1000 type))) + (loop for x = (- (random a) b) + for rlist = (multiple-value-list (acos x)) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (numberp y))))) (t t t t)) (deftest acos.3 (loop for type in '(integer short-float single-float double-float long-float) - collect - (let ((a (coerce 2000 type)) - (b (coerce -1000 type))) - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (acos (complex 0 x))) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (numberp y))))) + collect + (let ((a (coerce 2000 type)) + (b (coerce -1000 type))) + (loop for x = (- (random a) b) + for rlist = (multiple-value-list (acos (complex 0 x))) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (numberp y))))) (t t t t t)) (deftest acos.4 (loop for type in '(integer short-float single-float double-float long-float) - collect - (let ((a (coerce 2000 type)) - (b (coerce -1000 type))) - (loop for x1 = (- (random a) b) - for x2 = (- (random a) b) - for rlist = (multiple-value-list (acos (complex x1 x2))) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (numberp y))))) + collect + (let ((a (coerce 2000 type)) + (b (coerce -1000 type))) + (loop for x1 = (- (random a) b) + for x2 = (- (random a) b) + for rlist = (multiple-value-list (acos (complex x1 x2))) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (numberp y))))) (t t t t t)) (deftest acos.5 @@ -59,23 +59,23 @@ (deftest acos.6 (loop for type in '(single-float short-float double-float long-float) - unless (approx= (acos (coerce 0 type)) - (coerce (/ pi 2) type)) - collect type) + unless (approx= (acos (coerce 0 type)) + (coerce (/ pi 2) type)) + collect type) nil) (deftest acos.7 (loop for type in '(single-float short-float double-float long-float) - unless (approx= (acos (coerce 1 type)) - (coerce 0 type)) - collect type) + unless (approx= (acos (coerce 1 type)) + (coerce 0 type)) + collect type) nil) (deftest acos.8 (loop for type in '(single-float short-float double-float long-float) - unless (approx= (acos (coerce -1 type)) - (coerce pi type)) - collect type) + unless (approx= (acos (coerce -1 type)) + (coerce pi type)) + collect type) nil) (deftest acos.9 diff --git a/ansi-tests/acosh.lsp b/ansi-tests/acosh.lsp index 058bf21e..1425e723 100644 --- a/ansi-tests/acosh.lsp +++ b/ansi-tests/acosh.lsp @@ -8,64 +8,64 @@ (deftest acosh.1 (let ((result (acosh 1))) (or (eqlt result 0) - (eqlt result 0.0))) + (eqlt result 0.0))) t) (deftest acosh.2 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - for one = (coerce 1 type) - unless (equal (multiple-value-list (acosh one)) - (list zero)) - collect type) + for zero = (coerce 0 type) + for one = (coerce 1 type) + unless (equal (multiple-value-list (acosh one)) + (list zero)) + collect type) nil) (deftest acosh.3 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 `(complex ,type)) - for one = (coerce 1 `(complex ,type)) - unless (equal (multiple-value-list (acosh one)) - (list zero)) - collect type) + for zero = (coerce 0 `(complex ,type)) + for one = (coerce 1 `(complex ,type)) + unless (equal (multiple-value-list (acosh one)) + (list zero)) + collect type) nil) (deftest acosh.4 (loop for den = (1+ (random 10000)) - for num = (random (* 10 den)) - for x = (/ num den) - for rlist = (multiple-value-list (acosh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (numberp y)) - collect (list x rlist)) + for num = (random (* 10 den)) + for x = (/ num den) + for rlist = (multiple-value-list (acosh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (numberp y)) + collect (list x rlist)) nil) (deftest acosh.5 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (1+ (random (coerce 1000 type))) - for rlist = (multiple-value-list (acosh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) + nconc + (loop + for x = (1+ (random (coerce 1000 type))) + for rlist = (multiple-value-list (acosh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y type)) + collect (list x rlist))) nil) (deftest acosh.6 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 20 type)) 10) - for x2 = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (acosh (complex x1 x2))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 x2 rlist))) + nconc + (loop + for x1 = (- (random (coerce 20 type)) 10) + for x2 = (- (random (coerce 20 type)) 10) + for rlist = (multiple-value-list (acosh (complex x1 x2))) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y `(complex ,type))) + collect (list x1 x2 rlist))) nil) (deftest acosh.7 @@ -93,8 +93,8 @@ - - - + + + diff --git a/ansi-tests/add-method.lsp b/ansi-tests/add-method.lsp index 491d38b9..75e0fef7 100644 --- a/ansi-tests/add-method.lsp +++ b/ansi-tests/add-method.lsp @@ -23,9 +23,9 @@ (deftest add-method.error.2 (let* ((gf (eval '(defgeneric add-method-gf-03 (x) - (:method ((x t)) 'a)))) - (method (find-method #'add-method-gf-03 nil (list (find-class t)))) - (gf2 (eval '(defgeneric add-method-gf-04 (x y))))) + (:method ((x t)) 'a)))) + (method (find-method #'add-method-gf-03 nil (list (find-class t)))) + (gf2 (eval '(defgeneric add-method-gf-04 (x y))))) (handler-case (add-method gf2 method) (error () :error))) @@ -33,9 +33,9 @@ (deftest add-method.error.3 (let* ((gf (eval '(defgeneric add-method-gf-05 (x &optional y) - (:method ((x t) &optional y) 'a)))) - (method (find-method #'add-method-gf-05 nil (list (find-class t)))) - (gf2 (eval '(defgeneric add-method-gf-06 (x y))))) + (:method ((x t) &optional y) 'a)))) + (method (find-method #'add-method-gf-05 nil (list (find-class t)))) + (gf2 (eval '(defgeneric add-method-gf-06 (x y))))) (handler-case (add-method gf2 method) (error () :error))) @@ -52,9 +52,9 @@ (deftest add-method.error.6 (signals-error (let* ((gf (eval '(defgeneric add-method-gf-07 (x) - (:method ((x t)) 'a)))) - (method (find-method #'add-method-gf-07 nil (list (find-class t)))) - (gf2 (eval '(defgeneric add-method-gf-08 (x))))) + (:method ((x t)) 'a)))) + (method (find-method #'add-method-gf-07 nil (list (find-class t)))) + (gf2 (eval '(defgeneric add-method-gf-08 (x))))) (remove-method gf method) (add-method gf2 method nil)) program-error) @@ -62,10 +62,10 @@ (deftest add-method.error.7 (let* ((gf (eval '(defgeneric add-method-gf-09 (x y) - (:method ((x t) (y t)) 'a)))) - (method (find-method #'add-method-gf-09 nil (list (find-class t) - (find-class t)))) - (gf2 (eval '(defgeneric add-method-gf-10 (x &optional y))))) + (:method ((x t) (y t)) 'a)))) + (method (find-method #'add-method-gf-09 nil (list (find-class t) + (find-class t)))) + (gf2 (eval '(defgeneric add-method-gf-10 (x &optional y))))) (remove-method gf method) (handler-case (add-method gf2 method) @@ -74,9 +74,9 @@ (deftest add-method.error.8 (let* ((gf (eval '(defgeneric add-method-gf-11 (x &key y) - (:method ((x t) &key y) 'a)))) - (method (find-method #'add-method-gf-11 nil (list (find-class t)))) - (gf2 (eval '(defgeneric add-method-gf-12 (x))))) + (:method ((x t) &key y) 'a)))) + (method (find-method #'add-method-gf-11 nil (list (find-class t)))) + (gf2 (eval '(defgeneric add-method-gf-12 (x))))) (remove-method gf method) (handler-case (add-method gf2 method) @@ -88,11 +88,11 @@ (deftest add-method.1 (let* ((gf (eval '(defgeneric add-method-gf-13 (x) - (:method ((x integer)) 'a) - (:method ((x t)) 'b)))) - (method (find-method #'add-method-gf-13 - nil (list (find-class 'integer)))) - (gf2 (eval '(defgeneric add-method-gf-14 (x))))) + (:method ((x integer)) 'a) + (:method ((x t)) 'b)))) + (method (find-method #'add-method-gf-13 + nil (list (find-class 'integer)))) + (gf2 (eval '(defgeneric add-method-gf-14 (x))))) (declare (type generic-function gf gf2)) (values (funcall gf 0) @@ -108,14 +108,14 @@ (deftest add-method.2 (let* ((specializers (list (find-class 'integer))) - (gf (eval '(defgeneric add-method-gf-15 (x) - (:method ((x integer)) 'a) - (:method ((x t)) 'b)))) - (method (find-method gf nil specializers)) - (gf2 (eval '(defgeneric add-method-gf-16 (x) - (:method ((x integer)) 'c) - (:method ((x t)) 'd)))) - (method2 (find-method gf2 nil specializers))) + (gf (eval '(defgeneric add-method-gf-15 (x) + (:method ((x integer)) 'a) + (:method ((x t)) 'b)))) + (method (find-method gf nil specializers)) + (gf2 (eval '(defgeneric add-method-gf-16 (x) + (:method ((x integer)) 'c) + (:method ((x t)) 'd)))) + (method2 (find-method gf2 nil specializers))) (declare (type generic-function gf gf2)) (values (funcall gf 0) diff --git a/ansi-tests/adjoin.lsp b/ansi-tests/adjoin.lsp index abc61c49..c5b5a3c6 100644 --- a/ansi-tests/adjoin.lsp +++ b/ansi-tests/adjoin.lsp @@ -55,35 +55,35 @@ (deftest adjoin.12 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test-not (complement #'equal)) + :test-not (complement #'equal)) (aaa "AAA" "aaa" #\a)) (deftest adjoin.14 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test #'equal :key #'identity) + :test #'equal :key #'identity) (aaa "AAA" "aaa" #\a)) (deftest adjoin.15 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test 'equal :key #'identity) + :test 'equal :key #'identity) (aaa "AAA" "aaa" #\a)) ;; Test that a :key of NIL is the same as no key at all (deftest adjoin.16 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test #'equal :key nil) + :test #'equal :key nil) (aaa "AAA" "aaa" #\a)) ;; Test that a :key of NIL is the same as no key at all (deftest adjoin.17 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test 'equal :key nil) + :test 'equal :key nil) (aaa "AAA" "aaa" #\a)) ;; Test that a :key of NIL is the same as no key at all (deftest adjoin.18 (adjoin (copy-seq "aaa") '(aaa "AAA" "aaa" #\a) - :test-not (complement #'equal) :key nil) + :test-not (complement #'equal) :key nil) (aaa "AAA" "aaa" #\a)) ;;; Ordering in comparison function @@ -113,15 +113,15 @@ (deftest adjoin.24 (macrolet ((%m (z) z)) - (values - (adjoin (expand-in-current-env (%m 'a)) '(b c)) - (adjoin 'a (expand-in-current-env (%m '(b c)))) - (adjoin 'a '(b c) (expand-in-current-env (%m :test)) 'eql) - (adjoin 'a '(a a) (expand-in-current-env (%m :test-not)) 'eql) - (adjoin 'a '(b c) :test (expand-in-current-env (%m 'eql))) - (adjoin 'a '(b c) :test (expand-in-current-env (%m #'eql))) - (adjoin 1 '(1 2 3) :key (expand-in-current-env (%m 'identity))) - )) + (values + (adjoin (expand-in-current-env (%m 'a)) '(b c)) + (adjoin 'a (expand-in-current-env (%m '(b c)))) + (adjoin 'a '(b c) (expand-in-current-env (%m :test)) 'eql) + (adjoin 'a '(a a) (expand-in-current-env (%m :test-not)) 'eql) + (adjoin 'a '(b c) :test (expand-in-current-env (%m 'eql))) + (adjoin 'a '(b c) :test (expand-in-current-env (%m #'eql))) + (adjoin 1 '(1 2 3) :key (expand-in-current-env (%m 'identity))) + )) (a b c) (a b c) (a b c) @@ -140,9 +140,9 @@ (let ((i 0) w x y z) (values (adjoin (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) '(b c d a e)) - :key (progn (setf y (incf i)) #'identity) - :test (progn (setf z (incf i)) #'eql)) + (progn (setf x (incf i)) '(b c d a e)) + :key (progn (setf y (incf i)) #'identity) + :test (progn (setf z (incf i)) #'eql)) i w x y z)) (b c d a e) 4 1 2 3 4) @@ -151,10 +151,10 @@ (let ((i 0) w x y z p) (values (adjoin (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) '(b c d e)) - :test-not (progn (setf y (incf i)) (complement #'eql)) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf p (incf i)) nil)) + (progn (setf x (incf i)) '(b c d e)) + :test-not (progn (setf y (incf i)) (complement #'eql)) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf p (incf i)) nil)) i w x y z p)) (a b c d e) 5 1 2 3 4 5) diff --git a/ansi-tests/adjust-array.lsp b/ansi-tests/adjust-array.lsp index 14cc37b2..11009de6 100644 --- a/ansi-tests/adjust-array.lsp +++ b/ansi-tests/adjust-array.lsp @@ -10,41 +10,41 @@ ((integerp form) `'(,form)) ((null form) nil) ((and (consp form) - (eq (car form) 'quote) - (consp (cadr form))) + (eq (car form) 'quote) + (consp (cadr form))) form) (t `(let ((x ,form)) (if (listp x) x (list x)))))) - + (defmacro def-adjust-array-test (name args1 args2 expected-result) `(deftest ,name (let* ((a1 (make-array ,@args1)) - (a2 (adjust-array a1 ,@args2))) + (a2 (adjust-array a1 ,@args2))) (assert (or (not (adjustable-array-p a1)) (eq a1 a2))) (assert (or (adjustable-array-p a1) - (equal (array-dimensions a1) ,(listify-form (first args1))))) + (equal (array-dimensions a1) ,(listify-form (first args1))))) (assert (equal (array-dimensions a2) ,(listify-form (first args2)))) ,@(unless (or (member :displaced-to args1) - (member :displaced-to args2)) - (list '(assert (not (array-displacement a2))))) + (member :displaced-to args2)) + (list '(assert (not (array-displacement a2))))) a2) ,expected-result)) (defmacro def-adjust-array-fp-test (name args1 args2 misc &rest expected-results) `(deftest ,name (let* ((a1 (make-array ,@args1)) - (a2 (adjust-array a1 ,@args2))) + (a2 (adjust-array a1 ,@args2))) (assert (or (not (adjustable-array-p a1)) (eq a1 a2))) (assert (or (adjustable-array-p a1) - (equal (array-dimensions a1) ,(listify-form (first args1))))) + (equal (array-dimensions a1) ,(listify-form (first args1))))) (assert (equal (array-dimensions a2) ,(listify-form (first args2)))) ,@(unless (or (member :displaced-to args1) - (member :displaced-to args2)) - (list '(assert (not (array-displacement a2))))) + (member :displaced-to args2)) + (list '(assert (not (array-displacement a2))))) ,@(when misc (list misc)) (values - (fill-pointer a2) - a2)) + (fill-pointer a2) + a2)) ,@expected-results)) (def-adjust-array-test adjust-array.1 @@ -90,7 +90,7 @@ (5 :initial-contents '(a b c d e) :fill-pointer 3) (4 :fill-pointer 2) (progn (assert (eq (aref a2 2) 'c)) - (assert (eq (aref a2 3) 'd))) + (assert (eq (aref a2 3) 'd))) 2 #(a b)) (def-adjust-array-fp-test adjust-array.9 @@ -101,74 +101,74 @@ (deftest adjust-array.10 (let* ((a1 (make-array 5 :initial-contents '(a b c d e))) - (a2 (adjust-array a1 4 :displaced-to nil))) + (a2 (adjust-array a1 4 :displaced-to nil))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) #(a b c d)) (deftest adjust-array.11 (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) - (a2 (adjust-array a1 4))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) + (a2 (adjust-array a1 4))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) #(a b c d)) (deftest adjust-array.12 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) - (a1 (make-array 5 :initial-contents '(a b c d e))) - (a2 (adjust-array a1 4 :displaced-to a0))) + (a1 (make-array 5 :initial-contents '(a b c d e))) + (a2 (adjust-array a1 4 :displaced-to a0))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 0))) + (list a0 0))) a2) #(1 2 3 4)) (deftest adjust-array.13 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) - (a1 (make-array 5 :initial-contents '(a b c d e))) - (a2 (adjust-array a1 4 :displaced-to a0 - :displaced-index-offset 2))) + (a1 (make-array 5 :initial-contents '(a b c d e))) + (a2 (adjust-array a1 4 :displaced-to a0 + :displaced-index-offset 2))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 2))) + (list a0 2))) a2) #(3 4 5 6)) (deftest adjust-array.14 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) - (a2 (adjust-array a1 4 :displaced-to a0))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) + (a2 (adjust-array a1 4 :displaced-to a0))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 0))) + (list a0 0))) a2) #(1 2 3 4)) (deftest adjust-array.15 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) - (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1)) - (a3 (adjust-array a2 4 :displaced-to a1))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) + (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1)) + (a3 (adjust-array a2 4 :displaced-to a1))) a3) #(2 3 4 5)) (deftest adjust-array.16 (let* ((a0 (make-array 7 :initial-contents '(1 2 3 4 5 6 7))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) - (a2 (adjust-array a1 5 :displaced-to a0))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1)) + (a2 (adjust-array a1 5 :displaced-to a0))) a2) #(1 2 3 4 5)) @@ -189,8 +189,8 @@ (deftest adjust-array.20 (let* ((a0 (make-array nil :initial-element 'x)) - (a1 (make-array nil :displaced-to a0)) - (a2 (adjust-array a1 nil))) + (a1 (make-array nil :displaced-to a0)) + (a2 (adjust-array a1 nil))) a2) #0ax) @@ -198,17 +198,17 @@ (def-adjust-array-test adjust-array.21 ('(4 5) :initial-contents '((1 2 3 4 5) - (3 4 5 6 7) - (5 6 7 8 9) - (7 8 9 1 2))) + (3 4 5 6 7) + (5 6 7 8 9) + (7 8 9 1 2))) ('(2 3)) #2a((1 2 3)(3 4 5))) (def-adjust-array-test adjust-array.22 ('(4 5) :initial-contents '((1 2 3 4 5) - (3 4 5 6 7) - (5 6 7 8 9) - (7 8 9 1 2))) + (3 4 5 6 7) + (5 6 7 8 9) + (7 8 9 1 2))) ('(6 8) :initial-element 0) #2a((1 2 3 4 5 0 0 0) (3 4 5 6 7 0 0 0) @@ -219,14 +219,14 @@ (deftest adjust-array.23 (let* ((a1 (make-array '(4 5) :initial-contents '((#\1 #\2 #\3 #\4 #\5) - (#\3 #\4 #\5 #\6 #\7) - (#\5 #\6 #\7 #\8 #\9) - (#\7 #\8 #\9 #\1 #\2)) - :element-type 'character)) - (a2 (adjust-array a1 '(2 3) :element-type 'character))) + (#\3 #\4 #\5 #\6 #\7) + (#\5 #\6 #\7 #\8 #\9) + (#\7 #\8 #\9 #\1 #\2)) + :element-type 'character)) + (a2 (adjust-array a1 '(2 3) :element-type 'character))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a2) '(2 3)))) + (eq a1 a2) + (equal (array-dimensions a2) '(2 3)))) (assert (not (typep 0 (array-element-type a2)))) a2) #2a((#\1 #\2 #\3)(#\3 #\4 #\5))) @@ -259,7 +259,7 @@ ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) :element-type - (expand-in-current-env (%m t))))) + (expand-in-current-env (%m t))))) #(a b c d)) (deftest adjust-array.28 @@ -281,7 +281,7 @@ ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(6) (expand-in-current-env (%m :initial-contents)) - '(1 2 3 4 5 6)))) + '(1 2 3 4 5 6)))) #(1 2 3 4 5 6)) (deftest adjust-array.31 @@ -289,7 +289,7 @@ ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(3) :initial-contents - (expand-in-current-env (%m "ABC"))))) + (expand-in-current-env (%m "ABC"))))) #(#\A #\B #\C)) (deftest adjust-array.32 @@ -318,27 +318,27 @@ ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d)))) (adjust-array a '(4) :displaced-to - (expand-in-current-env (%m nil))))) + (expand-in-current-env (%m nil))))) #(a b c d)) (deftest adjust-array.36 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d))) - (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8)))) + (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8)))) (adjust-array a '(3) :displaced-to c - (expand-in-current-env (%m :displaced-index-offset)) - 2))) + (expand-in-current-env (%m :displaced-index-offset)) + 2))) #(3 4 5)) (deftest adjust-array.37 (macrolet ((%m (z) z)) (let ((a (make-array '(4) :initial-contents '(a b c d))) - (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8)))) + (c (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8)))) (adjust-array a '(5) :displaced-to c - :displaced-index-offset - (expand-in-current-env (%m 1))))) + :displaced-index-offset + (expand-in-current-env (%m 1))))) #(2 3 4 5 6)) ;;; Adjust an adjustable array @@ -395,8 +395,8 @@ (deftest adjust-array.adjustable.10 (let* ((a1 (make-array 5 :initial-contents '(a b c d e) - :adjustable t)) - (a2 (adjust-array a1 4 :displaced-to nil))) + :adjustable t)) + (a2 (adjust-array a1 4 :displaced-to nil))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) @@ -404,9 +404,9 @@ (deftest adjust-array.adjustable.11 (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t)) - (a2 (adjust-array a1 4))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :adjustable t)) + (a2 (adjust-array a1 4))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) @@ -414,20 +414,20 @@ (deftest adjust-array.adjustable.12 (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t)) - (a2 (adjust-array a1 4 :displaced-to a0))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :adjustable t)) + (a2 (adjust-array a1 4 :displaced-to a0))) (assert (eq a1 a2)) a2) #(x a b c)) (deftest adjust-array.adjustable.13 (let* ((a0 (make-array 7 :initial-contents '(x a b c d e y))) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t)) - (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :adjustable t)) + (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1))) (assert (eq a1 (adjust-array a1 5 :displaced-to a0 - :displaced-index-offset 2))) + :displaced-index-offset 2))) a2) #(c d e y)) @@ -478,92 +478,92 @@ (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) (4 :element-type 'character :fill-pointer 2) (progn (assert (eql (aref a2 2) #\c)) - (assert (eql (aref a2 3) #\d))) + (assert (eql (aref a2 3) #\d))) 2 "ab") (def-adjust-array-fp-test adjust-array.string.9 (5 :element-type 'character :initial-contents "abcde" :fill-pointer 3) (8 :element-type 'character :fill-pointer 5 :initial-element #\x) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) - '(#\x #\x #\x))) + '(#\x #\x #\x))) 5 "abcde") (deftest adjust-array.string.10 (let* ((a1 (make-array 5 :element-type 'character :initial-contents "abcde")) - (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character))) + (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) "abcd") (deftest adjust-array.string.11 (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'character)) - (a2 (adjust-array a1 4 :element-type 'character))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :element-type 'character)) + (a2 (adjust-array a1 4 :element-type 'character))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) "abcd") (deftest adjust-array.string.12 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) - (a1 (make-array 5 :initial-contents "abcde" :element-type 'character)) - (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) + (a1 (make-array 5 :initial-contents "abcde" :element-type 'character)) + (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 0))) + (list a0 0))) a2) "1234") (deftest adjust-array.string.13 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) - (a1 (make-array 5 :initial-contents "abcde" :element-type 'character)) - (a2 (adjust-array a1 4 :displaced-to a0 - :displaced-index-offset 2 - :element-type 'character))) + (a1 (make-array 5 :initial-contents "abcde" :element-type 'character)) + (a2 (adjust-array a1 4 :displaced-to a0 + :displaced-index-offset 2 + :element-type 'character))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 2))) + (list a0 2))) a2) "3456") (deftest adjust-array.string.14 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'character)) - (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :element-type 'character)) + (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 0))) + (list a0 0))) a2) "1234") (deftest adjust-array.string.15 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'character)) - (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 - :element-type 'character)) - (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'character))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :element-type 'character)) + (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 + :element-type 'character)) + (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'character))) a3) "2345") (deftest adjust-array.string.16 (let* ((a0 (make-array 7 :initial-contents "1234567" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'character)) - (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'character))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :element-type 'character)) + (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'character))) a2) "12345") @@ -585,8 +585,8 @@ (deftest adjust-array.string.20 (let* ((a0 (make-array nil :initial-element #\x :element-type 'character)) - (a1 (make-array nil :displaced-to a0 :element-type 'character)) - (a2 (adjust-array a1 nil :element-type 'character))) + (a1 (make-array nil :displaced-to a0 :element-type 'character)) + (a2 (adjust-array a1 nil :element-type 'character))) a2) #.(make-array nil :initial-element #\x :element-type 'character)) @@ -642,8 +642,8 @@ (deftest adjust-array.string.adjustable.10 (let* ((a1 (make-array 5 :initial-contents "abcde" - :adjustable t :element-type 'character)) - (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character))) + :adjustable t :element-type 'character)) + (a2 (adjust-array a1 4 :displaced-to nil :element-type 'character))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) @@ -651,9 +651,9 @@ (deftest adjust-array.string.adjustable.11 (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t :element-type 'character)) - (a2 (adjust-array a1 4 :element-type 'character))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :adjustable t :element-type 'character)) + (a2 (adjust-array a1 4 :element-type 'character))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) @@ -661,35 +661,35 @@ (deftest adjust-array.string.adjustable.12 (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t :element-type 'character)) - (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :adjustable t :element-type 'character)) + (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'character))) (assert (eq a1 a2)) a2) "xabc") (deftest adjust-array.string.adjustable.13 (let* ((a0 (make-array 7 :initial-contents "xabcdey" :element-type 'character)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t :element-type 'character)) - (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 - :element-type 'character))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :adjustable t :element-type 'character)) + (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 + :element-type 'character))) (assert (eq a1 (adjust-array a1 5 :displaced-to a0 - :displaced-index-offset 2 - :element-type 'character))) + :displaced-index-offset 2 + :element-type 'character))) a2) "cdey") ) for forms2 = (subst element-type 'character forms) for forms3 = (mapcar #'(lambda (form) - (destructuring-bind (dt name . body) form - `(,dt ,(if (eql element-type 'character) name - (intern (replace (copy-seq (symbol-name name)) - "BASEST" - :start1 13 :end1 19) - (symbol-package name))) - ,@ body))) - forms2) + (destructuring-bind (dt name . body) form + `(,dt ,(if (eql element-type 'character) name + (intern (replace (copy-seq (symbol-name name)) + "BASEST" + :start1 13 :end1 19) + (symbol-package name))) + ,@ body))) + forms2) do (eval `(progn ,@forms3))) ;; 2-d arrays @@ -699,16 +699,16 @@ :element-type 'character) ('(2 3)) #.(make-array '(2 3) :initial-contents '("123" "345") - :element-type 'character)) + :element-type 'character)) (def-adjust-array-test adjust-array.string.22 ('(4 5) :initial-contents '("12345" "34567" "56789" "78912") :element-type 'character) ('(6 8) :initial-element #\0 :element-type 'character) #.(make-array '(6 8) - :initial-contents '("12345000" "34567000" "56789000" + :initial-contents '("12345000" "34567000" "56789000" "78912000" "00000000" "00000000") - :element-type 'character)) + :element-type 'character)) (def-adjust-array-test adjust-array.bit-vector.1 (5 :element-type 'bit :initial-contents #*01100) @@ -752,92 +752,92 @@ (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) (4 :element-type 'bit :fill-pointer 2) (progn (assert (eql (aref a2 2) 1)) - (assert (eql (aref a2 3) 0))) + (assert (eql (aref a2 3) 0))) 2 #*01) (def-adjust-array-fp-test adjust-array.bit-vector.9 (5 :element-type 'bit :initial-contents #*01100 :fill-pointer 3) (8 :element-type 'bit :fill-pointer 5 :initial-element 1) (assert (equal (list (aref a2 5) (aref a2 6) (aref a2 7)) - '(1 1 1))) + '(1 1 1))) 5 #*01100) (deftest adjust-array.bit-vector.10 (let* ((a1 (make-array 5 :element-type 'bit :initial-contents #*01100)) - (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit))) + (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) #*0110) (deftest adjust-array.bit-vector.11 (let* ((a0 (make-array 7 :initial-contents #*0011001 :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'bit)) - (a2 (adjust-array a1 4 :element-type 'bit))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :element-type 'bit)) + (a2 (adjust-array a1 4 :element-type 'bit))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (not (array-displacement a2))) a2) #*0110) (deftest adjust-array.bit-vector.12 (let* ((a0 (make-array 7 :initial-contents #*1010101 :element-type 'bit)) - (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit)) - (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) + (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit)) + (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 0))) + (list a0 0))) a2) #*1010) (deftest adjust-array.bit-vector.13 (let* ((a0 (make-array 7 :initial-contents #*1011101 :element-type 'bit)) - (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit)) - (a2 (adjust-array a1 4 :displaced-to a0 - :displaced-index-offset 2 - :element-type 'bit))) + (a1 (make-array 5 :initial-contents #*01100 :element-type 'bit)) + (a2 (adjust-array a1 4 :displaced-to a0 + :displaced-index-offset 2 + :element-type 'bit))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 2))) + (list a0 2))) a2) #*1110) (deftest adjust-array.bit-vector.14 (let* ((a0 (make-array 7 :initial-contents #*1011001 :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'bit)) - (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :element-type 'bit)) + (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) (assert (if (adjustable-array-p a1) - (eq a1 a2) - (equal (array-dimensions a1) '(5)))) + (eq a1 a2) + (equal (array-dimensions a1) '(5)))) (assert (equal (multiple-value-list (array-displacement a2)) - (list a0 0))) + (list a0 0))) a2) #*1011) (deftest adjust-array.bit-vector.15 (let* ((a0 (make-array 7 :initial-contents #*1100010 :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'bit)) - (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 - :element-type 'bit)) - (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'bit))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :element-type 'bit)) + (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 + :element-type 'bit)) + (a3 (adjust-array a2 4 :displaced-to a1 :element-type 'bit))) a3) #*1000) (deftest adjust-array.bit-vector.16 (let* ((a0 (make-array 7 :initial-contents #*1011011 :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :element-type 'bit)) - (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'bit))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :element-type 'bit)) + (a2 (adjust-array a1 5 :displaced-to a0 :element-type 'bit))) a2) #*10110) @@ -858,8 +858,8 @@ (deftest adjust-array.bit-vector.20 (let* ((a0 (make-array nil :initial-element 1 :element-type 'bit)) - (a1 (make-array nil :displaced-to a0 :element-type 'bit)) - (a2 (adjust-array a1 nil :element-type 'bit))) + (a1 (make-array nil :displaced-to a0 :element-type 'bit)) + (a2 (adjust-array a1 nil :element-type 'bit))) a2) #.(make-array nil :initial-element 1 :element-type 'bit)) @@ -870,16 +870,16 @@ :element-type 'bit) ('(2 3)) #.(make-array '(2 3) :initial-contents '(#*111 #*001) - :element-type 'bit)) + :element-type 'bit)) (def-adjust-array-test adjust-array.bit-vector.22 ('(4 5) :initial-contents '(#*11100 #*00110 #*00001 #*11111) :element-type 'bit) ('(6 8) :initial-element 0 :element-type 'bit) #.(make-array '(6 8) - :initial-contents '(#*11100000 #*00110000 #*00001000 + :initial-contents '(#*11100000 #*00110000 #*00001000 #*11111000 #*00000000 #*00000000) - :element-type 'bit)) + :element-type 'bit)) ;;; Adjustable bit vector tests @@ -935,8 +935,8 @@ (deftest adjust-array.bit-vector.adjustable.10 (let* ((a1 (make-array 5 :initial-contents '(0 1 1 0 1) - :adjustable t :element-type 'bit)) - (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit))) + :adjustable t :element-type 'bit)) + (a2 (adjust-array a1 4 :displaced-to nil :element-type 'bit))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) @@ -944,10 +944,10 @@ (deftest adjust-array.bit-vector.adjustable.11 (let* ((a0 (make-array 7 :initial-contents '(0 1 0 1 1 1 0) - :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t :element-type 'bit)) - (a2 (adjust-array a1 4 :element-type 'bit))) + :element-type 'bit)) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :adjustable t :element-type 'bit)) + (a2 (adjust-array a1 4 :element-type 'bit))) (assert (eq a1 a2)) (assert (not (array-displacement a2))) a2) @@ -955,23 +955,23 @@ (deftest adjust-array.bit-vector.adjustable.12 (let* ((a0 (make-array 7 :initial-contents '(0 0 1 1 1 1 1) - :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t :element-type 'bit)) - (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) + :element-type 'bit)) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :adjustable t :element-type 'bit)) + (a2 (adjust-array a1 4 :displaced-to a0 :element-type 'bit))) (assert (eq a1 a2)) a2) #*0011) (deftest adjust-array.bit-vector.adjustable.13 (let* ((a0 (make-array 7 :initial-contents '(1 0 0 0 0 0 1) :element-type 'bit)) - (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 - :adjustable t :element-type 'bit)) - (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 - :element-type 'bit))) + (a1 (make-array 5 :displaced-to a0 :displaced-index-offset 1 + :adjustable t :element-type 'bit)) + (a2 (make-array 4 :displaced-to a1 :displaced-index-offset 1 + :element-type 'bit))) (assert (eq a1 (adjust-array a1 5 :displaced-to a0 - :displaced-index-offset 2 - :element-type 'bit))) + :displaced-index-offset 2 + :element-type 'bit))) a2) #*0001) @@ -987,28 +987,28 @@ (deftest adjust-array.error.2 (signals-error (adjust-array (make-array 10 :initial-element nil)) - program-error) + program-error) t) (deftest adjust-array.error.3 (signals-error (adjust-array (make-array 10 :initial-element nil) - 8 :bad t) - program-error) + 8 :bad t) + program-error) t) (deftest adjust-array.error.4 (signals-error (adjust-array (make-array 10 :initial-element nil) - 8 :initial-element) - program-error) + 8 :initial-element) + program-error) t) (deftest adjust-array.error.5 (signals-error (adjust-array (make-array 10 :initial-element nil) - 8 - :allow-other-keys nil - :allow-other-keys t - :bad t) - program-error) + 8 + :allow-other-keys nil + :allow-other-keys t + :bad t) + program-error) t) (deftest adjust-array.error.6 diff --git a/ansi-tests/adjustable-array-p.lsp b/ansi-tests/adjustable-array-p.lsp index 1933eac0..fdfce8b4 100644 --- a/ansi-tests/adjustable-array-p.lsp +++ b/ansi-tests/adjustable-array-p.lsp @@ -27,15 +27,15 @@ (deftest adjustable-array-p.6 (macrolet ((%m (z) z)) - (let ((a (make-array '(5) :adjustable t))) - (notnot (adjustable-array-p (expand-in-current-env (%m a)))))) + (let ((a (make-array '(5) :adjustable t))) + (notnot (adjustable-array-p (expand-in-current-env (%m a)))))) t) (deftest adjustable-array-p.order.1 (let ((i 0) x) (values (notnot (adjustable-array-p (progn (setf x (incf i)) - (make-array '(5) :adjustable t)))) + (make-array '(5) :adjustable t)))) i x)) t 1 1) @@ -63,7 +63,7 @@ (deftest adjustable-array-p.error.6 (signals-error (let ((x 10)) - (locally (declare (optimize (safety 3))) - (adjustable-array-p x))) - type-error) + (locally (declare (optimize (safety 3))) + (adjustable-array-p x))) + type-error) t) diff --git a/ansi-tests/allocate-instance.lsp b/ansi-tests/allocate-instance.lsp index 42c6322c..d69d8318 100644 --- a/ansi-tests/allocate-instance.lsp +++ b/ansi-tests/allocate-instance.lsp @@ -17,7 +17,7 @@ (deftest allocate-instance.1 (let* ((class (find-class 'allocate-instance-class-01)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-01) @@ -28,9 +28,9 @@ (deftest allocate-instance.2 (let* ((class (find-class 'allocate-instance-class-01)) - (obj (allocate-instance class - :foo t :a 10 :b 12 :c 1.0 :d 'a :e 17 - :f nil :bar t))) + (obj (allocate-instance class + :foo t :a 10 :b 12 :c 1.0 :d 'a :e 17 + :f nil :bar t))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-01) @@ -41,7 +41,7 @@ (deftest allocate-instance.3 (let* ((class (find-class 'allocate-instance-class-01)) - (obj (allocate-instance class :allow-other-keys nil :xyzzy t))) + (obj (allocate-instance class :allow-other-keys nil :xyzzy t))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-01) @@ -73,11 +73,11 @@ (deftest allocate-instance.5 (let* ((class (find-class 'allocate-instance-struct-01)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (setf (allocate-instance-struct-01-a obj) 'x - (allocate-instance-struct-01-b obj) 1234567890 - (allocate-instance-struct-01-c obj) #\Z - (allocate-instance-struct-01-d obj) 'foo) + (allocate-instance-struct-01-b obj) 1234567890 + (allocate-instance-struct-01-c obj) #\Z + (allocate-instance-struct-01-d obj) 'foo) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-struct-01) @@ -93,11 +93,11 @@ (deftest allocate-instance.order.1 (let* ((class (find-class 'allocate-instance-class-01)) - (i 0) x y z w - (obj (allocate-instance (progn (setf x (incf i)) class) - :e (setf y (incf i)) - :b (setf z (incf i)) - :e (setf w (incf i))))) + (i 0) x y z w + (obj (allocate-instance (progn (setf x (incf i)) class) + :e (setf y (incf i)) + :b (setf z (incf i)) + :e (setf w (incf i))))) (values (eqt (class-of obj) class) (typep* obj 'allocate-instance-class-01) @@ -118,13 +118,13 @@ #| (deftest allocate-instance.error.2 (signals-error (allocate-instance (find-class 'allocate-instance-class-01) - :b) - program-error) + :b) + program-error) t) (deftest allocate-instance.error.3 (signals-error (allocate-instance (find-class 'allocate-instance-class-01) - '(a b c) nil) - program-error) + '(a b c) nil) + program-error) t) |# diff --git a/ansi-tests/and.lsp b/ansi-tests/and.lsp index 6924d211..3046d09b 100644 --- a/ansi-tests/and.lsp +++ b/ansi-tests/and.lsp @@ -46,8 +46,8 @@ (macrolet ((%m (z) z)) (and (expand-in-current-env (%m :a)) - (expand-in-current-env (%m :b)) - (expand-in-current-env (%m :c)))) + (expand-in-current-env (%m :b)) + (expand-in-current-env (%m :c)))) :c) ;;; Error tests @@ -55,30 +55,30 @@ (deftest and.order.1 (let ((x 0)) (values (and nil (incf x)) - x)) + x)) nil 0) (deftest and.order.2 (let ((i 0) a b c d) (values (and (setf a (incf i)) - (setf b (incf i)) - (setf c (incf i)) - (setf d (incf i))) + (setf b (incf i)) + (setf c (incf i)) + (setf d (incf i))) i a b c d)) 4 4 1 2 3 4) (deftest and.error.1 (signals-error (funcall (macro-function 'and)) - program-error) + program-error) t) (deftest and.error.2 (signals-error (funcall (macro-function 'and) '(and)) - program-error) + program-error) t) (deftest and.error.3 (signals-error (funcall (macro-function 'and) '(and) nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/ansi-aux-macros.lsp b/ansi-tests/ansi-aux-macros.lsp index 656561cc..1b49e87f 100644 --- a/ansi-tests/ansi-aux-macros.lsp +++ b/ansi-tests/ansi-aux-macros.lsp @@ -24,7 +24,7 @@ (defun should-never-be-called () nil) (defmacro normally (form &optional (default-form - '(should-never-be-called))) + '(should-never-be-called))) `(if *should-always-be-true* ,form ,default-form)) ;;; Macro to ignore errors, but report them anyway @@ -36,11 +36,11 @@ `(eval-when (:load-toplevel :compile-toplevel :execute) (#+sbcl let #+sbcl () #-sbcl progn (handler-case - (progn ,@body) - (error (condition) - (princ condition) - (terpri) - (when *report-and-ignore-errors-break* (break)) - (values nil condition)))))) - - + (progn ,@body) + (error (condition) + (princ condition) + (terpri) + (when *report-and-ignore-errors-break* (break)) + (values nil condition)))))) + + diff --git a/ansi-tests/ansi-aux.lsp b/ansi-tests/ansi-aux.lsp index 2da83c5b..b59839bb 100644 --- a/ansi-tests/ansi-aux.lsp +++ b/ansi-tests/ansi-aux.lsp @@ -18,8 +18,8 @@ (if (null results) (values) (apply #'values - (not (not (first results))) - (rest results)))) + (not (not (first results))) + (rest results)))) (defmacro not-mv (form) `(not-mv-fn (multiple-value-list ,form))) @@ -28,8 +28,8 @@ (if (null results) (values) (apply #'values - (not (first results)) - (rest results)))) + (not (first results)) + (rest results)))) (declaim (ftype (function (t) function) to-function)) @@ -43,9 +43,9 @@ ;;; (defaults to 1) (defmacro check-values (form &optional (num 1)) (let ((v (gensym)) - (n (gensym))) + (n (gensym))) `(let ((,v (multiple-value-list ,form)) - (,n ,num)) + (,n ,num)) (check-values-length ,v ,n ',form) (car ,v)))) @@ -63,11 +63,11 @@ Results: ~A~%" expected-number form n results)))) ;;; Do multiple-value-bind, but check # of arguments (defmacro multiple-value-bind* ((&rest vars) form &body body) (let ((len (length vars)) - (v (gensym))) + (v (gensym))) `(let ((,v (multiple-value-list ,form))) (check-values-length ,v ,len ',form) (destructuring-bind ,vars ,v ,@body)))) - + ;;; Comparison functions that are like various builtins, ;;; but are guaranteed to return T for true. @@ -122,26 +122,26 @@ Results: ~A~%" expected-number form n results)))) (typep a2 'array) (= (array-rank a1) (array-rank a2)) (if (= (array-rank a1) 0) - (equal (regression-test::my-aref a1) (regression-test::my-aref a2)) - (let ((ad (array-dimensions a1))) - (and (equal ad (array-dimensions a2)) - (locally - (declare (type (array * *) a1 a2)) - (if (= (array-rank a1) 1) - (let ((as (first ad))) - (loop - for i from 0 below as - always (equal (regression-test::my-aref a1 i) - (regression-test::my-aref a2 i)))) - (let ((as (array-total-size a1))) - (and (= as (array-total-size a2)) - (loop - for i from 0 below as - always - (equal - (regression-test::my-row-major-aref a1 i) - (regression-test::my-row-major-aref a2 i)) - )))))))))) + (equal (regression-test::my-aref a1) (regression-test::my-aref a2)) + (let ((ad (array-dimensions a1))) + (and (equal ad (array-dimensions a2)) + (locally + (declare (type (array * *) a1 a2)) + (if (= (array-rank a1) 1) + (let ((as (first ad))) + (loop + for i from 0 below as + always (equal (regression-test::my-aref a1 i) + (regression-test::my-aref a2 i)))) + (let ((as (array-total-size a1))) + (and (= as (array-total-size a2)) + (loop + for i from 0 below as + always + (equal + (regression-test::my-row-major-aref a1 i) + (regression-test::my-row-major-aref a2 i)) + )))))))))) ;;; *universe* is defined elsewhere -- it is a list of various ;;; lisp objects used when stimulating things in various tests. @@ -159,9 +159,9 @@ Results: ~A~%" expected-number form n results)))) (multiple-value-bind (sub good) (subtypep* type1 type2) (if good - sub + sub (loop for e in *universe* - always (or (not (typep e type1)) (typep e type2)))))) + always (or (not (typep e type1)) (typep e type2)))))) (defun check-type-predicate (P TYPE) "Check that a predicate P is the same as #'(lambda (x) (typep x TYPE)) @@ -176,23 +176,23 @@ Results: ~A~%" expected-number form n results)))) (loop for x in *universe* when - (block failed - (let ((p1 (handler-case - (normally (funcall (the function p) x)) - (error () (format t "(FUNCALL ~S ~S) failed~%" - P x) - (return-from failed t)))) - (p2 (handler-case - (normally (typep x TYPE)) - (error () (format t "(TYPEP ~S '~S) failed~%" - x TYPE) - (return-from failed t))))) - (when (or (and p1 (not p2)) - (and (not p1) p2)) - (format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%" - P x p1 x TYPE p2) - t))) - collect x)) + (block failed + (let ((p1 (handler-case + (normally (funcall (the function p) x)) + (error () (format t "(FUNCALL ~S ~S) failed~%" + P x) + (return-from failed t)))) + (p2 (handler-case + (normally (typep x TYPE)) + (error () (format t "(TYPEP ~S '~S) failed~%" + x TYPE) + (return-from failed t))))) + (when (or (and p1 (not p2)) + (and (not p1) p2)) + (format t "(FUNCALL ~S ~S) = ~S, (TYPEP ~S '~S) = ~S~%" + P x p1 x TYPE p2) + t))) + collect x)) ;;; We have a common idiom where a guarded predicate should be ;;; true everywhere @@ -201,8 +201,8 @@ Results: ~A~%" expected-number form n results)))) "Return all elements of UNIVERSE for which the guard (if present) is false and for which PREDICATE is false." (remove-if #'(lambda (e) (or (and guard (funcall guard e)) - (funcall predicate e))) - universe)) + (funcall predicate e))) + universe)) (declaim (special *catch-error-type*)) @@ -213,10 +213,10 @@ Results: ~A~%" expected-number form n results)))) (let ((r (find-restart 'continue condition))) (cond ((and *catch-error-type* - (not (typep condition *catch-error-type*))) + (not (typep condition *catch-error-type*))) (format t "Condition ~S is not a ~A~%" condition *catch-error-type*) (cond (r (format t "Its continue restart is ~S~%" r)) - (t (format t "It has no continue restart~%"))) + (t (format t "It has no continue restart~%"))) (throw 'continue-failed nil)) (r (invoke-restart r)) (t (throw 'continue-failed nil))))) @@ -268,15 +268,15 @@ the condition to go uncaught if it cannot be classified." (defun classify-error** (form) (handler-bind ((warning #'(lambda (c) (declare (ignore c)) - (muffle-warning)))) - (proclaim '(optimize (safety 3))) - (classify-error* - (if regression-test::*compile-tests* - (funcall (compile nil `(lambda () - (declare (optimize (safety 3))) - ,form))) - (eval form)) - ))) + (muffle-warning)))) + (proclaim '(optimize (safety 3))) + (classify-error* + (if regression-test::*compile-tests* + (funcall (compile nil `(lambda () + (declare (optimize (safety 3))) + ,form))) + (eval form)) + ))) (defmacro classify-error (form) `(classify-error** ',form)) @@ -287,53 +287,53 @@ the condition to go uncaught if it cannot be classified." (defmacro signals-error (form error-name &key (safety 3) (name nil name-p) (inline nil)) `(handler-bind ((warning #'(lambda (c) (declare (ignore c)) - (muffle-warning)))) + (muffle-warning)))) (proclaim '(optimize (safety 3))) (handler-case (apply #'values - nil - (multiple-value-list - ,(cond - (inline form) - (regression-test::*compile-tests* - `(funcall (compile nil '(lambda () - (declare (optimize (safety ,safety))) - ,form)))) - (t `(eval ',form))))) + nil + (multiple-value-list + ,(cond + (inline form) + (regression-test::*compile-tests* + `(funcall (compile nil '(lambda () + (declare (optimize (safety ,safety))) + ,form)))) + (t `(eval ',form))))) (,error-name (c) - (cond - ,@(case error-name - (type-error - `(((typep (type-error-datum c) - (type-error-expected-type c)) - (values - nil - (list (list 'typep (list 'quote - (type-error-datum c)) - (list 'quote - (type-error-expected-type c))) - "==> true"))))) - ((undefined-function unbound-variable) - (and name-p - `(((not (eq (cell-error-name c) ',name)) - (values - nil - (list 'cell-error-name "==>" - (cell-error-name c))))))) - ((stream-error end-of-file reader-error) - `(((not (streamp (stream-error-stream c))) - (values - nil - (list 'stream-error-stream "==>" - (stream-error-stream c)))))) - (file-error - `(((not (pathnamep (pathname (file-error-pathname c)))) - (values - nil - (list 'file-error-pathname "==>" - (file-error-pathname c)))))) - (t nil)) - (t (printable-p c))))))) + (cond + ,@(case error-name + (type-error + `(((typep (type-error-datum c) + (type-error-expected-type c)) + (values + nil + (list (list 'typep (list 'quote + (type-error-datum c)) + (list 'quote + (type-error-expected-type c))) + "==> true"))))) + ((undefined-function unbound-variable) + (and name-p + `(((not (eq (cell-error-name c) ',name)) + (values + nil + (list 'cell-error-name "==>" + (cell-error-name c))))))) + ((stream-error end-of-file reader-error) + `(((not (streamp (stream-error-stream c))) + (values + nil + (list 'stream-error-stream "==>" + (stream-error-stream c)))))) + (file-error + `(((not (pathnamep (pathname (file-error-pathname c)))) + (values + nil + (list 'file-error-pathname "==>" + (file-error-pathname c)))))) + (t nil)) + (t (printable-p c))))))) (defmacro signals-error-always (form error-name) `(values @@ -342,36 +342,36 @@ the condition to go uncaught if it cannot be classified." (defmacro signals-type-error (var datum-form form &key (safety 3) (inline nil)) (let ((lambda-form - `(lambda (,var) - (declare (optimize (safety ,safety))) - ,form))) + `(lambda (,var) + (declare (optimize (safety ,safety))) + ,form))) `(let ((,var ,datum-form)) (declare (optimize safety)) (handler-bind - ((warning #'(lambda (c) (declare (ignore c)) - (muffle-warning)))) - ; (proclaim '(optimize (safety 3))) - (handler-case - (apply #'values - nil - (multiple-value-list - (funcall - ,(cond - (inline `(function ,lambda-form)) - (regression-test::*compile-tests* - `(compile nil ',lambda-form)) - (t `(eval ',lambda-form))) - ,var))) - (type-error - (c) - (let ((datum (type-error-datum c)) - (expected-type (type-error-expected-type c))) - (cond - ((not (eql ,var datum)) - (list :datum-mismatch ,var datum)) - ((typep datum expected-type) - (list :is-typep datum expected-type)) - (t (printable-p c)))))))))) + ((warning #'(lambda (c) (declare (ignore c)) + (muffle-warning)))) + ; (proclaim '(optimize (safety 3))) + (handler-case + (apply #'values + nil + (multiple-value-list + (funcall + ,(cond + (inline `(function ,lambda-form)) + (regression-test::*compile-tests* + `(compile nil ',lambda-form)) + (t `(eval ',lambda-form))) + ,var))) + (type-error + (c) + (let ((datum (type-error-datum c)) + (expected-type (type-error-expected-type c))) + (cond + ((not (eql ,var datum)) + (list :datum-mismatch ,var datum)) + ((typep datum expected-type) + (list :is-typep datum expected-type)) + (t (printable-p c)))))))))) (declaim (special *mini-universe*)) @@ -380,12 +380,12 @@ the condition to go uncaught if it cannot be classified." pred-fn signals a type error." (let (val) (loop for e in universe - unless (or (funcall guard-fn e) - (equal - (setf val (multiple-value-list - (signals-type-error x e (funcall pred-fn x) :inline t))) - '(t))) - collect (list e val)))) + unless (or (funcall guard-fn e) + (equal + (setf val (multiple-value-list + (signals-type-error x e (funcall pred-fn x) :inline t))) + '(t))) + collect (list e val)))) (defmacro check-type-error (&body args) `(locally (declare (optimize safety)) (check-type-error* ,@args))) @@ -394,10 +394,10 @@ the condition to go uncaught if it cannot be classified." "Returns T iff obj can be printed to a string." (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil)) + (*print-escape* nil)) (declare (optimize safety)) (handler-case (and (stringp (write-to-string obj)) t) - (condition (c) (declare (ignore c)) nil))))) + (condition (c) (declare (ignore c)) nil))))) ;;; ;;; The function SUBTYPEP should return two generalized booleans. @@ -406,28 +406,28 @@ the condition to go uncaught if it cannot be classified." ;;; (defun subtypep* (type1 type2) (apply #'values - (mapcar #'notnot - (multiple-value-list (subtypep type1 type2))))) + (mapcar #'notnot + (multiple-value-list (subtypep type1 type2))))) (defun subtypep*-or-fail (type1 type2) (let ((results (multiple-value-list (subtypep type1 type2)))) (and (= (length results) 2) - (or (not (second results)) - (notnot (first results)))))) + (or (not (second results)) + (notnot (first results)))))) (defun subtypep*-not-or-fail (type1 type2) (let ((results (multiple-value-list (subtypep type1 type2)))) (and (= (length results) 2) - (or (not (second results)) - (not (first results)))))) + (or (not (second results)) + (not (first results)))))) ;; (declaim (ftype (function (&rest function) (values function &optional)) -;; compose)) +;; compose)) (defun compose (&rest fns) (let ((rfns (reverse fns))) #'(lambda (x) (loop for f - in rfns do (setf x (funcall (the function f) x))) x))) + in rfns do (setf x (funcall (the function f) x))) x))) (defun evendigitp (c) (notnot (find c "02468"))) @@ -462,9 +462,9 @@ the condition to go uncaught if it cannot be classified." CALL-ARGUMENTS-LIMIT." (if (cddddr args) (list 'list* - (first args) (second args) (third args) (fourth args) - (make-list-expr (cddddr args))) - (cons 'list args))) + (first args) (second args) (third args) (fourth args) + (make-list-expr (cddddr args))) + (cons 'list args))) (defparameter +standard-chars+ (coerce @@ -473,13 +473,13 @@ the condition to go uncaught if it cannot be classified." (defparameter +base-chars+ #.(coerce - (concatenate 'string - "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "0123456789" - "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|") - 'simple-base-string)) - + (concatenate 'string + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "0123456789" + "<,>.?/\"':;[{]}~`!@#$%^&*()_-+= \\|") + 'simple-base-string)) + (declaim (type simple-base-string +base-chars+)) @@ -491,18 +491,18 @@ the condition to go uncaught if it cannot be classified." (defparameter +alphanumeric-chars+ (subseq +standard-chars+ 0 62)) (defparameter +digit-chars+ "0123456789") (defparameter +extended-digit-chars+ (coerce - "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" - 'simple-base-string)) + "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" + 'simple-base-string)) (declaim (type simple-base-string +alpha-chars+ +lower-case-chars+ - +upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+ - +standard-chars+)) + +upper-case-chars+ +alphanumeric-chars+ +extended-digit-chars+ + +standard-chars+)) (defparameter +code-chars+ (coerce (loop for i from 0 below 256 - for c = (code-char i) - when c collect c) - 'simple-string)) + for c = (code-char i) + when c collect c) + 'simple-string)) (declaim (type simple-string +code-chars+)) @@ -512,24 +512,24 @@ the condition to go uncaught if it cannot be classified." (defun has-non-abort-restart (c) (throw 'handled - (if (position 'abort (the list (compute-restarts c)) - :key #'restart-name :test-not #'eq) - 'success - 'fail))) + (if (position 'abort (the list (compute-restarts c)) + :key #'restart-name :test-not #'eq) + 'success + 'fail))) (defmacro handle-non-abort-restart (&body body) `(catch 'handled (handler-bind ((error #'has-non-abort-restart)) - ,@body))) + ,@body))) ;;; used in elt.lsp (defun elt-v-6-body () (let ((x (make-int-list 1000))) (let ((a (make-array '(1000) :initial-contents x))) (loop - for i from 0 to 999 do - (unless (eql i (elt a i)) (return nil)) - finally (return t))))) + for i from 0 to 999 do + (unless (eql i (elt a i)) (return nil)) + finally (return t))))) (defun make-adj-array (n &key initial-contents) (if initial-contents @@ -541,24 +541,24 @@ the condition to go uncaught if it cannot be classified." (let ((x (make-int-list 1000))) (let ((a (make-adj-array '(1000) :initial-contents x))) (loop - for i from 0 to 999 do - (unless (eql i (elt a i)) (return nil)) - finally (return t))))) + for i from 0 to 999 do + (unless (eql i (elt a i)) (return nil)) + finally (return t))))) (defparameter *displaced* (make-int-array 100000)) (defun make-displaced-array (n displacement) (make-array n :displaced-to *displaced* - :displaced-index-offset displacement)) + :displaced-index-offset displacement)) ;;; used in fill.lsp (defun array-unsigned-byte-fill-test-fn (byte-size &rest fill-args) (let* ((a (make-array '(5) :element-type (list 'unsigned-byte byte-size) - :initial-contents '(1 2 3 4 5))) - (b (apply #'fill a fill-args))) + :initial-contents '(1 2 3 4 5))) + (b (apply #'fill a fill-args))) (values (eqt a b) - (map 'list #'identity a)))) + (map 'list #'identity a)))) ;;; used in fill-strings.lsp (defun array-string-fill-test-fn (a &rest fill-args) @@ -574,121 +574,121 @@ the condition to go uncaught if it cannot be classified." (defparameter *subtype-table* (let ((table '( - (null symbol) - (symbol t) - (boolean symbol) - (standard-object t) - (function t) - (compiled-function function) - (generic-function function) - (standard-generic-function generic-function) - (class standard-object) - (built-in-class class) - (structure-class class) - (standard-class class) - (method standard-object) - (standard-method method) - (structure-object t) - (method-combination t) - (condition t) - (serious-condition condition) - (error serious-condition) - (type-error error) - (simple-type-error type-error) - (simple-condition condition) - (simple-type-error simple-condition) - (parse-error error) - (hash-table t) - (cell-error error) - (unbound-slot cell-error) - (warning condition) - (style-warning warning) - (storage-condition serious-condition) - (simple-warning warning) - (simple-warning simple-condition) - (keyword symbol) - (unbound-variable cell-error) - (control-error error) - (program-error error) - (undefined-function cell-error) - (package t) - (package-error error) - (random-state t) - (number t) - (real number) - (complex number) - (float real) - (short-float float) - (single-float float) - (double-float float) - (long-float float) - (rational real) - (integer rational) - (ratio rational) - (signed-byte integer) - (integer signed-byte) - (unsigned-byte signed-byte) - (bit unsigned-byte) - (fixnum integer) - (bignum integer) - (bit fixnum) - (arithmetic-error error) - (division-by-zero arithmetic-error) - (floating-point-invalid-operation arithmetic-error) - (floating-point-inexact arithmetic-error) - (floating-point-overflow arithmetic-error) - (floating-point-underflow arithmetic-error) - (character t) - (base-char character) - (standard-char base-char) - (extended-char character) - (sequence t) - (list sequence) - (null list) - (null boolean) - (cons list) - (array t) - (simple-array array) - (vector sequence) - (vector array) - (string vector) - (bit-vector vector) - (simple-vector vector) - (simple-vector simple-array) - (simple-bit-vector bit-vector) - (simple-bit-vector simple-array) - (base-string string) - (simple-string string) - (simple-string simple-array) - (simple-base-string base-string) - (simple-base-string simple-string) - (pathname t) - (logical-pathname pathname) - (file-error error) - (stream t) - (broadcast-stream stream) - (concatenated-stream stream) - (echo-stream stream) - (file-stream stream) - (string-stream stream) - (synonym-stream stream) - (two-way-stream stream) - (stream-error error) - (end-of-file stream-error) - (print-not-readable error) - (readtable t) - (reader-error parse-error) - (reader-error stream-error) - ))) + (null symbol) + (symbol t) + (boolean symbol) + (standard-object t) + (function t) + (compiled-function function) + (generic-function function) + (standard-generic-function generic-function) + (class standard-object) + (built-in-class class) + (structure-class class) + (standard-class class) + (method standard-object) + (standard-method method) + (structure-object t) + (method-combination t) + (condition t) + (serious-condition condition) + (error serious-condition) + (type-error error) + (simple-type-error type-error) + (simple-condition condition) + (simple-type-error simple-condition) + (parse-error error) + (hash-table t) + (cell-error error) + (unbound-slot cell-error) + (warning condition) + (style-warning warning) + (storage-condition serious-condition) + (simple-warning warning) + (simple-warning simple-condition) + (keyword symbol) + (unbound-variable cell-error) + (control-error error) + (program-error error) + (undefined-function cell-error) + (package t) + (package-error error) + (random-state t) + (number t) + (real number) + (complex number) + (float real) + (short-float float) + (single-float float) + (double-float float) + (long-float float) + (rational real) + (integer rational) + (ratio rational) + (signed-byte integer) + (integer signed-byte) + (unsigned-byte signed-byte) + (bit unsigned-byte) + (fixnum integer) + (bignum integer) + (bit fixnum) + (arithmetic-error error) + (division-by-zero arithmetic-error) + (floating-point-invalid-operation arithmetic-error) + (floating-point-inexact arithmetic-error) + (floating-point-overflow arithmetic-error) + (floating-point-underflow arithmetic-error) + (character t) + (base-char character) + (standard-char base-char) + (extended-char character) + (sequence t) + (list sequence) + (null list) + (null boolean) + (cons list) + (array t) + (simple-array array) + (vector sequence) + (vector array) + (string vector) + (bit-vector vector) + (simple-vector vector) + (simple-vector simple-array) + (simple-bit-vector bit-vector) + (simple-bit-vector simple-array) + (base-string string) + (simple-string string) + (simple-string simple-array) + (simple-base-string base-string) + (simple-base-string simple-string) + (pathname t) + (logical-pathname pathname) + (file-error error) + (stream t) + (broadcast-stream stream) + (concatenated-stream stream) + (echo-stream stream) + (file-stream stream) + (string-stream stream) + (synonym-stream stream) + (two-way-stream stream) + (stream-error error) + (end-of-file stream-error) + (print-not-readable error) + (readtable t) + (reader-error parse-error) + (reader-error stream-error) + ))) (when (subtypep* 'character 'base-char) (setq table - (append - '((character base-char) - ;; (string base-string) - ;; (simple-string simple-base-string) - ) - table))) - + (append + '((character base-char) + ;; (string base-string) + ;; (simple-string simple-base-string) + ) + table))) + table)) (defparameter *disjoint-types-list* @@ -700,22 +700,22 @@ the condition to go uncaught if it cannot be classified." `((cons (cons t t) (cons t (cons t t)) (eql (nil))) (symbol keyword boolean null (eql a) (eql nil) (eql t) (eql *)) (array vector simple-array simple-vector string simple-string - base-string simple-base-string (eql #())) + base-string simple-base-string (eql #())) (character base-char standard-char (eql #\a) - ,@(if (subtypep 'character 'base-char) nil - (list 'extended-char))) + ,@(if (subtypep 'character 'base-char) nil + (list 'extended-char))) (function compiled-function generic-function standard-generic-function - (eql ,#'car)) + (eql ,#'car)) (package (eql ,(find-package "COMMON-LISP"))) (pathname logical-pathname (eql #p"")) (stream broadcast-stream concatenated-stream echo-stream - file-stream string-stream synonym-stream two-way-stream) + file-stream string-stream synonym-stream two-way-stream) (number real complex float integer rational ratio fixnum - bit (integer 0 100) (float 0.0 100.0) (integer 0 *) - (rational 0 *) (mod 10) - (eql 0) - ,@(and (not (subtypep 'bignum nil)) - (list 'bignum))) + bit (integer 0 100) (float 0.0 100.0) (integer 0 *) + (rational 0 *) (mod 10) + (eql 0) + ,@(and (not (subtypep 'bignum nil)) + (list 'bignum))) (random-state) ,*condition-types* (restart) @@ -728,7 +728,7 @@ the condition to go uncaught if it cannot be classified." (let ((len (length list))) (if (<= len n) list (append (subseq list 0 n) - (format nil "And ~A more omitted." (- len n)))))) + (format nil "And ~A more omitted." (- len n)))))) (defun is-t-or-nil (e) (or (eqt e t) (eqt e nil))) @@ -747,14 +747,14 @@ the condition to go uncaught if it cannot be classified." (defmacro defstruct* (&body args) `(eval-when (:load-toplevel :compile-toplevel :execute) (handler-case (eval '(defstruct ,@args)) - (serious-condition () nil)))) + (serious-condition () nil)))) (defun safely-delete-package (package-designator) (let ((package (find-package package-designator))) (when package (let ((used-by (package-used-by-list package))) - (dolist (using-package used-by) - (unuse-package package using-package))) + (dolist (using-package used-by) + (unuse-package package using-package))) (delete-package package)))) #-(or allegro openmcl lispworks) @@ -762,8 +762,8 @@ the condition to go uncaught if it cannot be classified." "Replace the versions field of the pathname specified by pathspec with :wild, and delete all the files this refers to." (let* ((wild-pathname (make-pathname :version :wild :defaults (pathname pathspec))) - (truenames (directory wild-pathname))) - (mapc #'delete-file truenames))) + (truenames (directory wild-pathname))) + (mapc #'delete-file truenames))) ;;; This is a hack to get around an ACL bug; OpenMCL also apparently ;;; needs it @@ -780,10 +780,10 @@ the condition to go uncaught if it cannot be classified." (declare (ignore expected-fmt expected-args)) (and (typep c 'simple-condition) (let ((fc (simple-condition-format-control c)) - (args (simple-condition-format-arguments c))) - (and - (stringp (apply #'format nil fc args)) - t)))) + (args (simple-condition-format-arguments c))) + (and + (stringp (apply #'format nil fc args)) + t)))) (defun frob-simple-error (c expected-fmt &rest expected-args) (and (typep c 'simple-error) @@ -803,22 +803,22 @@ the condition to go uncaught if it cannot be classified." (defun collect-properties (plist prop) "Collect all the properties in plist for a property prop." (loop for e on plist by #'cddr - when (eql (car e) prop) - collect (cadr e))) + when (eql (car e) prop) + collect (cadr e))) (defmacro def-macro-test (test-name macro-form) (let ((macro-name (car macro-form))) (assert (symbolp macro-name)) `(deftest ,test-name (values - (signals-error (funcall (macro-function ',macro-name)) - program-error) - (signals-error (funcall (macro-function ',macro-name) - ',macro-form) - program-error) - (signals-error (funcall (macro-function ',macro-name) - ',macro-form nil nil) - program-error)) + (signals-error (funcall (macro-function ',macro-name)) + program-error) + (signals-error (funcall (macro-function ',macro-name) + ',macro-form) + program-error) + (signals-error (funcall (macro-function ',macro-name) + ',macro-form nil nil) + program-error)) t t t))) (defun typep* (element type) @@ -876,11 +876,11 @@ the condition to go uncaught if it cannot be classified." `(deftest ,name (block done (let ((*debugger-hook* #'(lambda (&rest args) - (declare (ignore args)) - (return-from done :good)))) - (handler-case - (unwind-protect (eval ',form) (return-from done :good)) - (condition () :good)))) + (declare (ignore args)) + (return-from done :good)))) + (handler-case + (unwind-protect (eval ',form) (return-from done :good)) + (condition () :good)))) :good)) (defun rational-safely (x) @@ -891,12 +891,12 @@ the condition to go uncaught if it cannot be classified." (multiple-value-bind (significand exponent sign) (integer-decode-float x) (let ((limit 1000) - (radix (float-radix x))) + (radix (float-radix x))) (cond ((< exponent (- limit)) - (* significand (expt radix (- limit)) sign)) + (* significand (expt radix (- limit)) sign)) ((> exponent limit) - (* significand (expt radix limit) sign)) + (* significand (expt radix limit) sign)) (t (rational x)))))) (declaim (special *similarity-list*)) @@ -918,7 +918,7 @@ the condition to go uncaught if it cannot be classified." (defmethod is-similar* ((x symbol) (y symbol)) (if (null (symbol-package x)) (and (null (symbol-package y)) - (is-similar* (symbol-name x) (symbol-name y))) + (is-similar* (symbol-name x) (symbol-name y))) ;; I think the requirements for interned symbols in ;; 3.2.4.2.2 boils down to EQ after the symbols are in the lisp (eq x y)) @@ -926,55 +926,55 @@ the condition to go uncaught if it cannot be classified." (defmethod is-similar* ((x random-state) (y random-state)) (let ((copy-of-x (make-random-state x)) - (copy-of-y (make-random-state y)) - (bound (1- (ash 1 24)))) + (copy-of-y (make-random-state y)) + (bound (1- (ash 1 24)))) (and ;; Try 50 values, and assume the random state are the same ;; if all the values are the same. Assuming the RNG is not ;; very pathological, this should be acceptable. (loop repeat 50 - always (eql (random bound copy-of-x) - (random bound copy-of-y))) + always (eql (random bound copy-of-x) + (random bound copy-of-y))) t))) (defmethod is-similar* ((x cons) (y cons)) (or (and (eq x y) t) (and (loop for (x2 . y2) in *similarity-list* - thereis (and (eq x x2) (eq y y2))) - t) + thereis (and (eq x x2) (eq y y2))) + t) (let ((*similarity-list* - (cons (cons x y) *similarity-list*))) - (and (is-similar* (car x) (car y)) - ;; If this causes stack problems, - ;; convert to a loop - (is-similar* (cdr x) (cdr y)))))) + (cons (cons x y) *similarity-list*))) + (and (is-similar* (car x) (car y)) + ;; If this causes stack problems, + ;; convert to a loop + (is-similar* (cdr x) (cdr y)))))) (defmethod is-similar* ((x vector) (y vector)) (or (and (eq x y) t) (and (or (not (typep x 'simple-array)) - (typep x 'simple-array)) + (typep x 'simple-array)) (= (length x) (length y)) (is-similar* (array-element-type x) - (array-element-type y)) + (array-element-type y)) (loop for i below (length x) - always (is-similar* (aref x i) (aref y i))) + always (is-similar* (aref x i) (aref y i))) t))) (defmethod is-similar* ((x array) (y array)) (or (and (eq x y) t) (and (or (not (typep x 'simple-array)) - (typep x 'simple-array)) + (typep x 'simple-array)) (= (array-rank x) (array-rank y)) (equal (array-dimensions x) (array-dimensions y)) (is-similar* (array-element-type x) - (array-element-type y)) + (array-element-type y)) (let ((*similarity-list* - (cons (cons x y) *similarity-list*))) - (loop for i below (array-total-size x) - always (is-similar* (row-major-aref x i) - (row-major-aref y i)))) + (cons (cons x y) *similarity-list*))) + (loop for i below (array-total-size x) + always (is-similar* (row-major-aref x i) + (row-major-aref y i)))) t))) (defmethod is-similar* ((x hash-table) (y hash-table)) @@ -995,128 +995,128 @@ the condition to go uncaught if it cannot be classified." (and (eql x y) t)) (defparameter *initial-print-pprint-dispatch* (if (boundp '*print-pprint-dispatch*) - *print-pprint-dispatch* - nil)) + *print-pprint-dispatch* + nil)) (defmacro my-with-standard-io-syntax (&body body) `(let ((*package* (find-package "COMMON-LISP-USER")) - (*print-array* t) - (*print-base* 10) - (*print-case* :upcase) - (*print-circle* nil) - (*print-escape* t) - (*print-gensym* t) - (*print-length* nil) - (*print-level* nil) - (*print-lines* nil) - (*print-miser-width* nil) - (*print-pprint-dispatch* *initial-print-pprint-dispatch*) - (*print-pretty* nil) - (*print-radix* nil) - (*print-readably* t) - (*print-right-margin* nil) - (*read-base* 10) - (*read-default-float-format* 'single-float) - (*read-eval* t) - (*read-suppress* nil) - (*readtable* (copy-readtable nil))) + (*print-array* t) + (*print-base* 10) + (*print-case* :upcase) + (*print-circle* nil) + (*print-escape* t) + (*print-gensym* t) + (*print-length* nil) + (*print-level* nil) + (*print-lines* nil) + (*print-miser-width* nil) + (*print-pprint-dispatch* *initial-print-pprint-dispatch*) + (*print-pretty* nil) + (*print-radix* nil) + (*print-readably* t) + (*print-right-margin* nil) + (*read-base* 10) + (*read-default-float-format* 'single-float) + (*read-eval* t) + (*read-suppress* nil) + (*readtable* (copy-readtable nil))) ,@body)) ;;; Function to produce a non-simple string (defun make-special-string (string &key fill adjust displace base) (let* ((len (length string)) - (len2 (if fill (+ len 4) len)) - (etype (if base 'base-char 'character))) + (len2 (if fill (+ len 4) len)) + (etype (if base 'base-char 'character))) (if displace - (let ((s0 (make-array (+ len2 5) - :initial-contents - (concatenate 'string - (make-string 2 :initial-element #\X) - string - (make-string (if fill 7 3) - :initial-element #\Y)) - :element-type etype))) - (make-array len2 :element-type etype - :adjustable adjust - :fill-pointer (if fill len nil) - :displaced-to s0 - :displaced-index-offset 2)) + (let ((s0 (make-array (+ len2 5) + :initial-contents + (concatenate 'string + (make-string 2 :initial-element #\X) + string + (make-string (if fill 7 3) + :initial-element #\Y)) + :element-type etype))) + (make-array len2 :element-type etype + :adjustable adjust + :fill-pointer (if fill len nil) + :displaced-to s0 + :displaced-index-offset 2)) (make-array len2 :element-type etype - :initial-contents - (if fill (concatenate 'string string "ZZZZ") string) - :fill-pointer (if fill len nil) - :adjustable adjust)))) + :initial-contents + (if fill (concatenate 'string string "ZZZZ") string) + :fill-pointer (if fill len nil) + :adjustable adjust)))) (defmacro do-special-strings ((var string-form &optional ret-form) &body forms) (let ((string (gensym)) - (fill (gensym "FILL")) - (adjust (gensym "ADJUST")) - (base (gensym "BASE")) - (displace (gensym "DISPLACE"))) + (fill (gensym "FILL")) + (adjust (gensym "ADJUST")) + (base (gensym "BASE")) + (displace (gensym "DISPLACE"))) `(let ((,string ,string-form)) (dolist (,fill '(nil t) ,ret-form) - (dolist (,adjust '(nil t)) - (dolist (,base '(nil t)) - (dolist (,displace '(nil t)) - (let ((,var (make-special-string - ,string - :fill ,fill :adjust ,adjust - :base ,base :displace ,displace))) - ,@forms)))))))) + (dolist (,adjust '(nil t)) + (dolist (,base '(nil t)) + (dolist (,displace '(nil t)) + (let ((,var (make-special-string + ,string + :fill ,fill :adjust ,adjust + :base ,base :displace ,displace))) + ,@forms)))))))) (defun make-special-integer-vector (contents &key fill adjust displace (etype 'integer)) (let* ((len (length contents)) - (min (reduce #'min contents)) - (max (reduce #'max contents)) - (len2 (if fill (+ len 4) len))) + (min (reduce #'min contents)) + (max (reduce #'max contents)) + (len2 (if fill (+ len 4) len))) (unless (and (typep min etype) - (typep max etype)) + (typep max etype)) (setq etype `(integer ,min ,max))) (if displace - (let ((s0 (make-array (+ len2 5) - :initial-contents - (concatenate 'list - (make-list 2 :initial-element - (if (typep 0 etype) 0 min)) - contents - (make-list (if fill 7 3) - :initial-element - (if (typep 1 etype) 1 max))) - :element-type etype))) - (make-array len2 :element-type etype - :adjustable adjust - :fill-pointer (if fill len nil) - :displaced-to s0 - :displaced-index-offset 2)) + (let ((s0 (make-array (+ len2 5) + :initial-contents + (concatenate 'list + (make-list 2 :initial-element + (if (typep 0 etype) 0 min)) + contents + (make-list (if fill 7 3) + :initial-element + (if (typep 1 etype) 1 max))) + :element-type etype))) + (make-array len2 :element-type etype + :adjustable adjust + :fill-pointer (if fill len nil) + :displaced-to s0 + :displaced-index-offset 2)) (make-array len2 :element-type etype - :initial-contents - (if fill (concatenate 'list - contents - (make-list 4 :initial-element - (if (typep 2 etype) 2 (floor (+ min max) 2)))) - contents) - :fill-pointer (if fill len nil) - :adjustable adjust)))) + :initial-contents + (if fill (concatenate 'list + contents + (make-list 4 :initial-element + (if (typep 2 etype) 2 (floor (+ min max) 2)))) + contents) + :fill-pointer (if fill len nil) + :adjustable adjust)))) (defmacro do-special-integer-vectors ((var vec-form &optional ret-form) &body forms) (let ((vector (gensym)) - (fill (gensym "FILL")) - (adjust (gensym "ADJUST")) - (etype (gensym "ETYPE")) - (displace (gensym "DISPLACE"))) + (fill (gensym "FILL")) + (adjust (gensym "ADJUST")) + (etype (gensym "ETYPE")) + (displace (gensym "DISPLACE"))) `(let ((,vector ,vec-form)) (dolist (,fill '(nil t) ,ret-form) - (dolist (,adjust '(nil t)) - (dolist (,etype ',(append (loop for i from 1 to 32 collect `(unsigned-byte ,i)) - (loop for i from 2 to 32 collect `(signed-byte ,i)) - '(integer))) - (dolist (,displace '(nil t)) - (let ((,var (make-special-integer-vector - ,vector - :fill ,fill :adjust ,adjust - :etype ,etype :displace ,displace))) - ,@forms)))))))) + (dolist (,adjust '(nil t)) + (dolist (,etype ',(append (loop for i from 1 to 32 collect `(unsigned-byte ,i)) + (loop for i from 2 to 32 collect `(signed-byte ,i)) + '(integer))) + (dolist (,displace '(nil t)) + (let ((,var (make-special-integer-vector + ,vector + :fill ,fill :adjust ,adjust + :etype ,etype :displace ,displace))) + ,@forms)))))))) ;;; Return T if arg X is a string designator in this implementation @@ -1164,17 +1164,17 @@ the condition to go uncaught if it cannot be classified." actually exist." (or (packagep x) (handler-case (and (locally (declare (optimize safety)) - (string x)) - t) - (type-error () nil)))) + (string x)) + t) + (type-error () nil)))) (defmacro def-fold-test (name form) "Create a test that FORM, which should produce a fresh value, does not improperly introduce sharing during constant folding." `(deftest ,name (flet ((%f () (declare (optimize (speed 3) (safety 0) (space 0) - (compilation-speed 0) (debug 0))) - ,form)) + (compilation-speed 0) (debug 0))) + ,form)) (eq (%f) (%f))) nil)) diff --git a/ansi-tests/append.lsp b/ansi-tests/append.lsp index 7a449417..eb49d6a9 100644 --- a/ansi-tests/append.lsp +++ b/ansi-tests/append.lsp @@ -17,20 +17,20 @@ (deftest append.3 (let ((x (list 'a 'b 'c 'd)) - (y (list 'e 'f 'g))) + (y (list 'e 'f 'g))) (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) + (ycopy (make-scaffold-copy y))) (let ((result (append x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - result)))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + result)))) (a b c d e f g)) (deftest append.4 (append (list 'a) (list 'b) (list 'c) - (list 'd) (list 'e) (list 'f) - (list 'g) 'h) + (list 'd) (list 'e) (list 'f) + (list 'g) 'h) (a b c d e f g . h)) (deftest append.5 @@ -51,17 +51,17 @@ (deftest append.8 (macrolet ((%m (z) z)) - (append (expand-in-current-env (%m '(a b c))))) + (append (expand-in-current-env (%m '(a b c))))) (a b c)) (deftest append.9 (macrolet ((%m (z) z)) - (append (expand-in-current-env (%m (list 1 2 3))) (list 4 5 6))) + (append (expand-in-current-env (%m (list 1 2 3))) (list 4 5 6))) (1 2 3 4 5 6)) (deftest append.10 (macrolet ((%m (z) z)) - (append (list 1 2 3) (expand-in-current-env (%m (list 4 5 6))))) + (append (list 1 2 3) (expand-in-current-env (%m (list 4 5 6))))) (1 2 3 4 5 6)) ;;; Order of evaluation tests @@ -70,8 +70,8 @@ (let ((i 0) x y z) (values (append (progn (setf x (incf i)) (copy-list '(a b c))) - (progn (setf y (incf i)) (copy-list '(d e f))) - (progn (setf z (incf i)) (copy-list '(g h i)))) + (progn (setf y (incf i)) (copy-list '(d e f))) + (progn (setf z (incf i)) (copy-list '(g h i)))) i x y z)) (a b c d e f g h i) 3 1 2 3) @@ -86,10 +86,10 @@ (deftest append.error.1 (signals-error (append '(a . b) '(z)) - type-error) + type-error) t) (deftest append.error.2 (signals-error (append '(x y z) '(a . b) '(z)) - type-error) + type-error) t) diff --git a/ansi-tests/apply.lsp b/ansi-tests/apply.lsp index 5fc0be7b..ca004dfc 100644 --- a/ansi-tests/apply.lsp +++ b/ansi-tests/apply.lsp @@ -21,7 +21,7 @@ (deftest apply.error.4 (signals-error (apply #'cons (list 1 2 3)) - program-error) + program-error) t) ;;; Non-error cases @@ -40,7 +40,7 @@ (deftest apply.4 (let ((zeros (make-list (min 10000 (1- call-arguments-limit)) - :initial-element 1))) + :initial-element 1))) (apply #'+ zeros)) #.(min 10000 (1- call-arguments-limit))) @@ -50,28 +50,28 @@ (deftest apply.6 (macrolet ((%m (z) z)) - (apply (expand-in-current-env (%m 'cons)) 1 2 nil)) + (apply (expand-in-current-env (%m 'cons)) 1 2 nil)) (1 . 2)) (deftest apply.7 (macrolet ((%m (z) z)) - (apply #'cons (expand-in-current-env (%m 1)) '(2))) + (apply #'cons (expand-in-current-env (%m 1)) '(2))) (1 . 2)) (deftest apply.8 (macrolet ((%m (z) z)) - (apply #'cons (expand-in-current-env (%m '(1 2))))) + (apply #'cons (expand-in-current-env (%m '(1 2))))) (1 . 2)) (deftest apply.order.1 (let ((i 0) x y z) (values (apply (progn (setf x (incf i)) - #'list) - (progn (setf y (incf i)) - 'b) - (progn (setf z (incf i)) - (list 'a))) + #'list) + (progn (setf y (incf i)) + 'b) + (progn (setf z (incf i)) + (list 'a))) i x y z)) (b a) 3 1 2 3) diff --git a/ansi-tests/apropos-list.lsp b/ansi-tests/apropos-list.lsp index ee3f2fdf..abe2062a 100644 --- a/ansi-tests/apropos-list.lsp +++ b/ansi-tests/apropos-list.lsp @@ -9,17 +9,17 @@ (let ((pkg "CL-TEST-APROPOS-LIST-PACKAGE")) (safely-delete-package pkg) (unwind-protect - (progn - (eval `(defpackage ,pkg (:use))) - (let* ((sym (intern "FOO" pkg))) - (loop for p in (list pkg (find-package pkg) (make-symbol pkg)) - nconc - (loop for string-designator in - '("F" "O" #\F #\O "" "FOO" "FO" - "OO" :|F| :|FO| :|FOO| :|O| :|OO|) - for result = (apropos-list string-designator p) - unless (equal result (list sym)) - collect (list string-designator result))))) + (progn + (eval `(defpackage ,pkg (:use))) + (let* ((sym (intern "FOO" pkg))) + (loop for p in (list pkg (find-package pkg) (make-symbol pkg)) + nconc + (loop for string-designator in + '("F" "O" #\F #\O "" "FOO" "FO" + "OO" :|F| :|FO| :|FOO| :|O| :|OO|) + for result = (apropos-list string-designator p) + unless (equal result (list sym)) + collect (list string-designator result))))) (safely-delete-package pkg))) nil) @@ -27,15 +27,15 @@ (let ((pkg #\A)) (safely-delete-package pkg) (unwind-protect - (progn - (eval `(defpackage ,pkg (:use))) - (let* ((sym (intern "FOO" pkg))) - (loop for string-designator in - '("F" "O" #\F #\O "" "FOO" "FO" - "OO" :|F| :|FO| :|FOO| :|O| :|OO|) - for result = (apropos-list string-designator pkg) - unless (equal result (list sym)) - collect (list string-designator result)))) + (progn + (eval `(defpackage ,pkg (:use))) + (let* ((sym (intern "FOO" pkg))) + (loop for string-designator in + '("F" "O" #\F #\O "" "FOO" "FO" + "OO" :|F| :|FO| :|FOO| :|O| :|OO|) + for result = (apropos-list string-designator pkg) + unless (equal result (list sym)) + collect (list string-designator result)))) (safely-delete-package pkg))) nil) @@ -43,34 +43,34 @@ (let ((pkg "CL-TEST-APROPOS-LIST-PACKAGE")) (safely-delete-package pkg) (unwind-protect - (progn - (eval `(defpackage ,pkg (:use))) - (intern "FOO" pkg) - (apropos-list "X" pkg)) + (progn + (eval `(defpackage ,pkg (:use))) + (intern "FOO" pkg) + (apropos-list "X" pkg)) (safely-delete-package pkg))) nil) (deftest apropos-list.4 (let ((sym :|X|) - (symbols (apropos-list "X"))) + (symbols (apropos-list "X"))) (notnot (member sym symbols))) t) (deftest apropos-list.5 (let ((sym :|X|) - (symbols (apropos-list '#:|X|))) + (symbols (apropos-list '#:|X|))) (notnot (member sym symbols))) t) (deftest apropos-list.6 (let ((sym :|X|) - (symbols (apropos-list #\X))) + (symbols (apropos-list #\X))) (notnot (member sym symbols))) t) (deftest apropos-list.7 (let ((sym :|X|) - (symbols (apropos-list "X" nil))) + (symbols (apropos-list "X" nil))) (notnot (member sym symbols))) t) @@ -79,15 +79,15 @@ (macrolet ((%m (z) z)) (intersection '(car) - (apropos-list (expand-in-current-env (%m "CAR")))))) + (apropos-list (expand-in-current-env (%m "CAR")))))) (car)) (deftest apropos-list.9 (macrolet ((%m (z) z)) (intersection '(car) - (apropos-list "CAR" (expand-in-current-env - (%m (find-package "COMMON-LISP")))))) + (apropos-list "CAR" (expand-in-current-env + (%m (find-package "COMMON-LISP")))))) (car)) ;;; Error tests diff --git a/ansi-tests/apropos.lsp b/ansi-tests/apropos.lsp index da70a9cb..4c6cd4b6 100644 --- a/ansi-tests/apropos.lsp +++ b/ansi-tests/apropos.lsp @@ -7,23 +7,23 @@ (deftest apropos.1 (loop for n from 10 - for x = (coerce (loop repeat n collect (random-from-seq +standard-chars+)) 'string) - unless (apropos-list x) - return (with-output-to-string (*standard-output*) - (assert (null (multiple-value-list (apropos x)))))) + for x = (coerce (loop repeat n collect (random-from-seq +standard-chars+)) 'string) + unless (apropos-list x) + return (with-output-to-string (*standard-output*) + (assert (null (multiple-value-list (apropos x)))))) "") (deftest apropos.2 (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos "CAR"))))))) + (*standard-output*) + (assert (null (multiple-value-list (apropos "CAR"))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.3 (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos "CAR" (find-package "CL")))))))) + (*standard-output*) + (assert (null (multiple-value-list (apropos "CAR" (find-package "CL")))))))) (notnot (search "CAR" s :test #'string-equal))) t) @@ -32,40 +32,40 @@ (do-special-strings (s "CAR" t) (setq result (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos s)))))) + (*standard-output*) + (assert (null (multiple-value-list (apropos s)))))) (assert (search "CAR" result :test #'string-equal)))) t) (deftest apropos.5 (let ((result nil) - (pkg (find-package "COMMON-LISP"))) + (pkg (find-package "COMMON-LISP"))) (do-special-strings (s "APROPOS" t) (setq result (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos s pkg)))))) + (*standard-output*) + (assert (null (multiple-value-list (apropos s pkg)))))) (assert (search "APROPOS" result :test #'string-equal)))) t) (deftest apropos.6 (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos "CAR" "CL"))))))) + (*standard-output*) + (assert (null (multiple-value-list (apropos "CAR" "CL"))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.7 (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos "CAR" :|CL|))))))) + (*standard-output*) + (assert (null (multiple-value-list (apropos "CAR" :|CL|))))))) (notnot (search "CAR" s :test #'string-equal))) t) (deftest apropos.8 (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list (apropos "CAR" nil))))))) + (*standard-output*) + (assert (null (multiple-value-list (apropos "CAR" nil))))))) (notnot (search "CAR" s :test #'string-equal))) t) @@ -73,9 +73,9 @@ (macrolet ((%m (z) z)) (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list - (apropos (expand-in-current-env (%m "CAR"))))))))) + (*standard-output*) + (assert (null (multiple-value-list + (apropos (expand-in-current-env (%m "CAR"))))))))) (notnot (search "CAR" s :test #'string-equal)))) t) @@ -83,10 +83,10 @@ (macrolet ((%m (z) z)) (let ((s (with-output-to-string - (*standard-output*) - (assert (null (multiple-value-list - (apropos "CAR" - (expand-in-current-env (%m nil))))))))) + (*standard-output*) + (assert (null (multiple-value-list + (apropos "CAR" + (expand-in-current-env (%m nil))))))))) (notnot (search "CAR" s :test #'string-equal)))) t) diff --git a/ansi-tests/aref.lsp b/ansi-tests/aref.lsp index e5597d35..efa080e6 100644 --- a/ansi-tests/aref.lsp +++ b/ansi-tests/aref.lsp @@ -25,10 +25,10 @@ (deftest aref.5 (let ((a (make-array '(2 3) :element-type 'base-char - :initial-contents '("abc" "def")))) + :initial-contents '("abc" "def")))) (loop for i below 2 - collect (loop for j below 3 - collect (aref a i j)))) + collect (loop for j below 3 + collect (aref a i j)))) ((#\a #\b #\c) (#\d #\e #\f))) @@ -38,11 +38,11 @@ (deftest aref.7 (let ((a (make-array '(2 5) :element-type 'bit - :initial-contents '((1 1 0 0 1) - (0 1 0 1 0))))) + :initial-contents '((1 1 0 0 1) + (0 1 0 1 0))))) (loop for i below 2 - collect (loop for j below 5 - collect (aref a i j)))) + collect (loop for j below 5 + collect (aref a i j)))) ((1 1 0 0 1) (0 1 0 1 0))) @@ -52,7 +52,7 @@ (let ((i 0) x y (a #(a b c d))) (values (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 2)) + (progn (setf y (incf i)) 2)) i x y)) c 2 1 2) @@ -60,8 +60,8 @@ (let ((i 0) x y z (a #2a((a b c)(d e f)))) (values (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 1) - (progn (setf z (incf i)) 2)) + (progn (setf y (incf i)) 1) + (progn (setf z (incf i)) 2)) i x y z)) f 3 1 2 3) @@ -127,8 +127,8 @@ (let ((i 0) x y z (a (copy-seq #(a b c d)))) (values (setf (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 2)) - (progn (setf z (incf i)) 'z)) + (progn (setf y (incf i)) 2)) + (progn (setf z (incf i)) 'z)) a i x y z)) z #(a b z d) 3 1 2 3) diff --git a/ansi-tests/arithmetic-error.lsp b/ansi-tests/arithmetic-error.lsp index bcbb1860..12979cef 100644 --- a/ansi-tests/arithmetic-error.lsp +++ b/ansi-tests/arithmetic-error.lsp @@ -6,8 +6,8 @@ (deftest arithmethic-error.1 (let ((a (make-condition 'arithmetic-error - :operation '/ - :operands '(0 0)))) + :operation '/ + :operands '(0 0)))) (values (notnot (typep a 'arithmetic-error)) (notnot (typep a (find-class 'arithmetic-error))) @@ -17,8 +17,8 @@ (deftest arithmethic-error.2 (let ((a (make-condition 'arithmetic-error - :operation #'/ - :operands '(0 0)))) + :operation #'/ + :operands '(0 0)))) (values (notnot (typep a 'arithmetic-error)) (notnot (typep a 'error)) @@ -32,8 +32,8 @@ (deftest arithmetic-error.3 (let ((a (make-condition 'arithmetic-error - :operation '/ - :operands '(0 0)))) + :operation '/ + :operands '(0 0)))) (macrolet ((%m (z) z)) (values @@ -49,10 +49,10 @@ (deftest arithmetic-error-operation.error.2 (signals-error (arithmetic-error-operation - (make-condition 'arithmetic-error :operation '/ - :operands '(1 0)) - nil) - program-error) + (make-condition 'arithmetic-error :operation '/ + :operands '(1 0)) + nil) + program-error) t) (deftest arithmetic-error-operands.error.1 @@ -61,8 +61,8 @@ (deftest arithmetic-error-operands.error.2 (signals-error (arithmetic-error-operands - (make-condition 'arithmetic-error :operation '/ - :operands '(1 0)) - nil) - program-error) + (make-condition 'arithmetic-error :operation '/ + :operands '(1 0)) + nil) + program-error) t) diff --git a/ansi-tests/array-aux.lsp b/ansi-tests/array-aux.lsp index 3304391a..193867de 100644 --- a/ansi-tests/array-aux.lsp +++ b/ansi-tests/array-aux.lsp @@ -14,24 +14,24 @@ (or (not is-known) (notnot is-subtype)))) (defun make-array-with-checks (dimensions - &rest options - &key - (element-type t element-type-p) - (initial-contents nil initial-contents-p) - (initial-element nil initial-element-p) - (adjustable nil) - (fill-pointer nil) - (displaced-to nil) - (displaced-index-offset 0 dio-p) - &aux - (dimensions-list (if (listp dimensions) - dimensions - (list dimensions)))) + &rest options + &key + (element-type t element-type-p) + (initial-contents nil initial-contents-p) + (initial-element nil initial-element-p) + (adjustable nil) + (fill-pointer nil) + (displaced-to nil) + (displaced-index-offset 0 dio-p) + &aux + (dimensions-list (if (listp dimensions) + dimensions + (list dimensions)))) "Call MAKE-ARRAY and do sanity tests on the output." (declare (ignore element-type-p initial-contents initial-contents-p - initial-element initial-element-p dio-p)) + initial-element initial-element-p dio-p)) (let ((a (check-values (apply #'make-array dimensions options))) - (rank (length dimensions-list))) + (rank (length dimensions-list))) (cond ((not (typep a 'array)) @@ -48,7 +48,7 @@ :fail-not-array5) ((not (typep a `(array ,element-type *))) :fail-not-array6) - + ; #-gcl ((not (typep a `(array ,element-type ,rank))) :fail-not-array7) @@ -57,78 +57,78 @@ :fail-not-array8) ((not (typep a `(array ,element-type ,(mapcar (constantly '*) - dimensions-list)))) + dimensions-list)))) :fail-not-array9) ((loop for i from 0 below (min 10 rank) - thereis - (let ((x (append (subseq dimensions-list 0 i) - (list '*) - (subseq dimensions-list (1+ i))))) - (or (not (typep a `(array * ,x))) - (not (typep a `(array ,element-type ,x)))))) + thereis + (let ((x (append (subseq dimensions-list 0 i) + (list '*) + (subseq dimensions-list (1+ i))))) + (or (not (typep a `(array * ,x))) + (not (typep a `(array ,element-type ,x)))))) :fail-not-array10) ((not (check-values (arrayp a))) :fail-not-arrayp) ((and ;; (eq t element-type) - (not adjustable) - (not fill-pointer) - (not displaced-to) - (cond - ((not (typep a 'simple-array)) - :fail-not-simple-array) - ((not (typep a '(simple-array *))) - :fail-not-simple-array2) - ((not (typep a `(simple-array * ,dimensions-list))) - :fail-not-simple-array3) - ((not (typep a `(simple-array * *))) - :fail-not-simple-array4) - ((not (typep a `(simple-array ,element-type))) - :fail-not-simple-array5) - ((not (typep a `(simple-array ,element-type *))) - :fail-not-simple-array6) - #-gcl - ((not (typep a `(simple-array ,element-type - ,rank))) - :fail-not-array7) - ((not (typep a `(simple-array ,element-type ,dimensions-list))) - :fail-not-simple-array8) - ((not (typep a `(simple-array ,element-type - ,(mapcar (constantly '*) - dimensions-list)))) - :fail-not-simple-array9) - ))) + (not adjustable) + (not fill-pointer) + (not displaced-to) + (cond + ((not (typep a 'simple-array)) + :fail-not-simple-array) + ((not (typep a '(simple-array *))) + :fail-not-simple-array2) + ((not (typep a `(simple-array * ,dimensions-list))) + :fail-not-simple-array3) + ((not (typep a `(simple-array * *))) + :fail-not-simple-array4) + ((not (typep a `(simple-array ,element-type))) + :fail-not-simple-array5) + ((not (typep a `(simple-array ,element-type *))) + :fail-not-simple-array6) + #-gcl + ((not (typep a `(simple-array ,element-type + ,rank))) + :fail-not-array7) + ((not (typep a `(simple-array ,element-type ,dimensions-list))) + :fail-not-simple-array8) + ((not (typep a `(simple-array ,element-type + ,(mapcar (constantly '*) + dimensions-list)))) + :fail-not-simple-array9) + ))) ;; If the array is a vector, check that... - ((and (eql rank 1) - (cond - ;; ...It's in type vector - ((not (typep a 'vector)) - :fail-not-vector) - ;; ...If the element type is a subtype of BIT, then it's a - ;; bit vector... - ((and (subtypep 'bit element-type) - (subtypep element-type 'bit) - (or (not (bit-vector-p a)) - (not (typep a 'bit-vector)))) - :fail-not-bit-vector) - ;; ...If not adjustable, fill pointered, or displaced, - ;; then it's a simple vector or simple bit vector - ;; (if the element-type is appropriate) - ((and (not adjustable) - (not fill-pointer) - (not displaced-to) - (cond - ((and (eq t element-type) - (or (not (simple-vector-p a)) - (not (typep a 'simple-vector)))) - :fail-not-simple-vector) - ((and (subtypep 'bit element-type) - (subtypep element-type 'bit) - (or (not (simple-bit-vector-p a)) - (not (typep a 'simple-bit-vector)))) - :fail-not-simple-bit-vector) ))) ))) + ((and (eql rank 1) + (cond + ;; ...It's in type vector + ((not (typep a 'vector)) + :fail-not-vector) + ;; ...If the element type is a subtype of BIT, then it's a + ;; bit vector... + ((and (subtypep 'bit element-type) + (subtypep element-type 'bit) + (or (not (bit-vector-p a)) + (not (typep a 'bit-vector)))) + :fail-not-bit-vector) + ;; ...If not adjustable, fill pointered, or displaced, + ;; then it's a simple vector or simple bit vector + ;; (if the element-type is appropriate) + ((and (not adjustable) + (not fill-pointer) + (not displaced-to) + (cond + ((and (eq t element-type) + (or (not (simple-vector-p a)) + (not (typep a 'simple-vector)))) + :fail-not-simple-vector) + ((and (subtypep 'bit element-type) + (subtypep element-type 'bit) + (or (not (simple-bit-vector-p a)) + (not (typep a 'simple-bit-vector)))) + :fail-not-simple-bit-vector) ))) ))) ;; The dimensions of the array must be initialized properly ((not (equal (array-dimensions a) dimensions-list)) @@ -140,7 +140,7 @@ ;; Arrays other than vectors cannot have fill pointers ((and (not (equal (array-rank a) 1)) - (array-has-fill-pointer-p a)) + (array-has-fill-pointer-p a)) :fail-non-vector-fill-pointer) ;; The actual element type must be a supertype of the element-type @@ -150,55 +150,55 @@ ;; If :adjustable is given, the array must be adjustable. ((and adjustable - (not (check-values (adjustable-array-p a))) - :fail-adjustable)) + (not (check-values (adjustable-array-p a))) + :fail-adjustable)) ;; If :fill-pointer is given, the array must have a fill pointer ((and fill-pointer - (not (check-values (array-has-fill-pointer-p a))) - :fail-has-fill-pointer)) + (not (check-values (array-has-fill-pointer-p a))) + :fail-has-fill-pointer)) ;; If the fill pointer is given as an integer, it must be the value ;; of the fill pointer of the new array ((and (check-values (integerp fill-pointer)) - (not (eql fill-pointer (check-values (fill-pointer a)))) - :fail-fill-pointer-1)) + (not (eql fill-pointer (check-values (fill-pointer a)))) + :fail-fill-pointer-1)) ;; If the fill-pointer argument is t, the fill pointer must be ;; set to the vector size. ((and (eq fill-pointer t) - (not (eql (first dimensions-list) (fill-pointer a))) - :fail-fill-pointer-2)) + (not (eql (first dimensions-list) (fill-pointer a))) + :fail-fill-pointer-2)) ;; If displaced-to another array, check that this is proper ((and displaced-to (multiple-value-bind* (actual-dt actual-dio) - (array-displacement a) - (cond - ((not (eq actual-dt displaced-to)) - :fail-displacement-1) - ((not (eql actual-dio displaced-index-offset)) - :fail-displaced-index-offset))))) + (array-displacement a) + (cond + ((not (eq actual-dt displaced-to)) + :fail-displacement-1) + ((not (eql actual-dio displaced-index-offset)) + :fail-displaced-index-offset))))) ;; Test of array-total-size ((not (eql (check-values (array-total-size a)) - (reduce #'* dimensions-list :initial-value 1))) + (reduce #'* dimensions-list :initial-value 1))) :fail-array-total-size) ;; Test array-row-major-index on all zeros ((and (> (array-total-size a) 0) - (not (eql (check-values - (apply #'array-row-major-index - a (make-list (array-rank a) :initial-element 0))) - 0))) + (not (eql (check-values + (apply #'array-row-major-index + a (make-list (array-rank a) :initial-element 0))) + 0))) :fail-array-row-major-index-0) ;; For the last entry ((and (> (array-total-size a) 0) - (not (eql (apply #'array-row-major-index - a (mapcar #'1- dimensions-list)) - (1- (reduce #'* dimensions-list :initial-value 1))))) + (not (eql (apply #'array-row-major-index + a (mapcar #'1- dimensions-list)) + (1- (reduce #'* dimensions-list :initial-value 1))))) :fail-array-row-major-index-last) ;; No problems -- return the array diff --git a/ansi-tests/array-dimension.lsp b/ansi-tests/array-dimension.lsp index c35b3601..25474a8c 100644 --- a/ansi-tests/array-dimension.lsp +++ b/ansi-tests/array-dimension.lsp @@ -39,20 +39,20 @@ (deftest array-dimension.7 (macrolet ((%m (z) z)) - (array-dimension (expand-in-current-env (%m "abc")) 0)) + (array-dimension (expand-in-current-env (%m "abc")) 0)) 3) (deftest array-dimension.8 (macrolet ((%m (z) z)) - (array-dimension #2a((a b)(c d)(e f)) - (expand-in-current-env (%m 0)))) + (array-dimension #2a((a b)(c d)(e f)) + (expand-in-current-env (%m 0)))) 3) (deftest array-dimension.order.1 (let ((i 0) a b) (values (array-dimension (progn (setf a (incf i)) #(a b c d)) - (progn (setf b (incf i)) 0)) + (progn (setf b (incf i)) 0)) i a b)) 4 2 1 2) @@ -68,5 +68,5 @@ (deftest array-dimension.error.3 (signals-error (array-dimension #(a b c) 0 nil) - program-error) + program-error) t) diff --git a/ansi-tests/array-dimensions.lsp b/ansi-tests/array-dimensions.lsp index 718d13aa..468e903c 100644 --- a/ansi-tests/array-dimensions.lsp +++ b/ansi-tests/array-dimensions.lsp @@ -30,8 +30,8 @@ (deftest array-dimensions.6 (let ((a (make-array '(2 3 4) :adjustable t))) (values (array-dimension a 0) - (array-dimension a 1) - (array-dimension a 2))) + (array-dimension a 1) + (array-dimension a 2))) 2 3 4) (deftest array-dimensions.7 @@ -41,7 +41,7 @@ (deftest array-dimensions.8 (macrolet ((%m (z) z)) (array-dimensions - (expand-in-current-env (%m #2a((a b)(c d)(e f)))))) + (expand-in-current-env (%m #2a((a b)(c d)(e f)))))) (3 2)) ;;; Error tests @@ -52,7 +52,7 @@ (deftest array-dimensions.error.2 (signals-error (array-dimensions #(a b c) nil) - program-error) + program-error) t) (deftest array-dimensions.error.3 @@ -65,5 +65,5 @@ (deftest array-dimensions.error.5 (signals-error (locally (array-dimensions nil)) - type-error) + type-error) t) diff --git a/ansi-tests/array-displacement.lsp b/ansi-tests/array-displacement.lsp index 465bf8c4..84ddb212 100644 --- a/ansi-tests/array-displacement.lsp +++ b/ansi-tests/array-displacement.lsp @@ -18,85 +18,85 @@ (deftest array-displacement.7 (let* ((a (make-array '(10))) - (b (make-array '(10) :displaced-to a))) + (b (make-array '(10) :displaced-to a))) (multiple-value-bind* (dt disp) - (array-displacement b) + (array-displacement b) (and (eqt a dt) - (eqlt disp 0)))) + (eqlt disp 0)))) t) (deftest array-displacement.8 (let* ((a (make-array '(10))) - (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) (multiple-value-bind* (dt disp) - (array-displacement b) + (array-displacement b) (and (eqt a dt) - (eqlt disp 2)))) + (eqlt disp 2)))) t) (deftest array-displacement.9 (let* ((a (make-array '(10) :element-type 'base-char)) - (b (make-array '(5) :displaced-to a :displaced-index-offset 2 - :element-type 'base-char))) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2 + :element-type 'base-char))) (multiple-value-bind* (dt disp) - (array-displacement b) + (array-displacement b) (and (eqt a dt) - (eqlt disp 2)))) + (eqlt disp 2)))) t) (deftest array-displacement.10 (let* ((a (make-array '(10) :element-type 'base-char)) - (b (make-array '(5) :displaced-to a - :element-type 'base-char))) + (b (make-array '(5) :displaced-to a + :element-type 'base-char))) (multiple-value-bind* (dt disp) - (array-displacement b) + (array-displacement b) (and (eqt a dt) - (eqlt disp 0)))) + (eqlt disp 0)))) t) (deftest array-displacement.11 (let* ((a (make-array '(10) :element-type 'bit)) - (b (make-array '(5) :displaced-to a :displaced-index-offset 2 - :element-type 'bit))) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2 + :element-type 'bit))) (multiple-value-bind* (dt disp) - (array-displacement b) + (array-displacement b) (and (eqt a dt) - (eqlt disp 2)))) + (eqlt disp 2)))) t) (deftest array-displacement.12 (let* ((a (make-array '(10) :element-type 'bit)) - (b (make-array '(5) :displaced-to a - :element-type 'bit))) + (b (make-array '(5) :displaced-to a + :element-type 'bit))) (multiple-value-bind* (dt disp) - (array-displacement b) + (array-displacement b) (and (eqt a dt) - (eqlt disp 0)))) + (eqlt disp 0)))) t) (deftest array-displacement.13 (let* ((a (make-array '(10) :element-type '(integer 0 255))) - (b (make-array '(5) :displaced-to a :displaced-index-offset 2 - :element-type '(integer 0 255)))) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2 + :element-type '(integer 0 255)))) (multiple-value-bind* (dt disp) - (array-displacement b) + (array-displacement b) (and (eqt a dt) - (eqlt disp 2)))) + (eqlt disp 2)))) t) (deftest array-displacement.14 (let* ((a (make-array '(10) :element-type '(integer 0 255))) - (b (make-array '(5) :displaced-to a - :element-type '(integer 0 255)))) + (b (make-array '(5) :displaced-to a + :element-type '(integer 0 255)))) (multiple-value-bind* (dt disp) - (array-displacement b) + (array-displacement b) (and (eqt a dt) - (eqlt disp 0)))) + (eqlt disp 0)))) t) (deftest array-displacement.15 (let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j))) - (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) + (b (make-array '(5) :displaced-to a :displaced-index-offset 2))) (macrolet ((%m (z) z)) (multiple-value-bind @@ -110,13 +110,13 @@ (deftest array-displacement.order.1 (let* ((a (make-array '(10))) - (b (make-array '(10) :displaced-to a)) - (i 0)) + (b (make-array '(10) :displaced-to a)) + (i 0)) (multiple-value-bind* (dt disp) - (array-displacement (progn (incf i) b)) + (array-displacement (progn (incf i) b)) (and (eql i 1) - (eqt a dt) - (eqlt disp 0)))) + (eqt a dt) + (eqlt disp 0)))) t) ;;; Error tests diff --git a/ansi-tests/array-element-type.lsp b/ansi-tests/array-element-type.lsp index 46608bde..5cf7ee81 100644 --- a/ansi-tests/array-element-type.lsp +++ b/ansi-tests/array-element-type.lsp @@ -9,7 +9,7 @@ (deftest array-element-type.1 (macrolet ((%m (z) z)) - (notnot (array-element-type (expand-in-current-env (%m #(a b c)))))) + (notnot (array-element-type (expand-in-current-env (%m #(a b c)))))) t) (deftest array-element-type.order.1 diff --git a/ansi-tests/array-in-bounds-p.lsp b/ansi-tests/array-in-bounds-p.lsp index 42169c6c..6ae0d125 100644 --- a/ansi-tests/array-in-bounds-p.lsp +++ b/ansi-tests/array-in-bounds-p.lsp @@ -74,19 +74,19 @@ (deftest array-in-bounds-p.15 (let* ((a1 (make-array '(20))) - (a2 (make-array '(10) :displaced-to a1))) + (a2 (make-array '(10) :displaced-to a1))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) (nil t t t t t t t t t t nil)) (deftest array-in-bounds-p.16 (let* ((a1 (make-array '(20) :element-type 'bit :initial-element 0)) - (a2 (make-array '(10) :displaced-to a1 :element-type 'bit))) + (a2 (make-array '(10) :displaced-to a1 :element-type 'bit))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) (nil t t t t t t t t t t nil)) (deftest array-in-bounds-p.17 (let* ((a1 (make-array '(20) :element-type 'character :initial-element #\x)) - (a2 (make-array '(10) :displaced-to a1 :element-type 'character))) + (a2 (make-array '(10) :displaced-to a1 :element-type 'character))) (loop for i from -1 to 10 collect (notnot (array-in-bounds-p a2 i)))) (nil t t t t t t t t t t nil)) @@ -95,8 +95,8 @@ (deftest array-in-bounds-p.18 (let ((a (make-array '(3 4)))) (loop for i from -1 to 3 collect - (loop for j from -1 to 4 collect - (notnot (array-in-bounds-p a i j))))) + (loop for j from -1 to 4 collect + (notnot (array-in-bounds-p a i j))))) ((nil nil nil nil nil nil) (nil t t t t nil) (nil t t t t nil) @@ -106,8 +106,8 @@ (deftest array-in-bounds-p.19 (let ((a (make-array '(1 3 4) :adjustable t))) (loop for i from -1 to 3 collect - (loop for j from -1 to 4 collect - (notnot (array-in-bounds-p a 0 i j))))) + (loop for j from -1 to 4 collect + (notnot (array-in-bounds-p a 0 i j))))) ((nil nil nil nil nil nil) (nil t t t t nil) (nil t t t t nil) @@ -140,7 +140,7 @@ (deftest array-in-bounds-p.25 (macrolet ((%m (z) z)) - (array-in-bounds-p #(a b) (expand-in-current-env (%m 2)))) + (array-in-bounds-p #(a b) (expand-in-current-env (%m 2)))) nil) ;;; Order of evaluation tests @@ -149,9 +149,9 @@ (let ((x 0) y z) (values (array-in-bounds-p (progn (setf y (incf x)) - #()) - (progn (setf z (incf x)) - 10)) + #()) + (progn (setf z (incf x)) + 10)) x y z)) nil 2 1 2) diff --git a/ansi-tests/array-rank.lsp b/ansi-tests/array-rank.lsp index fd282127..ebc66db6 100644 --- a/ansi-tests/array-rank.lsp +++ b/ansi-tests/array-rank.lsp @@ -13,7 +13,7 @@ (deftest array-rank.2 (check-predicate #'(lambda (e) (or (not (typep e 'vector)) - (eql (array-rank e) 1)))) + (eql (array-rank e) 1)))) nil) (deftest array-rank.3 diff --git a/ansi-tests/array-row-major-index.lsp b/ansi-tests/array-row-major-index.lsp index e57f0603..c6db17b6 100644 --- a/ansi-tests/array-row-major-index.lsp +++ b/ansi-tests/array-row-major-index.lsp @@ -13,13 +13,13 @@ (deftest array-row-major-index.2 (loop for i from 0 to 4 - collect (array-row-major-index #(a b c d e) i)) + collect (array-row-major-index #(a b c d e) i)) (0 1 2 3 4)) (deftest array-row-major-index.3 (let ((a (make-array '(5) :fill-pointer 1))) (loop for i from 0 to 4 - collect (array-row-major-index a i))) + collect (array-row-major-index a i))) (0 1 2 3 4)) (deftest array-row-major-index.4 @@ -36,7 +36,7 @@ (deftest array-row-major-index.order.1 (let ((x 0) y z - (a #(a b c d e f))) + (a #(a b c d e f))) (values (array-row-major-index (progn (setf y (incf x)) a) diff --git a/ansi-tests/array-t.lsp b/ansi-tests/array-t.lsp index c6aa154c..d9354fe7 100644 --- a/ansi-tests/array-t.lsp +++ b/ansi-tests/array-t.lsp @@ -167,7 +167,7 @@ (deftest array-t.8.1 (typep #() '(array t (1))) nil) - + (deftest array-t.8.2 (notnot-mv (typep #() '(array t (0)))) t) @@ -179,7 +179,7 @@ (deftest array-t.8.4 (typep #(a b c) '(array t (2))) nil) - + (deftest array-t.8.5 (notnot-mv (typep #(a b c) '(array t (3)))) t) @@ -207,7 +207,7 @@ (deftest array-t.8.11 (typep "abc" '(array t (2))) nil) - + (deftest array-t.8.12 (typep "abc" '(array t (3))) nil) diff --git a/ansi-tests/array-total-size.lsp b/ansi-tests/array-total-size.lsp index 05ad68b7..2655175f 100644 --- a/ansi-tests/array-total-size.lsp +++ b/ansi-tests/array-total-size.lsp @@ -29,7 +29,7 @@ (deftest array-total-size.6 (macrolet ((%m (z) z)) - (array-total-size (expand-in-current-env (%m #(a b c))))) + (array-total-size (expand-in-current-env (%m #(a b c))))) 3) (deftest array-total-size.order.1 diff --git a/ansi-tests/array.lsp b/ansi-tests/array.lsp index 11bfae77..75ac0f1f 100644 --- a/ansi-tests/array.lsp +++ b/ansi-tests/array.lsp @@ -222,7 +222,7 @@ (deftest array.8.1 (typep #() '(array * (1))) nil) - + (deftest array.8.2 (notnot-mv (typep #() '(array * (0)))) t) @@ -234,7 +234,7 @@ (deftest array.8.4 (typep #(a b c) '(array * (2))) nil) - + (deftest array.8.5 (notnot-mv (typep #(a b c) '(array * (3)))) t) @@ -262,7 +262,7 @@ (deftest array.8.11 (typep "abc" '(array * (2))) nil) - + (deftest array.8.12 (notnot-mv (typep "abc" '(array * (3)))) t) diff --git a/ansi-tests/ash.lsp b/ansi-tests/ash.lsp index ad7db5b3..9ee802f8 100644 --- a/ansi-tests/ash.lsp +++ b/ansi-tests/ash.lsp @@ -31,36 +31,36 @@ (deftest ash.1 (loop for x in *integers* - always (eql (ash x 0) x)) + always (eql (ash x 0) x)) t) (deftest ash.2 (loop for i = (random-fixnum) - for s = (random-from-interval 40) - for ishifted = (ash i s) - repeat 1000 - always (eql (floor (* i (expt 2 s))) ishifted)) + for s = (random-from-interval 40) + for ishifted = (ash i s) + repeat 1000 + always (eql (floor (* i (expt 2 s))) ishifted)) t) (deftest ash.3 (let* ((nbits 100) - (bound (expt 2 nbits))) + (bound (expt 2 nbits))) (loop for i = (random-from-interval bound) - for s = (random-from-interval (+ nbits 20)) - for ishifted = (ash i s) - repeat 1000 - always (eql (floor (* i (expt 2 s))) ishifted))) + for s = (random-from-interval (+ nbits 20)) + for ishifted = (ash i s) + repeat 1000 + always (eql (floor (* i (expt 2 s))) ishifted))) t) (deftest ash.4 (loop for i from -1 downto -1000 - always (eql (ash i i) -1)) + always (eql (ash i i) -1)) t) (deftest ash.5 (loop for i from 1 to 100 - for j = (- (ash 1 i)) - always (eql (ash j j) -1)) + for j = (- (ash 1 i)) + always (eql (ash j j) -1)) t) (deftest ash.6 @@ -74,6 +74,6 @@ (deftest ash.order.1 (let ((i 0) x y) (values (ash (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2)) - i x y)) + (progn (setf y (incf i)) 2)) + i x y)) 4 2 1 2) diff --git a/ansi-tests/asin.lsp b/ansi-tests/asin.lsp index c723e362..2b544ba1 100644 --- a/ansi-tests/asin.lsp +++ b/ansi-tests/asin.lsp @@ -7,50 +7,50 @@ (deftest asin.1 (loop for i from -1000 to 1000 - for rlist = (multiple-value-list (asin i)) - for y = (car rlist) - always (and (null (cdr rlist)) - (numberp y))) + for rlist = (multiple-value-list (asin i)) + for y = (car rlist) + always (and (null (cdr rlist)) + (numberp y))) t) (deftest asin.2 (loop for type in '(short-float single-float double-float long-float) - collect - (let ((a (coerce 2000 type)) - (b (coerce -1000 type))) - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (asin x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (numberp y))))) + collect + (let ((a (coerce 2000 type)) + (b (coerce -1000 type))) + (loop for x = (- (random a) b) + for rlist = (multiple-value-list (asin x)) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (numberp y))))) (t t t t)) (deftest asin.3 (loop for type in '(integer short-float single-float double-float long-float) - collect - (let ((a (coerce 2000 type)) - (b (coerce -1000 type))) - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (asin (complex 0 x))) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (numberp y))))) + collect + (let ((a (coerce 2000 type)) + (b (coerce -1000 type))) + (loop for x = (- (random a) b) + for rlist = (multiple-value-list (asin (complex 0 x))) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (numberp y))))) (t t t t t)) (deftest asin.4 (loop for type in '(integer short-float single-float double-float long-float) - collect - (let ((a (coerce 2000 type)) - (b (coerce -1000 type))) - (loop for x1 = (- (random a) b) - for x2 = (- (random a) b) - for rlist = (multiple-value-list (asin (complex x1 x2))) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (numberp y))))) + collect + (let ((a (coerce 2000 type)) + (b (coerce -1000 type))) + (loop for x1 = (- (random a) b) + for x2 = (- (random a) b) + for rlist = (multiple-value-list (asin (complex x1 x2))) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (numberp y))))) (t t t t t)) (deftest asin.5 @@ -59,23 +59,23 @@ (deftest asin.6 (loop for type in '(single-float short-float double-float long-float) - unless (approx= (asin (coerce 1 type)) - (coerce (/ pi 2) type)) - collect type) + unless (approx= (asin (coerce 1 type)) + (coerce (/ pi 2) type)) + collect type) nil) (deftest asin.7 (loop for type in '(single-float short-float double-float long-float) - unless (approx= (asin (coerce 0 type)) - (coerce 0 type)) - collect type) + unless (approx= (asin (coerce 0 type)) + (coerce 0 type)) + collect type) nil) (deftest asin.8 (loop for type in '(single-float short-float double-float long-float) - unless (approx= (asin (coerce -1 type)) - (coerce (/ pi -2) type)) - collect type) + unless (approx= (asin (coerce -1 type)) + (coerce (/ pi -2) type)) + collect type) nil) (deftest asin.9 diff --git a/ansi-tests/asinh.lsp b/ansi-tests/asinh.lsp index 44f832e0..59fce002 100644 --- a/ansi-tests/asinh.lsp +++ b/ansi-tests/asinh.lsp @@ -8,62 +8,62 @@ (deftest asinh.1 (let ((result (asinh 0))) (or (eqlt result 0) - (eqlt result 0.0))) + (eqlt result 0.0))) t) (deftest asinh.2 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - unless (equal (multiple-value-list (asinh zero)) - (list zero)) - collect type) + for zero = (coerce 0 type) + unless (equal (multiple-value-list (asinh zero)) + (list zero)) + collect type) nil) (deftest asinh.3 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 `(complex ,type)) - unless (equal (multiple-value-list (asinh zero)) - (list zero)) - collect type) + for zero = (coerce 0 `(complex ,type)) + unless (equal (multiple-value-list (asinh zero)) + (list zero)) + collect type) nil) (deftest asinh.4 (loop for den = (1+ (random 10000)) - for num = (random (* 10 den)) - for x = (/ num den) - for rlist = (multiple-value-list (asinh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (numberp y)) - collect (list x rlist)) + for num = (random (* 10 den)) + for x = (/ num den) + for rlist = (multiple-value-list (asinh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (numberp y)) + collect (list x rlist)) nil) (deftest asinh.5 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (asinh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) + nconc + (loop + for x = (- (random (coerce 20 type)) 10) + for rlist = (multiple-value-list (asinh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y type)) + collect (list x rlist))) nil) (deftest asinh.6 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 20 type)) 10) - for x2 = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (asinh (complex x1 x2))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 x2 rlist))) + nconc + (loop + for x1 = (- (random (coerce 20 type)) 10) + for x2 = (- (random (coerce 20 type)) 10) + for rlist = (multiple-value-list (asinh (complex x1 x2))) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y `(complex ,type))) + collect (list x1 x2 rlist))) nil) (deftest asinh.7 @@ -91,7 +91,7 @@ - - - + + + diff --git a/ansi-tests/assert.lsp b/ansi-tests/assert.lsp index 706447bb..ac50ebed 100644 --- a/ansi-tests/assert.lsp +++ b/ansi-tests/assert.lsp @@ -20,9 +20,9 @@ (let ((x nil)) (handler-bind ((error #'(lambda (c) - (setq x 17) - (let ((r (find-restart 'continue c))) - (when r (invoke-restart r)))))) + (setq x 17) + (let ((r (find-restart 'continue c))) + (when r (invoke-restart r)))))) (assert x) x)) 17) @@ -31,8 +31,8 @@ (let ((x nil)) (handler-bind ((error #'(lambda (c) - (setq x 17) - (continue c)))) + (setq x 17) + (continue c)))) (assert x) x)) 17) @@ -56,15 +56,15 @@ (deftest assert.6 (let ((x (vector 'a 'b 'c))) (assert t ((aref x 0) (aref x 1) (aref x 2)) - "Vector x has value: ~A." x)) + "Vector x has value: ~A." x)) nil) (deftest assert.7 (let ((x nil)) (handler-bind ((simple-error #'(lambda (c) - (setq x 17) - (continue c)))) + (setq x 17) + (continue c)))) (assert x () 'simple-error) x)) 17) @@ -73,8 +73,8 @@ (let ((x 0)) (handler-bind ((type-error #'(lambda (c) - (incf x) - (continue c)))) + (incf x) + (continue c)))) (assert (> x 5) () 'type-error) x)) 6) @@ -83,8 +83,8 @@ (let ((x 0)) (handler-bind ((type-error #'(lambda (c) (declare (ignore c)) - (incf x) - (continue)))) + (incf x) + (continue)))) (assert (> x 5) () 'type-error) x)) 6) diff --git a/ansi-tests/assoc-if-not.lsp b/ansi-tests/assoc-if-not.lsp index 192354e1..37a969ac 100644 --- a/ansi-tests/assoc-if-not.lsp +++ b/ansi-tests/assoc-if-not.lsp @@ -9,8 +9,8 @@ (deftest assoc-if-not.1 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if-not #'oddp x))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) @@ -19,8 +19,8 @@ (deftest assoc-if-not.2 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if-not #'evenp x :key #'1+))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if-not #'evenp x :key #'1+))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) @@ -29,8 +29,8 @@ (deftest assoc-if-not.3 (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if-not #'oddp x))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) (eqt result (fourth x)) @@ -47,8 +47,8 @@ (let ((i 0) x y) (values (assoc-if-not (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) - '((a . 1) (b . 2) (nil . 17) (d . 4)))) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4)))) i x y)) (nil . 17) 2 1 2) @@ -56,9 +56,9 @@ (let ((i 0) x y z) (values (assoc-if-not (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) - '((a . 1) (b . 2) (nil . 17) (d . 4))) - :key (progn (setf z (incf i)) #'null)) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4))) + :key (progn (setf z (incf i)) #'null)) i x y z)) (a . 1) 3 1 2 3) @@ -66,17 +66,17 @@ (deftest assoc-if-not.allow-other-keys.1 (assoc-if-not #'identity - '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) + '((a . 1) (nil . 2) (c . 3)) :bad t :allow-other-keys t) (nil . 2)) (deftest assoc-if-not.allow-other-keys.2 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) - :allow-other-keys t :also-bad t) + :allow-other-keys t :also-bad t) (nil . 2)) (deftest assoc-if-not.allow-other-keys.3 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) - :allow-other-keys t :also-bad t :key #'not) + :allow-other-keys t :also-bad t :key #'not) (a . 1)) (deftest assoc-if-not.allow-other-keys.4 @@ -89,7 +89,7 @@ (deftest assoc-if-not.keywords.6 (assoc-if-not #'identity '((a . 1) (nil . 2) (c . 3)) - :key #'identity :key #'null) + :key #'identity :key #'null) (nil . 2)) (deftest assoc-if-not.keywords.7 @@ -120,7 +120,7 @@ ))) (4 . c) (4 . c)) - + ;;; Error tests (deftest assoc-if-not.error.1 @@ -133,32 +133,32 @@ (deftest assoc-if-not.error.3 (signals-error (assoc-if-not #'null nil :bad t) - program-error) + program-error) t) (deftest assoc-if-not.error.4 (signals-error (assoc-if-not #'null nil :key) - program-error) + program-error) t) (deftest assoc-if-not.error.5 (signals-error (assoc-if-not #'null nil 1 1) - program-error) + program-error) t) (deftest assoc-if-not.error.6 (signals-error (assoc-if-not #'null nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest assoc-if-not.error.7 (signals-error (assoc-if-not #'cons '((a b)(c d))) - program-error) + program-error) t) (deftest assoc-if-not.error.8 (signals-error (assoc-if-not #'identity '((a b)(c d)) :key #'cons) - program-error) + program-error) t) (deftest assoc-if-not.error.9 @@ -171,12 +171,12 @@ (deftest assoc-if-not.error.11 (signals-error (assoc-if-not #'identity '((a . b) . c)) - type-error) + type-error) t) (deftest assoc-if-not.error.12 (signals-error (assoc-if-not #'identity '((a . b) :bad (c . d))) - type-error) + type-error) t) (deftest assoc-if-not.error.13 diff --git a/ansi-tests/assoc-if.lsp b/ansi-tests/assoc-if.lsp index 0e00f639..2dd39d9f 100644 --- a/ansi-tests/assoc-if.lsp +++ b/ansi-tests/assoc-if.lsp @@ -9,8 +9,8 @@ (deftest assoc-if.1 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if #'evenp x))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) @@ -19,8 +19,8 @@ (deftest assoc-if.2 (let* ((x (copy-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if #'oddp x :key #'1+))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'oddp x :key #'1+))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) @@ -29,8 +29,8 @@ (deftest assoc-if.3 (let* ((x (copy-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc-if #'evenp x))) + (xcopy (make-scaffold-copy x)) + (result (assoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) (eqt result (fourth x)) @@ -52,8 +52,8 @@ (let ((i 0) x y) (values (assoc-if (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) - '((a . 1) (b . 2) (nil . 17) (d . 4)))) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4)))) i x y)) (nil . 17) 2 1 2) @@ -61,9 +61,9 @@ (let ((i 0) x y z) (values (assoc-if (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) - '((a . 1) (b . 2) (nil . 17) (d . 4))) - :key (progn (setf z (incf i)) #'null)) + (progn (setf y (incf i)) + '((a . 1) (b . 2) (nil . 17) (d . 4))) + :key (progn (setf z (incf i)) #'null)) i x y z)) (a . 1) 3 1 2 3) @@ -75,12 +75,12 @@ (deftest assoc-if.allow-other-keys.2 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) - :allow-other-keys t :also-bad t) + :allow-other-keys t :also-bad t) (nil . 2)) (deftest assoc-if.allow-other-keys.3 (assoc-if #'null '((a . 1) (nil . 2) (c . 3)) - :allow-other-keys t :also-bad t :key #'not) + :allow-other-keys t :also-bad t :key #'not) (a . 1)) (deftest assoc-if.allow-other-keys.4 @@ -116,7 +116,7 @@ (6 . c) (6 . c) (6 . c) - (6 . c)) + (6 . c)) ;;; Error cases @@ -130,32 +130,32 @@ (deftest assoc-if.error.3 (signals-error (assoc-if #'null nil :bad t) - program-error) + program-error) t) (deftest assoc-if.error.4 (signals-error (assoc-if #'null nil :key) - program-error) + program-error) t) (deftest assoc-if.error.5 (signals-error (assoc-if #'null nil 1 1) - program-error) + program-error) t) (deftest assoc-if.error.6 (signals-error (assoc-if #'null nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest assoc-if.error.7 (signals-error (assoc-if #'cons '((a b)(c d))) - program-error) + program-error) t) (deftest assoc-if.error.8 (signals-error (assoc-if #'identity '((a b)(c d)) :key #'cons) - program-error) + program-error) t) (deftest assoc-if.error.9 @@ -168,12 +168,12 @@ (deftest assoc-if.error.11 (signals-error (assoc-if #'null '((a . b) . c)) - type-error) + type-error) t) (deftest assoc-if.error.12 (signals-error (assoc-if #'null '((a . b) :bad (c . d))) - type-error) + type-error) t) (deftest assoc-if.error.13 diff --git a/ansi-tests/assoc.lsp b/ansi-tests/assoc.lsp index 7fae17b3..b2cbb885 100644 --- a/ansi-tests/assoc.lsp +++ b/ansi-tests/assoc.lsp @@ -33,8 +33,8 @@ (deftest assoc.7 (let* ((x (copy-tree '((a . b) (b . c) (c . d)))) - (xcopy (make-scaffold-copy x)) - (result (assoc 'b x))) + (xcopy (make-scaffold-copy x)) + (result (assoc 'b x))) (and (eqt result (second x)) (check-scaffold-copy x xcopy))) @@ -46,7 +46,7 @@ (deftest assoc.9 (assoc (copy-seq "abc") - '((abc . 1) ("abc" . 2) ("abc" . 3))) + '((abc . 1) ("abc" . 2) ("abc" . 3))) nil) (deftest assoc.10 @@ -61,67 +61,67 @@ (deftest assoc.12 (assoc #\e '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)) - :key #'(lambda (x) (schar x 1))) + :key #'(lambda (x) (schar x 1))) ("aevgd" . 2)) (deftest assoc.13 (assoc nil '(((a) . b) ( nil . c ) ((nil) . d)) - :key #'car) + :key #'car) (nil . c)) (deftest assoc.14 (assoc (copy-seq "abc") - '((abc . 1) ("abc" . 2) ("abc" . 3)) - :test #'equal) + '((abc . 1) ("abc" . 2) ("abc" . 3)) + :test #'equal) ("abc" . 2)) (deftest assoc.15 (assoc (copy-seq "abc") - '((abc . 1) ("abc" . 2) ("abc" . 3)) - :test #'equalp) + '((abc . 1) ("abc" . 2) ("abc" . 3)) + :test #'equalp) ("abc" . 2)) (deftest assoc.16 (assoc (copy-list '(a)) (copy-tree '(((a) b) ((a) (c)))) - :test #'equal) + :test #'equal) ((a) b)) (deftest assoc.17 (assoc (copy-seq "abc") - '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)) - :test-not (complement #'equalp)) + '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)) + :test-not (complement #'equalp)) ("abc" . 2)) (deftest assoc.18 (assoc 'a '((a . d)(b . c)) :test-not #'eq) (b . c)) - + (deftest assoc.19 (assoc 'a '((a . d)(b . c)) :test (complement #'eq)) (b . c)) (deftest assoc.20 (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) - :key #'(lambda (x) (and (stringp x) (string-downcase x))) - :test #'equal) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test #'equal) ("A" . 6)) (deftest assoc.21 (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) - :key #'(lambda (x) (and (stringp x) x)) - :test #'equal) + :key #'(lambda (x) (and (stringp x) x)) + :test #'equal) ("a" . 3)) (deftest assoc.22 (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) - :key #'(lambda (x) (and (stringp x) (string-downcase x))) - :test-not (complement #'equal)) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test-not (complement #'equal)) ("A" . 6)) (deftest assoc.23 (assoc "a" '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)) - :key #'(lambda (x) (and (stringp x) x)) - :test-not (complement #'equal)) + :key #'(lambda (x) (and (stringp x) x)) + :test-not (complement #'equal)) ("a" . 3)) ;; Check that it works when test returns a true value @@ -129,7 +129,7 @@ (deftest assoc.24 (assoc 'a '((b . 1) (a . 2) (c . 3)) - :test #'(lambda (x y) (and (eqt x y) 'matched))) + :test #'(lambda (x y) (and (eqt x y) 'matched))) (a . 2)) ;; Check that the order of the arguments to test is correct @@ -137,9 +137,9 @@ (deftest assoc.25 (block fail (assoc 'a '((b . 1) (c . 2) (a . 3)) - :test #'(lambda (x y) - (unless (eqt x 'a) (return-from fail 'fail)) - (eqt x y)))) + :test #'(lambda (x y) + (unless (eqt x 'a) (return-from fail 'fail)) + (eqt x y)))) (a . 3)) ;;; Order of test arguments @@ -160,7 +160,7 @@ (deftest assoc.31 (let () (assoc nil '((a . b) nil (c . d) (nil . e) (nil . f) nil (g . h)) - :test #'eq)) + :test #'eq)) (nil . e)) ;;; :test & :test-not together are harmless @@ -177,7 +177,7 @@ (let ((i 0) x y) (values (assoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4)))) + (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4)))) i x y)) (c . 3) 2 1 2) @@ -185,8 +185,8 @@ (let ((i 0) x y z) (values (assoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) - :test (progn (setf z (incf i)) #'eq)) + (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) + :test (progn (setf z (incf i)) #'eq)) i x y z)) (c . 3) 3 1 2 3) @@ -194,8 +194,8 @@ (let ((i 0) x y) (values (assoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) - :test #'eq) + (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) + :test #'eq) i x y)) (c . 3) 2 1 2) @@ -203,9 +203,9 @@ (let ((i 0) x y z w) (values (assoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf w (incf i)) #'not)) + (progn (setf y (incf i)) '((a . 1) (b . 2) (c . 3) (d . 4))) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf w (incf i)) #'not)) i x y z w)) (c . 3) 4 1 2 3 4) @@ -221,7 +221,7 @@ (deftest assoc.allow-other-keys.3 (assoc 'b '((a . 1) (b . 2) (c . 3)) :allow-other-keys t :also-bad t - :test-not #'eql) + :test-not #'eql) (a . 1)) (deftest assoc.allow-other-keys.4 @@ -263,32 +263,32 @@ (deftest assoc.error.6 (signals-error (assoc nil nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest assoc.error.7 (signals-error (assoc 'a '((a . b)) :test #'identity) - program-error) + program-error) t) (deftest assoc.error.8 (signals-error (assoc 'a '((a . b)) :test-not #'identity) - program-error) + program-error) t) (deftest assoc.error.9 (signals-error (assoc 'a '((a . b)) :key #'cons) - program-error) + program-error) t) (deftest assoc.error.10 (signals-error (assoc 'z '((a . b) . c)) - type-error) + type-error) t) (deftest assoc.error.11 (signals-error (assoc 'z '((a . b) :bad (c . d))) - type-error) + type-error) t) (deftest assoc.error.12 diff --git a/ansi-tests/atan.lsp b/ansi-tests/atan.lsp index 50b55b1c..66cb1eea 100644 --- a/ansi-tests/atan.lsp +++ b/ansi-tests/atan.lsp @@ -8,97 +8,97 @@ (deftest atan.1 (let ((result (atan 0))) (or (eqlt result 0) - (eqlt result 0.0))) + (eqlt result 0.0))) t) (deftest atan.2 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - unless (eql (atan zero) zero) - collect type) + for zero = (coerce 0 type) + unless (eql (atan zero) zero) + collect type) nil) (deftest atan.3 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - unless (eql (atan zero 1) zero) - collect type) + for zero = (coerce 0 type) + unless (eql (atan zero 1) zero) + collect type) nil) (deftest atan.4 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - for one = (coerce 1 type) - unless (eql (atan 0 one) zero) - collect type) + for zero = (coerce 0 type) + for one = (coerce 1 type) + unless (eql (atan 0 one) zero) + collect type) nil) (deftest atan.5 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - for one = (coerce 1 type) - unless (eql (atan zero one) zero) - collect type) + for zero = (coerce 0 type) + for one = (coerce 1 type) + unless (eql (atan zero one) zero) + collect type) nil) (deftest atan.6 (loop for type in '(short-float single-float double-float long-float) - for a = (coerce 2000 type) - for b = (coerce -1000 type) - collect - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (atan x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) + for a = (coerce 2000 type) + for b = (coerce -1000 type) + collect + (loop for x = (- (random a) b) + for rlist = (multiple-value-list (atan x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y type)) + collect (list x rlist))) (nil nil nil nil)) (deftest atan.7 (loop for type in '(short-float single-float double-float long-float) - for a = (coerce 2000 type) - for b = (coerce -1000 type) - for zero = (coerce 0 type) - collect - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (atan (complex x zero))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x rlist))) + for a = (coerce 2000 type) + for b = (coerce -1000 type) + for zero = (coerce 0 type) + collect + (loop for x = (- (random a) b) + for rlist = (multiple-value-list (atan (complex x zero))) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y `(complex ,type))) + collect (list x rlist))) (nil nil nil nil)) (deftest atan.8 (loop for type in '(short-float single-float double-float long-float) - for a = (coerce 2000 type) - for b = (coerce -1000 type) - for zero = (coerce 0 type) - collect - (loop for x = (- (random a) b) - for rlist = (multiple-value-list (atan (complex zero x))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x rlist))) + for a = (coerce 2000 type) + for b = (coerce -1000 type) + for zero = (coerce 0 type) + collect + (loop for x = (- (random a) b) + for rlist = (multiple-value-list (atan (complex zero x))) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y `(complex ,type))) + collect (list x rlist))) (nil nil nil nil)) (deftest atan.9 (loop for type in '(short-float single-float double-float long-float) - for a = (coerce 2000 type) - for b = (coerce -1000 type) - for zero = (coerce 0 type) - collect - (loop for x1 = (- (random a) b) - for x2 = (- (random a) b) - for rlist = (multiple-value-list (atan (complex x1 x2))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 x2 rlist))) + for a = (coerce 2000 type) + for b = (coerce -1000 type) + for zero = (coerce 0 type) + collect + (loop for x1 = (- (random a) b) + for x2 = (- (random a) b) + for rlist = (multiple-value-list (atan (complex x1 x2))) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y `(complex ,type))) + collect (list x1 x2 rlist))) (nil nil nil nil)) (deftest atan.10 @@ -107,7 +107,7 @@ (deftest atan.11 (loop for type in '(short-float single-float double-float long-float) - collect (approx= (atan (coerce 1 type)) (coerce (/ pi 4) type))) + collect (approx= (atan (coerce 1 type)) (coerce (/ pi 4) type))) (t t t t)) (deftest atan.12 @@ -116,7 +116,7 @@ (deftest atan.13 (loop for type in '(short-float single-float double-float long-float) - collect (approx= (atan (coerce -1 type)) (coerce (/ pi -4) type))) + collect (approx= (atan (coerce -1 type)) (coerce (/ pi -4) type))) (t t t t)) (deftest atan.14 diff --git a/ansi-tests/atanh.lsp b/ansi-tests/atanh.lsp index 94e883a3..624c31b2 100644 --- a/ansi-tests/atanh.lsp +++ b/ansi-tests/atanh.lsp @@ -8,89 +8,89 @@ (deftest atanh.1 (let ((result (atanh 0))) (or (eqlt result 0) - (eqlt result 0.0))) + (eqlt result 0.0))) t) (deftest atanh.2 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - unless (equal (multiple-value-list (atanh zero)) - (list zero)) - collect type) + for zero = (coerce 0 type) + unless (equal (multiple-value-list (atanh zero)) + (list zero)) + collect type) nil) (deftest atanh.3 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 `(complex ,type)) - unless (equal (multiple-value-list (atanh zero)) - (list zero)) - collect type) + for zero = (coerce 0 `(complex ,type)) + unless (equal (multiple-value-list (atanh zero)) + (list zero)) + collect type) nil) (deftest atanh.4 (loop for den = (1+ (random 10000)) - for num = (random den) - for x = (/ num den) - for rlist = (multiple-value-list (atanh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (numberp y)) - collect (list x rlist)) + for num = (random den) + for x = (/ num den) + for rlist = (multiple-value-list (atanh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (numberp y)) + collect (list x rlist)) nil) (deftest atanh.5 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (if (eql (random 2) 0) - (+ 2 (random (coerce 1000 type))) - (- -2 (random (coerce 1000 type)))) - for rlist = (multiple-value-list (atanh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x rlist))) + nconc + (loop + for x = (if (eql (random 2) 0) + (+ 2 (random (coerce 1000 type))) + (- -2 (random (coerce 1000 type)))) + for rlist = (multiple-value-list (atanh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y `(complex ,type))) + collect (list x rlist))) nil) (deftest atanh.5a (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (- (random (coerce 1.9998s0 type)) 0.9999s0) - for rlist = (multiple-value-list (atanh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) + nconc + (loop + for x = (- (random (coerce 1.9998s0 type)) 0.9999s0) + for rlist = (multiple-value-list (atanh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y type)) + collect (list x rlist))) nil) (deftest atanh.6 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 1.9998s0 type)) 0.9999s0) - for rlist = (multiple-value-list (atanh (complex x1 0.0s0))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 rlist))) + nconc + (loop + for x1 = (- (random (coerce 1.9998s0 type)) 0.9999s0) + for rlist = (multiple-value-list (atanh (complex x1 0.0s0))) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y `(complex ,type))) + collect (list x1 rlist))) nil) (deftest atanh.7 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 1.9998s0 type)) 0.9999s0) - for rlist = (multiple-value-list (atanh (complex 0.0s0 x1))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 rlist))) + nconc + (loop + for x1 = (- (random (coerce 1.9998s0 type)) 0.9999s0) + for rlist = (multiple-value-list (atanh (complex 0.0s0 x1))) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y `(complex ,type))) + collect (list x1 rlist))) nil) (deftest atanh.8 diff --git a/ansi-tests/atom-errors.lsp b/ansi-tests/atom-errors.lsp index 874fae21..d68db59a 100644 --- a/ansi-tests/atom-errors.lsp +++ b/ansi-tests/atom-errors.lsp @@ -35,5 +35,5 @@ TWO-WAY-STREAM STREAM-ERROR END-OF-FILE PRINT-NOT-READABLE - READER-ERROR) + READER-ERROR) collect (list tp (multiple-value-list (subtypep* tp 'atom))))) diff --git a/ansi-tests/atom.lsp b/ansi-tests/atom.lsp index 2cc53b19..9e1e57e7 100644 --- a/ansi-tests/atom.lsp +++ b/ansi-tests/atom.lsp @@ -9,8 +9,8 @@ (deftest atom.1 (loop for x in *universe* - unless (if (atom x) (not (consp x)) (consp x)) - collect x) + unless (if (atom x) (not (consp x)) (consp x)) + collect x) nil) (deftest atom.2 diff --git a/ansi-tests/backquote-aux.lsp b/ansi-tests/backquote-aux.lsp index 2c858dc1..7ff2953e 100644 --- a/ansi-tests/backquote-aux.lsp +++ b/ansi-tests/backquote-aux.lsp @@ -12,30 +12,30 @@ (defun make-random-backquoted-form (size) (my-with-standard-io-syntax (let ((*print-readably* nil) - (*package* (find-package "CL-TEST"))) + (*package* (find-package "CL-TEST"))) (read-from-string (concatenate 'string - "`" - (make-random-backquoted-sequence-string size)))))) + "`" + (make-random-backquoted-sequence-string size)))))) (defun make-random-backquoted-sequence-string (size) (case size ((0 1) (make-random-backquoted-string size)) (t (let* ((nelements (1+ (min (random (1- size)) (random (1- size)) 9))) - (sizes (random-partition (1- size) nelements)) - (substrings (mapcar #'make-random-backquoted-string sizes))) + (sizes (random-partition (1- size) nelements)) + (substrings (mapcar #'make-random-backquoted-string sizes))) (apply #'concatenate - 'string - "(" - (car substrings) - (if nil ; (and (> nelements 1) (coin)) - (nconc - (loop for s in (cddr substrings) collect " " collect s) - (list " . " (cadr substrings) ")")) - (nconc - (loop for s in (cdr substrings) collect " " collect s) - (list ")")))))))) + 'string + "(" + (car substrings) + (if nil ; (and (> nelements 1) (coin)) + (nconc + (loop for s in (cddr substrings) collect " " collect s) + (list " . " (cadr substrings) ")")) + (nconc + (loop for s in (cdr substrings) collect " " collect s) + (list ")")))))))) ;;; Create a string that is a backquoted form (defun make-random-backquoted-string (size) diff --git a/ansi-tests/beyond-ansi/ba-aux.lsp b/ansi-tests/beyond-ansi/ba-aux.lsp index cce99661..b271242e 100644 --- a/ansi-tests/beyond-ansi/ba-aux.lsp +++ b/ansi-tests/beyond-ansi/ba-aux.lsp @@ -8,18 +8,18 @@ (defun function-name-p (x) (or (symbolp x) (and (consp x) - (eql (car x) 'setf) - (consp (cdr x)) - (symbolp (cadr x)) - (null (cddr x))))) + (eql (car x) 'setf) + (consp (cdr x)) + (symbolp (cadr x)) + (null (cddr x))))) (defun symbol-or-function-p (x) (or (symbolp x) (and (consp x) - (eql (car x) 'function) - (consp (cdr x)) - (null (cddr x)) - (function-name-p (cadr x))))) + (eql (car x) 'function) + (consp (cdr x)) + (null (cddr x)) + (function-name-p (cadr x))))) (defun symbol-or-list-p (x) (or (symbolp x) (listp x))) @@ -36,12 +36,12 @@ (assert (fboundp pred)) (setf pred (symbol-function pred))) (loop for x in vals - for inner-form = (if (functionp formf) - (funcall formf x) - (subst `',x var formf)) - for form = `(signals-error ,inner-form error) - unless (or (funcall pred x) (eval form)) - collect x)) + for inner-form = (if (functionp formf) + (funcall formf x) + (subst `',x var formf)) + for form = `(signals-error ,inner-form error) + unless (or (funcall pred x) (eval form)) + collect x)) (defmacro def-all-error-test (name pred form &rest other-args) `(deftest ,name diff --git a/ansi-tests/beyond-ansi/ba-test-package.lsp b/ansi-tests/beyond-ansi/ba-test-package.lsp index ae94eac1..be424326 100644 --- a/ansi-tests/beyond-ansi/ba-test-package.lsp +++ b/ansi-tests/beyond-ansi/ba-test-package.lsp @@ -8,7 +8,7 @@ (let* ((name :ba-test) (pkg (find-package name))) (unless pkg (setq pkg (make-package name :use '(:cl :regression-test - :cl-test)))) + :cl-test)))) (let ((*package* pkg)) (shadow '(#:handler-case #:handler-bind)) (import '(common-lisp-user::compile-and-load) pkg) diff --git a/ansi-tests/beyond-ansi/errors-data-and-control-flow-3.lsp b/ansi-tests/beyond-ansi/errors-data-and-control-flow-3.lsp index 04f118ef..7f6c788d 100644 --- a/ansi-tests/beyond-ansi/errors-data-and-control-flow-3.lsp +++ b/ansi-tests/beyond-ansi/errors-data-and-control-flow-3.lsp @@ -70,7 +70,7 @@ (def-error-test multiple-value-bind.1 (multiple-value-bind)) (def-error-test multiple-value-bind.2 (multiple-value-bind . - #.(1+ most-positive-fixnum))) + #.(1+ most-positive-fixnum))) (def-error-test multiple-value-bind.3 (multiple-value-bind (x))) (def-error-test multiple-value-bind.4 (multiple-value-bind (x . y) 1 x)) (def-error-test multiple-value-bind.5 (multiple-value-bind (x) . :foo)) diff --git a/ansi-tests/beyond-ansi/errors-eval-compile.lsp b/ansi-tests/beyond-ansi/errors-eval-compile.lsp index c1b042eb..a4b4ee1e 100644 --- a/ansi-tests/beyond-ansi/errors-eval-compile.lsp +++ b/ansi-tests/beyond-ansi/errors-eval-compile.lsp @@ -15,9 +15,9 @@ (cl:handler-case (let ((vals (multiple-value-list (apply #'compile args)))) (if (and (= (length vals) 3) - (cadr vals) - (caadr vals)) - t + (cadr vals) + (caadr vals)) + t (apply #'values nil vals))) (error () t))) @@ -25,9 +25,9 @@ (deftest compile.1 (loop for x in *mini-universe* - unless (or (function-name-p x) - (compile-fails? x)) - collect x) + unless (or (function-name-p x) + (compile-fails? x)) + collect x) nil) (deftest compile.2 @@ -38,9 +38,9 @@ (let ((sym (gensym))) (eval `(defun ,sym () nil)) (loop for x in *mini-universe* - unless (or (functionp x) (and (consp x) (eql (car x) 'lambda)) - (compile-fails? sym x)) - collect x)) + unless (or (functionp x) (and (consp x) (eql (car x) 'lambda)) + (compile-fails? sym x)) + collect x)) nil) (deftest compile.4 @@ -156,85 +156,85 @@ #-sbcl (deftest type.1 (loop for x in *mini-universe* - for tp = (type-of x) - for lambda-form = `(lambda (y) (declare (optimize safety) - (type (not ,tp) y)) y) - for fn = (progn (print lambda-form) - (eval `(function ,lambda-form))) - unless (eval `(signals-error (funcall ',fn ',x) error)) - collect x) + for tp = (type-of x) + for lambda-form = `(lambda (y) (declare (optimize safety) + (type (not ,tp) y)) y) + for fn = (progn (print lambda-form) + (eval `(function ,lambda-form))) + unless (eval `(signals-error (funcall ',fn ',x) error)) + collect x) nil) (deftest type.2 (let* ((utypes (coerce (mapcar #'type-of *universe*) 'vector)) - (n (length utypes))) + (n (length utypes))) (flet ((%rtype () (elt utypes (random n)))) (loop for x in *mini-universe* - for tp = (loop for tp = (%rtype) - while (typep x tp) - finally (return tp)) - for lambda-form = `(lambda (y) (declare (optimize safety) - (type ,tp y)) y) - for fn = (progn ;; (print lambda-form) - (eval `(function ,lambda-form))) - unless (eval `(signals-error (funcall ',fn ',x) error)) - collect x))) + for tp = (loop for tp = (%rtype) + while (typep x tp) + finally (return tp)) + for lambda-form = `(lambda (y) (declare (optimize safety) + (type ,tp y)) y) + for fn = (progn ;; (print lambda-form) + (eval `(function ,lambda-form))) + unless (eval `(signals-error (funcall ',fn ',x) error)) + collect x))) nil) (deftest type.2c (let* ((utypes (coerce (mapcar #'type-of *universe*) 'vector)) - (n (length utypes))) + (n (length utypes))) (flet ((%rtype () (elt utypes (random n)))) (loop for x in *mini-universe* - for tp = (loop for tp = (%rtype) - while (typep x tp) - finally (return tp)) - for lambda-form = `(lambda (y) (declare (optimize safety) - (type ,tp y)) y) - for fn = (progn ;; (print lambda-form) - (compile nil lambda-form)) - unless (eval `(signals-error (funcall ',fn ',x) error)) - collect x))) + for tp = (loop for tp = (%rtype) + while (typep x tp) + finally (return tp)) + for lambda-form = `(lambda (y) (declare (optimize safety) + (type ,tp y)) y) + for fn = (progn ;; (print lambda-form) + (compile nil lambda-form)) + unless (eval `(signals-error (funcall ',fn ',x) error)) + collect x))) nil) (deftest type.3 (loop for x in *mini-universe* - for tp = (type-of x) - for lambda-form = `(lambda (z) (declare (optimize safety)) - (let ((y z)) - (declare (type ,tp y)) - y)) - for fn = (progn ;; (print lambda-form) - (eval `(function ,lambda-form))) - unless (or (typep nil tp) - (eval `(signals-error (funcall ',fn nil) error))) - collect x) + for tp = (type-of x) + for lambda-form = `(lambda (z) (declare (optimize safety)) + (let ((y z)) + (declare (type ,tp y)) + y)) + for fn = (progn ;; (print lambda-form) + (eval `(function ,lambda-form))) + unless (or (typep nil tp) + (eval `(signals-error (funcall ',fn nil) error))) + collect x) nil) (deftest type.3c (loop for x in *mini-universe* - for tp = (type-of x) - for lambda-form = `(lambda (z) (declare (optimize safety)) - (let ((y z)) - (declare (type ,tp y)) - y)) - for fn = (progn ;; (print lambda-form) - (compile nil lambda-form)) - unless (or (typep nil tp) - (eval `(signals-error (funcall ',fn nil) error))) - collect x) + for tp = (type-of x) + for lambda-form = `(lambda (z) (declare (optimize safety)) + (let ((y z)) + (declare (type ,tp y)) + y)) + for fn = (progn ;; (print lambda-form) + (compile nil lambda-form)) + unless (or (typep nil tp) + (eval `(signals-error (funcall ',fn nil) error))) + collect x) nil) (deftest type.4 (loop for x in *mini-universe* - for tp = (type-of x) - for lambda-form = `(lambda (z) (declare (optimize safety)) - (the ,tp z)) - for fn = (progn ;; (print lambda-form) - (eval `(function ,lambda-form))) - unless (or (typep nil tp) - (eval `(signals-error (funcall ',fn nil) error))) - collect x) + for tp = (type-of x) + for lambda-form = `(lambda (z) (declare (optimize safety)) + (the ,tp z)) + for fn = (progn ;; (print lambda-form) + (eval `(function ,lambda-form))) + unless (or (typep nil tp) + (eval `(signals-error (funcall ',fn nil) error))) + collect x) nil) (deftest type.5 @@ -251,12 +251,12 @@ (deftest type.8 (signals-error (let ((x (make-array 3 :initial-element 0 - :element-type '(integer 0 2)))) - (declare (optimize safety) - (type (array (integer 0 2) (3)) x)) - (setf (aref x 0) 3) - (aref x 0)) - error) + :element-type '(integer 0 2)))) + (declare (optimize safety) + (type (array (integer 0 2) (3)) x)) + (setf (aref x 0) 3) + (aref x 0)) + error) t) ;; Move the type tests off to another file, eventually. @@ -328,4 +328,4 @@ (def-error-test the.5 (setf (the t) nil)) (def-error-test the.6 (let (x y) (setf (the t x y) nil))) -;;; +;;; diff --git a/ansi-tests/beyond-ansi/load-ba.lsp b/ansi-tests/beyond-ansi/load-ba.lsp index 4109acc9..a02fb73f 100644 --- a/ansi-tests/beyond-ansi/load-ba.lsp +++ b/ansi-tests/beyond-ansi/load-ba.lsp @@ -5,7 +5,7 @@ (let ((*default-pathname-defaults* (pathname *load-pathname*))) (let ((*default-pathname-defaults* - (merge-pathnames (make-pathname :directory '(:relative :up))))) + (merge-pathnames (make-pathname :directory '(:relative :up))))) (load "gclload1.lsp")) (load "ba-test-package.lsp") (eval '(compile-and-load "ba-aux.lsp")) diff --git a/ansi-tests/bit-and.lsp b/ansi-tests/bit-and.lsp index 415b347d..d4c5fb62 100644 --- a/ansi-tests/bit-and.lsp +++ b/ansi-tests/bit-and.lsp @@ -9,7 +9,7 @@ (deftest bit-and.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-and s1 s2) s1 s2)) #0a0 #0a0 @@ -17,7 +17,7 @@ (deftest bit-and.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-and s1 s2) s1 s2)) #0a0 #0a1 @@ -25,7 +25,7 @@ (deftest bit-and.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-and s1 s2) s1 s2)) #0a0 #0a0 @@ -33,7 +33,7 @@ (deftest bit-and.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-and s1 s2) s1 s2)) #0a1 #0a1 @@ -41,9 +41,9 @@ (deftest bit-and.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-and s1 s2 s3))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-and s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 @@ -53,9 +53,9 @@ (deftest bit-and.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-and s1 s2 s3))) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-and s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 @@ -65,8 +65,8 @@ (deftest bit-and.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-and s1 s2 t))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-and s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 @@ -78,28 +78,28 @@ (deftest bit-and.8 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-and a1 a2)) a1 a2)) #*0001 #*0011 #*0101) (deftest bit-and.9 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-and a1 a2 t)))) + (a2 (copy-seq #*0101)) + (result (check-values (bit-and a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0001 #*0001 #*0101 t) (deftest bit-and.10 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-and a1 a2 a3)))) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-and a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0001 #*0011 #*0101 #*0001 t) (deftest bit-and.11 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-and a1 a2 nil)) a1 a2)) #*0001 #*0011 #*0101) @@ -107,10 +107,10 @@ (deftest bit-and.12 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-and a1 a2))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-and a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -118,10 +118,10 @@ (deftest bit-and.13 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-and a1 a2 t))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-and a1 a2 t))) (values a1 a2 result)) #2a((0 0)(0 1)) #2a((0 0)(1 1)) @@ -129,10 +129,10 @@ (deftest bit-and.14 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-and a1 a2 nil))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-and a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -140,12 +140,12 @@ (deftest bit-and.15 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-and a1 a2 a3))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-and a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -156,12 +156,12 @@ (deftest bit-and.16 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-and a1 a2))) + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-and a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -171,14 +171,14 @@ (deftest bit-and.17 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-and a1 a2))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-and a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) @@ -187,14 +187,14 @@ (deftest bit-and.18 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-and a1 a2 t))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-and a1 a2 t))) (values a0 a1 a2 result)) #*00010011 #2a((0 0)(0 1)) @@ -203,17 +203,17 @@ (deftest bit-and.19 (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-and a1 a2 a3))) + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-and a1 a2 a3))) (values a0 a1 a2 result)) #*010100110001 #2a((0 1)(0 1)) @@ -230,16 +230,16 @@ (deftest bit-and.22 (macrolet ((%m (z) z)) (bit-and #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) + (expand-in-current-env (%m nil)))) #*00100010) (deftest bit-and.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) (values (bit-and (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) + (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) @@ -263,6 +263,6 @@ (deftest bit-and.error.3 (signals-error (bit-and #*000 #*0100 nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/bit-andc1.lsp b/ansi-tests/bit-andc1.lsp index 47d0f2e1..3997a88b 100644 --- a/ansi-tests/bit-andc1.lsp +++ b/ansi-tests/bit-andc1.lsp @@ -9,7 +9,7 @@ (deftest bit-andc1.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-andc1 s1 s2) s1 s2)) #0a0 #0a0 @@ -17,7 +17,7 @@ (deftest bit-andc1.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-andc1 s1 s2) s1 s2)) #0a0 #0a1 @@ -25,7 +25,7 @@ (deftest bit-andc1.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-andc1 s1 s2) s1 s2)) #0a1 #0a0 @@ -33,7 +33,7 @@ (deftest bit-andc1.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-andc1 s1 s2) s1 s2)) #0a0 #0a1 @@ -41,9 +41,9 @@ (deftest bit-andc1.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-andc1 s1 s2 s3))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-andc1 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 @@ -53,9 +53,9 @@ (deftest bit-andc1.6 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-andc1 s1 s2 s3))) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-andc1 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a1 @@ -65,8 +65,8 @@ (deftest bit-andc1.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-andc1 s1 s2 t))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-andc1 s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 @@ -78,28 +78,28 @@ (deftest bit-andc1.8 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-andc1 a1 a2)) a1 a2)) #*0100 #*0011 #*0101) (deftest bit-andc1.9 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-andc1 a1 a2 t)))) + (a2 (copy-seq #*0101)) + (result (check-values (bit-andc1 a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0100 #*0100 #*0101 t) (deftest bit-andc1.10 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*0000)) - (result (check-values (bit-andc1 a1 a2 a3)))) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*0000)) + (result (check-values (bit-andc1 a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0100 #*0011 #*0101 #*0100 t) (deftest bit-andc1.11 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-andc1 a1 a2 nil)) a1 a2)) #*0100 #*0011 #*0101) @@ -107,10 +107,10 @@ (deftest bit-andc1.12 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-andc1 a1 a2))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-andc1 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -118,10 +118,10 @@ (deftest bit-andc1.13 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-andc1 a1 a2 t))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-andc1 a1 a2 t))) (values a1 a2 result)) #2a((0 0)(1 0)) #2a((0 0)(1 1)) @@ -129,10 +129,10 @@ (deftest bit-andc1.14 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-andc1 a1 a2 nil))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-andc1 a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -140,12 +140,12 @@ (deftest bit-andc1.15 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-andc1 a1 a2 a3))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-andc1 a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -156,12 +156,12 @@ (deftest bit-andc1.16 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-andc1 a1 a2))) + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-andc1 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -171,14 +171,14 @@ (deftest bit-andc1.17 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-andc1 a1 a2))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-andc1 a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) @@ -187,14 +187,14 @@ (deftest bit-andc1.18 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-andc1 a1 a2 t))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-andc1 a1 a2 t))) (values a0 a1 a2 result)) #*00100011 #2a((0 0)(1 0)) @@ -203,17 +203,17 @@ (deftest bit-andc1.19 (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-andc1 a1 a2 a3))) + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-andc1 a1 a2 a3))) (values a0 a1 a2 result)) #*010100110010 #2a((0 1)(0 1)) @@ -230,16 +230,16 @@ (deftest bit-andc1.22 (macrolet ((%m (z) z)) (bit-andc1 #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) + (expand-in-current-env (%m nil)))) #*01001000) (deftest bit-andc1.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) (values (bit-andc1 (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) + (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) @@ -263,5 +263,5 @@ (deftest bit-andc1.error.3 (signals-error (bit-andc1 #*000 #*0100 nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/bit-andc2.lsp b/ansi-tests/bit-andc2.lsp index 43ef395b..9a20b7ec 100644 --- a/ansi-tests/bit-andc2.lsp +++ b/ansi-tests/bit-andc2.lsp @@ -9,7 +9,7 @@ (deftest bit-andc2.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-andc2 s1 s2) s1 s2)) #0a0 #0a0 @@ -17,7 +17,7 @@ (deftest bit-andc2.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-andc2 s1 s2) s1 s2)) #0a1 #0a1 @@ -25,7 +25,7 @@ (deftest bit-andc2.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-andc2 s1 s2) s1 s2)) #0a0 #0a0 @@ -33,7 +33,7 @@ (deftest bit-andc2.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-andc2 s1 s2) s1 s2)) #0a0 #0a1 @@ -41,9 +41,9 @@ (deftest bit-andc2.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-andc2 s1 s2 s3))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-andc2 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 @@ -53,9 +53,9 @@ (deftest bit-andc2.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-andc2 s1 s2 s3))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-andc2 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a0 @@ -65,8 +65,8 @@ (deftest bit-andc2.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-andc2 s1 s2 t))) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-andc2 s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a1 @@ -78,28 +78,28 @@ (deftest bit-andc2.8 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-andc2 a1 a2)) a1 a2)) #*0010 #*0011 #*0101) (deftest bit-andc2.9 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-andc2 a1 a2 t)))) + (a2 (copy-seq #*0101)) + (result (check-values (bit-andc2 a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0010 #*0010 #*0101 t) (deftest bit-andc2.10 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-andc2 a1 a2 a3)))) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-andc2 a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0010 #*0011 #*0101 #*0010 t) (deftest bit-andc2.11 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-andc2 a1 a2 nil)) a1 a2)) #*0010 #*0011 #*0101) @@ -107,10 +107,10 @@ (deftest bit-andc2.12 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-andc2 a1 a2))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-andc2 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -118,10 +118,10 @@ (deftest bit-andc2.13 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-andc2 a1 a2 t))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-andc2 a1 a2 t))) (values a1 a2 result)) #2a((0 1)(0 0)) #2a((0 0)(1 1)) @@ -129,10 +129,10 @@ (deftest bit-andc2.14 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-andc2 a1 a2 nil))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-andc2 a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -140,12 +140,12 @@ (deftest bit-andc2.15 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-andc2 a1 a2 a3))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-andc2 a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -156,12 +156,12 @@ (deftest bit-andc2.16 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-andc2 a1 a2))) + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-andc2 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -171,14 +171,14 @@ (deftest bit-andc2.17 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-andc2 a1 a2))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-andc2 a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) @@ -187,14 +187,14 @@ (deftest bit-andc2.18 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-andc2 a1 a2 t))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-andc2 a1 a2 t))) (values a0 a1 a2 result)) #*01000011 #2a((0 1)(0 0)) @@ -203,17 +203,17 @@ (deftest bit-andc2.19 (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-andc2 a1 a2 a3))) + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-andc2 a1 a2 a3))) (values a0 a1 a2 result)) #*010100110100 #2a((0 1)(0 1)) @@ -230,16 +230,16 @@ (deftest bit-andc2.22 (macrolet ((%m (z) z)) (bit-andc2 #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) + (expand-in-current-env (%m nil)))) #*10000001) (deftest bit-andc2.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) (values (bit-andc2 (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) + (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) @@ -263,6 +263,6 @@ (deftest bit-andc2.error.3 (signals-error (bit-andc2 #*000 #*0100 nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/bit-aux.lsp b/ansi-tests/bit-aux.lsp index d41a1489..da0193bb 100644 --- a/ansi-tests/bit-aux.lsp +++ b/ansi-tests/bit-aux.lsp @@ -9,14 +9,14 @@ (assert (typep maxlen '(integer 1))) (assert (typep reps 'unsigned-byte)) (loop for len = (random maxlen) - for twos = (make-list len :initial-element 2) - for v1 = (map 'bit-vector #'random twos) - for v2 = (map 'bit-vector #'random twos) - for result = (funcall bit-fn v1 v2) - repeat reps - unless (and (= (length result) len) - (every #'(lambda (result-bit v1-bit v2-bit) - (= result-bit (logand 1 (funcall log-fn v1-bit v2-bit)))) - result v1 v2)) - collect (list len v1 v2 result))) + for twos = (make-list len :initial-element 2) + for v1 = (map 'bit-vector #'random twos) + for v2 = (map 'bit-vector #'random twos) + for result = (funcall bit-fn v1 v2) + repeat reps + unless (and (= (length result) len) + (every #'(lambda (result-bit v1-bit v2-bit) + (= result-bit (logand 1 (funcall log-fn v1-bit v2-bit)))) + result v1 v2)) + collect (list len v1 v2 result))) diff --git a/ansi-tests/bit-eqv.lsp b/ansi-tests/bit-eqv.lsp index 357a48a4..5fdfb329 100644 --- a/ansi-tests/bit-eqv.lsp +++ b/ansi-tests/bit-eqv.lsp @@ -10,7 +10,7 @@ (deftest bit-eqv.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-eqv s1 s2) s1 s2)) #0a1 #0a0 @@ -18,7 +18,7 @@ (deftest bit-eqv.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-eqv s1 s2) s1 s2)) #0a0 #0a1 @@ -26,7 +26,7 @@ (deftest bit-eqv.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-eqv s1 s2) s1 s2)) #0a0 #0a0 @@ -34,7 +34,7 @@ (deftest bit-eqv.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-eqv s1 s2) s1 s2)) #0a1 #0a1 @@ -42,9 +42,9 @@ (deftest bit-eqv.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-eqv s1 s2 s3))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-eqv s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 @@ -54,9 +54,9 @@ (deftest bit-eqv.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-eqv s1 s2 s3))) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-eqv s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 @@ -66,8 +66,8 @@ (deftest bit-eqv.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-eqv s1 s2 t))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-eqv s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 @@ -79,28 +79,28 @@ (deftest bit-eqv.8 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-eqv a1 a2)) a1 a2)) #*1001 #*0011 #*0101) (deftest bit-eqv.9 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-eqv a1 a2 t)))) + (a2 (copy-seq #*0101)) + (result (check-values (bit-eqv a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1001 #*1001 #*0101 t) (deftest bit-eqv.10 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*0000)) - (result (check-values (bit-eqv a1 a2 a3)))) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*0000)) + (result (check-values (bit-eqv a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1001 #*0011 #*0101 #*1001 t) (deftest bit-eqv.11 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-eqv a1 a2 nil)) a1 a2)) #*1001 #*0011 #*0101) @@ -108,10 +108,10 @@ (deftest bit-eqv.12 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-eqv a1 a2))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-eqv a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -119,10 +119,10 @@ (deftest bit-eqv.13 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-eqv a1 a2 t))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-eqv a1 a2 t))) (values a1 a2 result)) #2a((1 0)(0 1)) #2a((0 0)(1 1)) @@ -130,10 +130,10 @@ (deftest bit-eqv.14 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-eqv a1 a2 nil))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-eqv a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -141,12 +141,12 @@ (deftest bit-eqv.15 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-eqv a1 a2 a3))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-eqv a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -157,12 +157,12 @@ (deftest bit-eqv.16 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-eqv a1 a2))) + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-eqv a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -172,14 +172,14 @@ (deftest bit-eqv.17 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-eqv a1 a2))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-eqv a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) @@ -188,14 +188,14 @@ (deftest bit-eqv.18 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-eqv a1 a2 t))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-eqv a1 a2 t))) (values a0 a1 a2 result)) #*10010011 #2a((1 0)(0 1)) @@ -204,17 +204,17 @@ (deftest bit-eqv.19 (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-eqv a1 a2 a3))) + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-eqv a1 a2 a3))) (values a0 a1 a2 result)) #*010100111001 #2a((0 1)(0 1)) @@ -231,16 +231,16 @@ (deftest bit-eqv.22 (macrolet ((%m (z) z)) (bit-eqv #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) + (expand-in-current-env (%m nil)))) #*00110110) (deftest bit-eqv.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) (values (bit-eqv (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) + (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) @@ -264,5 +264,5 @@ (deftest bit-eqv.error.3 (signals-error (bit-eqv #*000 #*0100 nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/bit-ior.lsp b/ansi-tests/bit-ior.lsp index 47c349b1..bad18647 100644 --- a/ansi-tests/bit-ior.lsp +++ b/ansi-tests/bit-ior.lsp @@ -9,7 +9,7 @@ (deftest bit-ior.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-ior s1 s2) s1 s2)) #0a0 #0a0 @@ -17,7 +17,7 @@ (deftest bit-ior.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-ior s1 s2) s1 s2)) #0a1 #0a1 @@ -25,7 +25,7 @@ (deftest bit-ior.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-ior s1 s2) s1 s2)) #0a1 #0a0 @@ -33,7 +33,7 @@ (deftest bit-ior.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-ior s1 s2) s1 s2)) #0a1 #0a1 @@ -41,9 +41,9 @@ (deftest bit-ior.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-ior s1 s2 s3))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-ior s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 @@ -53,9 +53,9 @@ (deftest bit-ior.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-ior s1 s2 s3))) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-ior s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 @@ -65,8 +65,8 @@ (deftest bit-ior.7 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-ior s1 s2 t))) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-ior s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a1 #0a1 @@ -78,28 +78,28 @@ (deftest bit-ior.8 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-ior a1 a2)) a1 a2)) #*0111 #*0011 #*0101) (deftest bit-ior.9 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-ior a1 a2 t)))) + (a2 (copy-seq #*0101)) + (result (check-values (bit-ior a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0111 #*0111 #*0101 t) (deftest bit-ior.10 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-ior a1 a2 a3)))) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-ior a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0111 #*0011 #*0101 #*0111 t) (deftest bit-ior.11 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-ior a1 a2 nil)) a1 a2)) #*0111 #*0011 #*0101) @@ -107,10 +107,10 @@ (deftest bit-ior.12 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-ior a1 a2))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-ior a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -118,10 +118,10 @@ (deftest bit-ior.13 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-ior a1 a2 t))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-ior a1 a2 t))) (values a1 a2 result)) #2a((0 1)(1 1)) #2a((0 0)(1 1)) @@ -129,10 +129,10 @@ (deftest bit-ior.14 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-ior a1 a2 nil))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-ior a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -140,12 +140,12 @@ (deftest bit-ior.15 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-ior a1 a2 a3))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-ior a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -156,12 +156,12 @@ (deftest bit-ior.16 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-ior a1 a2))) + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-ior a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -171,14 +171,14 @@ (deftest bit-ior.17 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-ior a1 a2))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-ior a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) @@ -187,14 +187,14 @@ (deftest bit-ior.18 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-ior a1 a2 t))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-ior a1 a2 t))) (values a0 a1 a2 result)) #*01110011 #2a((0 1)(1 1)) @@ -203,17 +203,17 @@ (deftest bit-ior.19 (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-ior a1 a2 a3))) + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-ior a1 a2 a3))) (values a0 a1 a2 result)) #*010100110111 #2a((0 1)(0 1)) @@ -230,16 +230,16 @@ (deftest bit-ior.22 (macrolet ((%m (z) z)) (bit-ior #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) + (expand-in-current-env (%m nil)))) #*11101011) (deftest bit-ior.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) (values (bit-ior (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) + (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) @@ -263,5 +263,5 @@ (deftest bit-ior.error.3 (signals-error (bit-ior #*000 #*0100 nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/bit-nand.lsp b/ansi-tests/bit-nand.lsp index 41c0722b..2cc97329 100644 --- a/ansi-tests/bit-nand.lsp +++ b/ansi-tests/bit-nand.lsp @@ -9,7 +9,7 @@ (deftest bit-nand.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-nand s1 s2) s1 s2)) #0a1 #0a0 @@ -17,7 +17,7 @@ (deftest bit-nand.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-nand s1 s2) s1 s2)) #0a1 #0a1 @@ -25,7 +25,7 @@ (deftest bit-nand.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-nand s1 s2) s1 s2)) #0a1 #0a0 @@ -33,7 +33,7 @@ (deftest bit-nand.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-nand s1 s2) s1 s2)) #0a0 #0a1 @@ -41,9 +41,9 @@ (deftest bit-nand.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-nand s1 s2 s3))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-nand s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 @@ -53,9 +53,9 @@ (deftest bit-nand.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-nand s1 s2 s3))) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-nand s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 @@ -65,8 +65,8 @@ (deftest bit-nand.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-nand s1 s2 t))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-nand s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a1 #0a0 @@ -78,28 +78,28 @@ (deftest bit-nand.8 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-nand a1 a2)) a1 a2)) #*1110 #*0011 #*0101) (deftest bit-nand.9 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-nand a1 a2 t)))) + (a2 (copy-seq #*0101)) + (result (check-values (bit-nand a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1110 #*1110 #*0101 t) (deftest bit-nand.10 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-nand a1 a2 a3)))) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-nand a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1110 #*0011 #*0101 #*1110 t) (deftest bit-nand.11 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-nand a1 a2 nil)) a1 a2)) #*1110 #*0011 #*0101) @@ -107,10 +107,10 @@ (deftest bit-nand.12 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-nand a1 a2))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-nand a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -118,10 +118,10 @@ (deftest bit-nand.13 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-nand a1 a2 t))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-nand a1 a2 t))) (values a1 a2 result)) #2a((1 1)(1 0)) #2a((0 0)(1 1)) @@ -129,10 +129,10 @@ (deftest bit-nand.14 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-nand a1 a2 nil))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-nand a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -140,12 +140,12 @@ (deftest bit-nand.15 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-nand a1 a2 a3))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-nand a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -156,12 +156,12 @@ (deftest bit-nand.16 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-nand a1 a2))) + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-nand a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -171,14 +171,14 @@ (deftest bit-nand.17 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-nand a1 a2))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-nand a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) @@ -187,14 +187,14 @@ (deftest bit-nand.18 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-nand a1 a2 t))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-nand a1 a2 t))) (values a0 a1 a2 result)) #*11100011 #2a((1 1)(1 0)) @@ -203,17 +203,17 @@ (deftest bit-nand.19 (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-nand a1 a2 a3))) + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-nand a1 a2 a3))) (values a0 a1 a2 result)) #*010100111110 #2a((0 1)(0 1)) @@ -230,16 +230,16 @@ (deftest bit-nand.22 (macrolet ((%m (z) z)) (bit-nand #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) + (expand-in-current-env (%m nil)))) #*11011101) (deftest bit-nand.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) (values (bit-nand (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) + (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) @@ -263,5 +263,5 @@ (deftest bit-nand.error.3 (signals-error (bit-nand #*000 #*0100 nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/bit-nor.lsp b/ansi-tests/bit-nor.lsp index 381f9446..cc9a0d76 100644 --- a/ansi-tests/bit-nor.lsp +++ b/ansi-tests/bit-nor.lsp @@ -9,7 +9,7 @@ (deftest bit-nor.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-nor s1 s2) s1 s2)) #0a1 #0a0 @@ -17,7 +17,7 @@ (deftest bit-nor.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-nor s1 s2) s1 s2)) #0a0 #0a1 @@ -25,7 +25,7 @@ (deftest bit-nor.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-nor s1 s2) s1 s2)) #0a0 #0a0 @@ -33,7 +33,7 @@ (deftest bit-nor.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-nor s1 s2) s1 s2)) #0a0 #0a1 @@ -41,9 +41,9 @@ (deftest bit-nor.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-nor s1 s2 s3))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-nor s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 @@ -53,9 +53,9 @@ (deftest bit-nor.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-nor s1 s2 s3))) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-nor s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 @@ -65,8 +65,8 @@ (deftest bit-nor.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-nor s1 s2 t))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-nor s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 @@ -78,28 +78,28 @@ (deftest bit-nor.8 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-nor a1 a2)) a1 a2)) #*1000 #*0011 #*0101) (deftest bit-nor.9 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-nor a1 a2 t)))) + (a2 (copy-seq #*0101)) + (result (check-values (bit-nor a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1000 #*1000 #*0101 t) (deftest bit-nor.10 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-nor a1 a2 a3)))) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-nor a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1000 #*0011 #*0101 #*1000 t) (deftest bit-nor.11 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-nor a1 a2 nil)) a1 a2)) #*1000 #*0011 #*0101) @@ -107,10 +107,10 @@ (deftest bit-nor.12 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-nor a1 a2))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-nor a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -118,10 +118,10 @@ (deftest bit-nor.13 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-nor a1 a2 t))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-nor a1 a2 t))) (values a1 a2 result)) #2a((1 0)(0 0)) #2a((0 0)(1 1)) @@ -129,10 +129,10 @@ (deftest bit-nor.14 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-nor a1 a2 nil))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-nor a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -140,12 +140,12 @@ (deftest bit-nor.15 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-nor a1 a2 a3))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-nor a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -156,12 +156,12 @@ (deftest bit-nor.16 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-nor a1 a2))) + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-nor a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -171,14 +171,14 @@ (deftest bit-nor.17 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-nor a1 a2))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-nor a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) @@ -187,14 +187,14 @@ (deftest bit-nor.18 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-nor a1 a2 t))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-nor a1 a2 t))) (values a0 a1 a2 result)) #*10000011 #2a((1 0)(0 0)) @@ -203,17 +203,17 @@ (deftest bit-nor.19 (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-nor a1 a2 a3))) + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-nor a1 a2 a3))) (values a0 a1 a2 result)) #*010100111000 #2a((0 1)(0 1)) @@ -230,16 +230,16 @@ (deftest bit-nor.22 (macrolet ((%m (z) z)) (bit-nor #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) + (expand-in-current-env (%m nil)))) #*00010100) (deftest bit-nor.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) (values (bit-nor (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) + (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) @@ -263,5 +263,5 @@ (deftest bit-nor.error.3 (signals-error (bit-nor #*000 #*0100 nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/bit-not.lsp b/ansi-tests/bit-not.lsp index 372b2cfe..5fb9aba8 100644 --- a/ansi-tests/bit-not.lsp +++ b/ansi-tests/bit-not.lsp @@ -9,7 +9,7 @@ (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) (values (bit-not a1) a1)) #0a1 #0a0) - + (deftest bit-not.2 (let ((a1 (make-array nil :element-type 'bit :initial-element 1))) (values (bit-not a1) a1)) @@ -19,7 +19,7 @@ (let ((a1 (make-array nil :element-type 'bit :initial-element 0))) (values (bit-not a1 t) a1)) #0a1 #0a1) - + (deftest bit-not.4 (let ((a1 (make-array nil :element-type 'bit :initial-element 1))) (values (bit-not a1 t) a1)) @@ -27,8 +27,8 @@ (deftest bit-not.5 (let* ((a1 (make-array nil :element-type 'bit :initial-element 1)) - (a2 (make-array nil :element-type 'bit :initial-element 1)) - (result (bit-not a1 a2))) + (a2 (make-array nil :element-type 'bit :initial-element 1)) + (result (bit-not a1 a2))) (values a1 a2 (eqt a2 result))) #0a1 #0a0 t) @@ -53,7 +53,7 @@ (deftest bit-not.9 (let ((a1 (copy-seq #*0011010110)) - (a2 (copy-seq #*0000000000))) + (a2 (copy-seq #*0000000000))) (values (bit-not a1 a2) a1 a2)) #*1100101001 #*0011010110 @@ -63,30 +63,30 @@ (deftest bit-not.10 (let ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(1 0))))) + :initial-contents '((0 1)(1 0))))) (values (bit-not a1) a1)) #2a((1 0)(0 1)) #2a((0 1)(1 0))) (deftest bit-not.11 (let ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(1 0))))) + :initial-contents '((0 1)(1 0))))) (values (bit-not a1 nil) a1)) #2a((1 0)(0 1)) #2a((0 1)(1 0))) (deftest bit-not.12 (let ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(1 0))))) + :initial-contents '((0 1)(1 0))))) (values (bit-not a1 t) a1)) #2a((1 0)(0 1)) #2a((1 0)(0 1))) (deftest bit-not.13 (let ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(1 0)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-element 0))) + :initial-contents '((0 1)(1 0)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-element 0))) (values (bit-not a1 a2) a1 a2)) #2a((1 0)(0 1)) #2a((0 1)(1 0)) @@ -96,8 +96,8 @@ (deftest bit-not.14 (let ((a1 (make-array '(2 2) :element-type 'bit - :adjustable t - :initial-contents '((0 1)(1 0))))) + :adjustable t + :initial-contents '((0 1)(1 0))))) (values (bit-not a1) a1)) #2a((1 0)(0 1)) #2a((0 1)(1 0))) @@ -106,13 +106,13 @@ (deftest bit-not.15 (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 0 0 1 1 0 0 0 0 0 0 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 2)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 6))) + :initial-contents '(0 0 0 1 1 0 0 0 0 0 0 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 2)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 6))) (values (bit-not a1 a2) a0 a1 a2)) #2a((1 0)(0 1)) #*000110100100 @@ -137,7 +137,7 @@ (deftest bit-not.order.1 (let ((a (copy-seq #*001101)) - (i 0) x) + (i 0) x) (values (bit-not (progn (setf x (incf i)) a)) i x)) diff --git a/ansi-tests/bit-orc1.lsp b/ansi-tests/bit-orc1.lsp index eb0b3e1a..fddac473 100644 --- a/ansi-tests/bit-orc1.lsp +++ b/ansi-tests/bit-orc1.lsp @@ -9,7 +9,7 @@ (deftest bit-orc1.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-orc1 s1 s2) s1 s2)) #0a1 #0a0 @@ -17,7 +17,7 @@ (deftest bit-orc1.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-orc1 s1 s2) s1 s2)) #0a0 #0a1 @@ -25,7 +25,7 @@ (deftest bit-orc1.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-orc1 s1 s2) s1 s2)) #0a1 #0a0 @@ -33,7 +33,7 @@ (deftest bit-orc1.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-orc1 s1 s2) s1 s2)) #0a1 #0a1 @@ -41,9 +41,9 @@ (deftest bit-orc1.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-orc1 s1 s2 s3))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-orc1 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 @@ -53,9 +53,9 @@ (deftest bit-orc1.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-orc1 s1 s2 s3))) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-orc1 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 @@ -65,8 +65,8 @@ (deftest bit-orc1.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-orc1 s1 s2 t))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-orc1 s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a0 #0a0 @@ -78,28 +78,28 @@ (deftest bit-orc1.8 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-orc1 a1 a2)) a1 a2)) #*1101 #*0011 #*0101) (deftest bit-orc1.9 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-orc1 a1 a2 t)))) + (a2 (copy-seq #*0101)) + (result (check-values (bit-orc1 a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1101 #*1101 #*0101 t) (deftest bit-orc1.10 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-orc1 a1 a2 a3)))) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-orc1 a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1101 #*0011 #*0101 #*1101 t) (deftest bit-orc1.11 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-orc1 a1 a2 nil)) a1 a2)) #*1101 #*0011 #*0101) @@ -107,10 +107,10 @@ (deftest bit-orc1.12 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-orc1 a1 a2))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-orc1 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -118,10 +118,10 @@ (deftest bit-orc1.13 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-orc1 a1 a2 t))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-orc1 a1 a2 t))) (values a1 a2 result)) #2a((1 0)(1 1)) #2a((0 0)(1 1)) @@ -129,10 +129,10 @@ (deftest bit-orc1.14 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-orc1 a1 a2 nil))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-orc1 a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -140,12 +140,12 @@ (deftest bit-orc1.15 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-orc1 a1 a2 a3))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-orc1 a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -156,12 +156,12 @@ (deftest bit-orc1.16 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-orc1 a1 a2))) + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-orc1 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -171,14 +171,14 @@ (deftest bit-orc1.17 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-orc1 a1 a2))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-orc1 a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) @@ -187,14 +187,14 @@ (deftest bit-orc1.18 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-orc1 a1 a2 t))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-orc1 a1 a2 t))) (values a0 a1 a2 result)) #*10110011 #2a((1 0)(1 1)) @@ -203,17 +203,17 @@ (deftest bit-orc1.19 (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-orc1 a1 a2 a3))) + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-orc1 a1 a2 a3))) (values a0 a1 a2 result)) #*010100111011 #2a((0 1)(0 1)) @@ -230,23 +230,23 @@ (deftest bit-orc1.22 (macrolet ((%m (z) z)) (bit-orc1 #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) + (expand-in-current-env (%m nil)))) #*01111110) (deftest bit-orc1.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) (values (bit-orc1 (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) + (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) (deftest bit-orc1.fold.1 (flet ((%f () (declare (optimize speed (safety 0) (space 0))) - (bit-orc1 #*11010 #*10100))) + (bit-orc1 #*11010 #*10100))) (values (%f) (let ((bv (%f))) (setf (elt bv 0) 0) bv) (%f))) #*10101 #*00101 #*10101) @@ -268,7 +268,7 @@ (deftest bit-orc1.error.3 (signals-error (bit-orc1 #*000 #*0100 nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/bit-orc2.lsp b/ansi-tests/bit-orc2.lsp index 04de5e53..aaec562e 100644 --- a/ansi-tests/bit-orc2.lsp +++ b/ansi-tests/bit-orc2.lsp @@ -9,7 +9,7 @@ (deftest bit-orc2.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-orc2 s1 s2) s1 s2)) #0a1 #0a0 @@ -17,7 +17,7 @@ (deftest bit-orc2.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-orc2 s1 s2) s1 s2)) #0a1 #0a1 @@ -25,7 +25,7 @@ (deftest bit-orc2.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-orc2 s1 s2) s1 s2)) #0a0 #0a0 @@ -33,7 +33,7 @@ (deftest bit-orc2.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-orc2 s1 s2) s1 s2)) #0a1 #0a1 @@ -41,9 +41,9 @@ (deftest bit-orc2.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-orc2 s1 s2 s3))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-orc2 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 @@ -53,9 +53,9 @@ (deftest bit-orc2.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-orc2 s1 s2 s3))) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-orc2 s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 @@ -65,8 +65,8 @@ (deftest bit-orc2.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-orc2 s1 s2 t))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-orc2 s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a1 #0a0 @@ -78,28 +78,28 @@ (deftest bit-orc2.8 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-orc2 a1 a2)) a1 a2)) #*1011 #*0011 #*0101) (deftest bit-orc2.9 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-orc2 a1 a2 t)))) + (a2 (copy-seq #*0101)) + (result (check-values (bit-orc2 a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*1011 #*1011 #*0101 t) (deftest bit-orc2.10 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-orc2 a1 a2 a3)))) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-orc2 a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*1011 #*0011 #*0101 #*1011 t) (deftest bit-orc2.11 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-orc2 a1 a2 nil)) a1 a2)) #*1011 #*0011 #*0101) @@ -107,10 +107,10 @@ (deftest bit-orc2.12 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-orc2 a1 a2))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-orc2 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -118,10 +118,10 @@ (deftest bit-orc2.13 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-orc2 a1 a2 t))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-orc2 a1 a2 t))) (values a1 a2 result)) #2a((1 1)(0 1)) #2a((0 0)(1 1)) @@ -129,10 +129,10 @@ (deftest bit-orc2.14 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-orc2 a1 a2 nil))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-orc2 a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -140,12 +140,12 @@ (deftest bit-orc2.15 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-orc2 a1 a2 a3))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-orc2 a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -156,12 +156,12 @@ (deftest bit-orc2.16 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-orc2 a1 a2))) + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-orc2 a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -171,14 +171,14 @@ (deftest bit-orc2.17 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-orc2 a1 a2))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-orc2 a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) @@ -187,14 +187,14 @@ (deftest bit-orc2.18 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-orc2 a1 a2 t))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-orc2 a1 a2 t))) (values a0 a1 a2 result)) #*11010011 #2a((1 1)(0 1)) @@ -203,17 +203,17 @@ (deftest bit-orc2.19 (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-orc2 a1 a2 a3))) + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-orc2 a1 a2 a3))) (values a0 a1 a2 result)) #*010100111101 #2a((0 1)(0 1)) @@ -230,22 +230,22 @@ (deftest bit-orc2.22 (macrolet ((%m (z) z)) (bit-orc2 #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) + (expand-in-current-env (%m nil)))) #*10110111) (deftest bit-orc2.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) (values (bit-orc2 (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) + (progn (setf z (incf x)) s2)) x y z)) #*1 2 1 2) (deftest bit-orc2.fold.1 (flet ((%f () (declare (optimize speed (safety 0) (space 0))) - (bit-orc2 #*00101 #*01011))) + (bit-orc2 #*00101 #*01011))) (values (%f) (let ((bv (%f))) (setf (elt bv 0) 0) bv) (%f))) #*10101 #*00101 #*10101) @@ -267,7 +267,7 @@ (deftest bit-orc2.error.3 (signals-error (bit-orc2 #*000 #*0100 nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/bit-vector-p.lsp b/ansi-tests/bit-vector-p.lsp index 3543ff5c..2b5af301 100644 --- a/ansi-tests/bit-vector-p.lsp +++ b/ansi-tests/bit-vector-p.lsp @@ -8,7 +8,7 @@ (deftest bit-vector-p.2 (notnot-mv (bit-vector-p #*)) t) - + (deftest bit-vector-p.3 (notnot-mv (bit-vector-p #*00101)) t) @@ -43,7 +43,7 @@ (deftest bit-vector-p.11 (bit-vector-p (make-array '(2 2) :element-type 'bit - :initial-element 0)) + :initial-element 0)) nil) (deftest bit-vector-p.12 @@ -54,7 +54,7 @@ (macrolet ((%m (z) z)) (values (notnot (bit-vector-p (expand-in-current-env (%m #*110101)))) - (bit-vector-p (expand-in-current-env (%m nil))))) + (bit-vector-p (expand-in-current-env (%m nil))))) t nil) (deftest bit-vector-p.order.1 diff --git a/ansi-tests/bit-vector.lsp b/ansi-tests/bit-vector.lsp index 9acce28d..2c2f0cab 100644 --- a/ansi-tests/bit-vector.lsp +++ b/ansi-tests/bit-vector.lsp @@ -12,7 +12,7 @@ (deftest bit-vector.2 (notnot-mv (typep #* 'bit-vector)) t) - + (deftest bit-vector.3 (notnot-mv (typep #*00101 'bit-vector)) t) @@ -47,8 +47,8 @@ (deftest bit-vector.11 (typep (make-array '(2 2) :element-type 'bit - :initial-element 0) - 'bit-vector) + :initial-element 0) + 'bit-vector) nil) (deftest bit-vector.12 @@ -81,7 +81,7 @@ (deftest bit-vector.class.2 (notnot-mv (typep #* (find-class 'bit-vector))) t) - + (deftest bit-vector.class.3 (notnot-mv (typep #*00101 (find-class 'bit-vector))) t) @@ -116,6 +116,6 @@ (deftest bit-vector.class.11 (typep (make-array '(2 2) :element-type 'bit - :initial-element 0) - (find-class 'bit-vector)) + :initial-element 0) + (find-class 'bit-vector)) nil) diff --git a/ansi-tests/bit-xor.lsp b/ansi-tests/bit-xor.lsp index e1e72582..0f629cfa 100644 --- a/ansi-tests/bit-xor.lsp +++ b/ansi-tests/bit-xor.lsp @@ -9,7 +9,7 @@ (deftest bit-xor.1 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-xor s1 s2) s1 s2)) #0a0 #0a0 @@ -17,7 +17,7 @@ (deftest bit-xor.2 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit))) + (s2 (make-array nil :initial-element 0 :element-type 'bit))) (values (bit-xor s1 s2) s1 s2)) #0a1 #0a1 @@ -25,7 +25,7 @@ (deftest bit-xor.3 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-xor s1 s2) s1 s2)) #0a1 #0a0 @@ -33,7 +33,7 @@ (deftest bit-xor.4 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit))) + (s2 (make-array nil :initial-element 1 :element-type 'bit))) (values (bit-xor s1 s2) s1 s2)) #0a0 #0a1 @@ -41,9 +41,9 @@ (deftest bit-xor.5 (let* ((s1 (make-array nil :initial-element 0 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-xor s1 s2 s3))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-xor s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a0 #0a0 @@ -53,9 +53,9 @@ (deftest bit-xor.6 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 1 :element-type 'bit)) - (s3 (make-array nil :initial-element 1 :element-type 'bit)) - (result (bit-xor s1 s2 s3))) + (s2 (make-array nil :initial-element 1 :element-type 'bit)) + (s3 (make-array nil :initial-element 1 :element-type 'bit)) + (result (bit-xor s1 s2 s3))) (values s1 s2 s3 result (eqt s3 result))) #0a1 #0a1 @@ -65,8 +65,8 @@ (deftest bit-xor.7 (let* ((s1 (make-array nil :initial-element 1 :element-type 'bit)) - (s2 (make-array nil :initial-element 0 :element-type 'bit)) - (result (bit-xor s1 s2 t))) + (s2 (make-array nil :initial-element 0 :element-type 'bit)) + (result (bit-xor s1 s2 t))) (values s1 s2 result (eqt s1 result))) #0a1 #0a0 @@ -78,28 +78,28 @@ (deftest bit-xor.8 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-xor a1 a2)) a1 a2)) #*0110 #*0011 #*0101) (deftest bit-xor.9 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (result (check-values (bit-xor a1 a2 t)))) + (a2 (copy-seq #*0101)) + (result (check-values (bit-xor a1 a2 t)))) (values result a1 a2 (eqt result a1))) #*0110 #*0110 #*0101 t) (deftest bit-xor.10 (let* ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101)) - (a3 (copy-seq #*1110)) - (result (check-values (bit-xor a1 a2 a3)))) + (a2 (copy-seq #*0101)) + (a3 (copy-seq #*1110)) + (result (check-values (bit-xor a1 a2 a3)))) (values result a1 a2 a3 (eqt result a3))) #*0110 #*0011 #*0101 #*0110 t) (deftest bit-xor.11 (let ((a1 (copy-seq #*0011)) - (a2 (copy-seq #*0101))) + (a2 (copy-seq #*0101))) (values (check-values (bit-xor a1 a2 nil)) a1 a2)) #*0110 #*0011 #*0101) @@ -107,10 +107,10 @@ (deftest bit-xor.12 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-xor a1 a2))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-xor a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -118,10 +118,10 @@ (deftest bit-xor.13 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-xor a1 a2 t))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-xor a1 a2 t))) (values a1 a2 result)) #2a((0 1)(1 0)) #2a((0 0)(1 1)) @@ -129,10 +129,10 @@ (deftest bit-xor.14 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (result (bit-xor a1 a2 nil))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (result (bit-xor a1 a2 nil))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -140,12 +140,12 @@ (deftest bit-xor.15 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)))) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)))) - (a3 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(0 0)))) - (result (bit-xor a1 a2 a3))) + :initial-contents '((0 1)(0 1)))) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)))) + (a3 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(0 0)))) + (result (bit-xor a1 a2 a3))) (values a1 a2 a3 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -156,12 +156,12 @@ (deftest bit-xor.16 (let* ((a1 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 1)(0 1)) - :adjustable t)) - (a2 (make-array '(2 2) :element-type 'bit - :initial-contents '((0 0)(1 1)) - :adjustable t)) - (result (bit-xor a1 a2))) + :initial-contents '((0 1)(0 1)) + :adjustable t)) + (a2 (make-array '(2 2) :element-type 'bit + :initial-contents '((0 0)(1 1)) + :adjustable t)) + (result (bit-xor a1 a2))) (values a1 a2 result)) #2a((0 1)(0 1)) #2a((0 0)(1 1)) @@ -171,14 +171,14 @@ (deftest bit-xor.17 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-xor a1 a2))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-xor a1 a2))) (values a0 a1 a2 result)) #*01010011 #2a((0 1)(0 1)) @@ -187,14 +187,14 @@ (deftest bit-xor.18 (let* ((a0 (make-array '(8) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (result (bit-xor a1 a2 t))) + :initial-contents '(0 1 0 1 0 0 1 1))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (result (bit-xor a1 a2 t))) (values a0 a1 a2 result)) #*01100011 #2a((0 1)(1 0)) @@ -203,17 +203,17 @@ (deftest bit-xor.19 (let* ((a0 (make-array '(12) :element-type 'bit - :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) - (a1 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 0)) - (a2 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 4)) - (a3 (make-array '(2 2) :element-type 'bit - :displaced-to a0 - :displaced-index-offset 8)) - (result (bit-xor a1 a2 a3))) + :initial-contents '(0 1 0 1 0 0 1 1 1 1 1 0))) + (a1 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 0)) + (a2 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 4)) + (a3 (make-array '(2 2) :element-type 'bit + :displaced-to a0 + :displaced-index-offset 8)) + (result (bit-xor a1 a2 a3))) (values a0 a1 a2 result)) #*010100110110 #2a((0 1)(0 1)) @@ -230,16 +230,16 @@ (deftest bit-xor.22 (macrolet ((%m (z) z)) (bit-xor #*10100011 #*01101010 - (expand-in-current-env (%m nil)))) + (expand-in-current-env (%m nil)))) #*11001001) (deftest bit-xor.order.1 (let* ((s1 (make-array 1 :initial-element 0 :element-type 'bit)) - (s2 (make-array 1 :initial-element 0 :element-type 'bit)) - (x 0) y z) + (s2 (make-array 1 :initial-element 0 :element-type 'bit)) + (x 0) y z) (values (bit-xor (progn (setf y (incf x)) s1) - (progn (setf z (incf x)) s2)) + (progn (setf z (incf x)) s2)) x y z)) #*0 2 1 2) @@ -263,5 +263,5 @@ (deftest bit-xor.error.3 (signals-error (bit-xor #*000 #*0100 nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/bit.lsp b/ansi-tests/bit.lsp index 4b2de409..e043c70f 100644 --- a/ansi-tests/bit.lsp +++ b/ansi-tests/bit.lsp @@ -12,9 +12,9 @@ (deftest bit.2 (let ((a #*00000000)) (loop for i from 0 below (length a) - collect (let ((b (copy-seq a))) - (setf (bit b i) 1) - b))) + collect (let ((b (copy-seq a))) + (setf (bit b i) 1) + b))) (#*10000000 #*01000000 #*00100000 @@ -27,9 +27,9 @@ (deftest bit.3 (let ((a #*11111111)) (loop for i from 0 below (length a) - collect (let ((b (copy-seq a))) - (setf (bit b i) 0) - b))) + collect (let ((b (copy-seq a))) + (setf (bit b i) 0) + b))) (#*01111111 #*10111111 #*11011111 @@ -73,13 +73,13 @@ (deftest bit.7 (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 1 1 1 0 0) - :element-type 'bit - :fill-pointer 5))) + :element-type 'bit + :fill-pointer 5))) (values (coerce a 'list) (loop for i from 0 below 10 collect (bit a i)) (loop for i from 0 below 10 - collect (setf (bit a i) (- 1 (bit a i)))) + collect (setf (bit a i) (- 1 (bit a i)))) (coerce a 'list) (loop for i from 0 below 10 collect (bit a i)) (fill-pointer a))) @@ -94,13 +94,13 @@ (deftest bit.8 (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 1 1 1 0 0) - :element-type 'bit - :adjustable t))) + :element-type 'bit + :adjustable t))) (values (coerce a 'list) (loop for i from 0 below 10 collect (bit a i)) (loop for i from 0 below 10 - collect (setf (bit a i) (- 1 (bit a i)))) + collect (setf (bit a i) (- 1 (bit a i)))) (coerce a 'list) (loop for i from 0 below 10 collect (bit a i)))) (0 1 1 0 0 1 1 1 0 0) @@ -113,20 +113,20 @@ (deftest bit.order.1 (let ((x 0) y z - (b (copy-seq #*01010))) + (b (copy-seq #*01010))) (values (bit (progn (setf y (incf x)) b) - (progn (setf z (incf x)) 1)) + (progn (setf z (incf x)) 1)) x y z)) 1 2 1 2) (deftest bit.order.2 (let ((x 0) y z w - (b (copy-seq #*01010))) + (b (copy-seq #*01010))) (values (setf (bit (progn (setf y (incf x)) b) - (progn (setf z (incf x)) 1)) - (progn (setf w (incf x)) 0)) + (progn (setf z (incf x)) 1)) + (progn (setf w (incf x)) 0)) b x y z w)) 0 #*00010 3 1 2 3) diff --git a/ansi-tests/block.lsp b/ansi-tests/block.lsp index 793010fb..2b41460c 100644 --- a/ansi-tests/block.lsp +++ b/ansi-tests/block.lsp @@ -80,7 +80,7 @@ (deftest block.12 (macrolet ((%m (z) z)) - (block foo (expand-in-current-env (%m :good)))) + (block foo (expand-in-current-env (%m :good)))) :good) #| diff --git a/ansi-tests/boole.lsp b/ansi-tests/boole.lsp index 5a91f48e..74fdac38 100644 --- a/ansi-tests/boole.lsp +++ b/ansi-tests/boole.lsp @@ -14,26 +14,26 @@ (defparameter *boole-vals* (list boole-1 boole-2 boole-and boole-andc1 boole-andc2 - boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand - boole-nor boole-orc1 boole-orc2 boole-set boole-xor)) + boole-c1 boole-c2 boole-clr boole-eqv boole-ior boole-nand + boole-nor boole-orc1 boole-orc2 boole-set boole-xor)) (defparameter *boole-fns* (list #'(lambda (x y) (declare (ignore y)) x) - #'(lambda (x y) (declare (ignore x)) y) - #'logand - #'logandc1 - #'logandc2 - #'(lambda (x y) (declare (ignore y)) (lognot x)) - #'(lambda (x y) (declare (ignore x)) (lognot y)) - (constantly 0) - #'logeqv - #'logior - #'lognand - #'lognor - #'logorc1 - #'logorc2 - (constantly -1) - #'logxor)) + #'(lambda (x y) (declare (ignore x)) y) + #'logand + #'logandc1 + #'logandc2 + #'(lambda (x y) (declare (ignore y)) (lognot x)) + #'(lambda (x y) (declare (ignore x)) (lognot y)) + (constantly 0) + #'logeqv + #'logior + #'lognand + #'lognor + #'logorc1 + #'logorc2 + (constantly -1) + #'logxor)) (deftest boole.error.1 (signals-error (boole) program-error) @@ -58,67 +58,67 @@ (deftest boole.error.6 (loop for n in *boole-val-names* - unless (eval `(signals-type-error x nil (boole ,n nil 1))) - collect n) + unless (eval `(signals-type-error x nil (boole ,n nil 1))) + collect n) nil) (deftest boole.error.7 (loop for n in *boole-val-names* - unless (eval `(signals-type-error x nil (boole ,n 1 nil))) - collect n) + unless (eval `(signals-type-error x nil (boole ,n 1 nil))) + collect n) nil) (deftest boole.1 (loop for v in *boole-vals* - for fn of-type function in *boole-fns* - for n in *boole-val-names* - nconc - (loop for x = (random-fixnum) - for y = (random-fixnum) - for result1 = (funcall (the function fn) x y) - for vals = (multiple-value-list (boole v x y)) - for result2 = (car vals) - repeat 100 - unless (and (= (length vals) 1) (eql result1 result2)) - collect (list n x y result1 result2))) + for fn of-type function in *boole-fns* + for n in *boole-val-names* + nconc + (loop for x = (random-fixnum) + for y = (random-fixnum) + for result1 = (funcall (the function fn) x y) + for vals = (multiple-value-list (boole v x y)) + for result2 = (car vals) + repeat 100 + unless (and (= (length vals) 1) (eql result1 result2)) + collect (list n x y result1 result2))) nil) (deftest boole.2 (loop for v in *boole-vals* - for fn of-type function in *boole-fns* - for n in *boole-val-names* - nconc - (loop for x = (random-from-interval 1000000000000000) - for y = (random-from-interval 1000000000000000) - for result1 = (funcall (the function fn) x y) - for vals = (multiple-value-list (boole v x y)) - for result2 = (car vals) - repeat 100 - unless (and (= (length vals) 1) (eql result1 result2)) - collect (list n x y result1 result2))) + for fn of-type function in *boole-fns* + for n in *boole-val-names* + nconc + (loop for x = (random-from-interval 1000000000000000) + for y = (random-from-interval 1000000000000000) + for result1 = (funcall (the function fn) x y) + for vals = (multiple-value-list (boole v x y)) + for result2 = (car vals) + repeat 100 + unless (and (= (length vals) 1) (eql result1 result2)) + collect (list n x y result1 result2))) nil) (deftest boole.3 (loop for n in *boole-val-names* - for fn of-type function in *boole-fns* - for fn2 = (compile nil `(lambda (x y) (declare (type fixnum x y)) - (boole ,n x y))) - nconc - (loop for x = (random-fixnum) - for y = (random-fixnum) - for result1 = (funcall (the function fn) x y) - for vals = (multiple-value-list (funcall fn2 x y)) - for result2 = (car vals) - repeat 100 - unless (and (= (length vals) 1) (eql result1 result2)) - collect (list n x y result1 result2))) + for fn of-type function in *boole-fns* + for fn2 = (compile nil `(lambda (x y) (declare (type fixnum x y)) + (boole ,n x y))) + nconc + (loop for x = (random-fixnum) + for y = (random-fixnum) + for result1 = (funcall (the function fn) x y) + for vals = (multiple-value-list (funcall fn2 x y)) + for result2 = (car vals) + repeat 100 + unless (and (= (length vals) 1) (eql result1 result2)) + collect (list n x y result1 result2))) nil) (deftest boole.4 (macrolet ((%m (z) z)) - (values (boole (expand-in-current-env (%m boole-and)) #b11001100 #b01011010) - (boole boole-and (expand-in-current-env (%m #b11001100)) #b01011010) - (boole boole-and #b11001100 (expand-in-current-env (%m #b01011010))))) + (values (boole (expand-in-current-env (%m boole-and)) #b11001100 #b01011010) + (boole boole-and (expand-in-current-env (%m #b11001100)) #b01011010) + (boole boole-and #b11001100 (expand-in-current-env (%m #b01011010))))) #b01001000 #b01001000 #b01001000) @@ -138,7 +138,7 @@ (deftest boole.constants.1 (eqlt (length *boole-vals*) - (length (remove-duplicates *boole-vals*))) + (length (remove-duplicates *boole-vals*))) t) (deftest boole.constants.2 diff --git a/ansi-tests/boundp.lsp b/ansi-tests/boundp.lsp index 6c83b0b9..dd1e2b9f 100644 --- a/ansi-tests/boundp.lsp +++ b/ansi-tests/boundp.lsp @@ -50,8 +50,8 @@ ;;; See 11.1.2.1.1 (deftest boundp.5 (loop for x in *cl-non-variable-constant-symbols* - when (boundp x) - collect x) + when (boundp x) + collect x) nil) (deftest boundp.6 diff --git a/ansi-tests/broadcast-stream-streams.lsp b/ansi-tests/broadcast-stream-streams.lsp index f0aef320..9033a08d 100644 --- a/ansi-tests/broadcast-stream-streams.lsp +++ b/ansi-tests/broadcast-stream-streams.lsp @@ -21,7 +21,7 @@ (deftest broadcast-stream-streams.error.2 (signals-error (broadcast-stream-streams (make-broadcast-stream) nil) - program-error) + program-error) t) diff --git a/ansi-tests/butlast.lsp b/ansi-tests/butlast.lsp index 717a6eb5..f8c9811e 100644 --- a/ansi-tests/butlast.lsp +++ b/ansi-tests/butlast.lsp @@ -11,36 +11,36 @@ (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) (let ((result (butlast x 2))) - (and - (check-scaffold-copy x xcopy) - result)))) + (and + (check-scaffold-copy x xcopy) + result)))) (a b c)) (deftest butlast.2 (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) (let ((result (butlast x 0))) - (and - (check-scaffold-copy x xcopy) - result)))) + (and + (check-scaffold-copy x xcopy) + result)))) (a b c d e)) (deftest butlast.3 (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) (let ((result (butlast x 5))) - (and - (check-scaffold-copy x xcopy) - result)))) + (and + (check-scaffold-copy x xcopy) + result)))) nil) (deftest butlast.4 (let ((x (list 'a 'b 'c 'd 'e))) (let ((xcopy (make-scaffold-copy x))) (let ((result (butlast x 6))) - (and - (check-scaffold-copy x xcopy) - result)))) + (and + (check-scaffold-copy x xcopy) + result)))) nil) (deftest butlast.5 @@ -61,18 +61,18 @@ (deftest butlast.9 (macrolet ((%m (z) z)) - (values (butlast (expand-in-current-env (%m (list 'a 'b 'c)))) - (butlast (list 'a 'b 'c 'd 'e) (expand-in-current-env (%m 2))))) + (values (butlast (expand-in-current-env (%m (list 'a 'b 'c)))) + (butlast (list 'a 'b 'c 'd 'e) (expand-in-current-env (%m 2))))) (a b) - (a b c)) + (a b c)) (deftest butlast.order.1 (let ((i 0) x y) (values (butlast (progn (setf x (incf i)) - (list 'a 'b 'c 'd 'e)) - (progn (setf y (incf i)) - 2)) + (list 'a 'b 'c 'd 'e)) + (progn (setf y (incf i)) + 2)) i x y)) (a b c) 2 1 2) @@ -91,7 +91,7 @@ (deftest butlast.error.1 (signals-error (butlast (copy-tree '(a b c d)) 'a) - type-error) + type-error) t) (deftest butlast.error.2 diff --git a/ansi-tests/byte.lsp b/ansi-tests/byte.lsp index 456e7a43..f9afd20d 100644 --- a/ansi-tests/byte.lsp +++ b/ansi-tests/byte.lsp @@ -27,12 +27,12 @@ (deftest byte.3 (loop for i from 0 to 100 - always - (loop for j from 0 to 100 - always - (let ((bspec (byte i j))) - (and (eql i (byte-size bspec)) - (eql j (byte-position bspec)))))) + always + (loop for j from 0 to 100 + always + (let ((bspec (byte i j))) + (and (eql i (byte-size bspec)) + (eql j (byte-position bspec)))))) t) (deftest byte.4 @@ -63,7 +63,7 @@ (deftest byte-position.error.2 (signals-error (byte-position (byte 1 1) nil) - program-error) + program-error) t) (deftest byte-size.error.1 diff --git a/ansi-tests/call-arguments-limit.lsp b/ansi-tests/call-arguments-limit.lsp index 478465e3..ac178951 100644 --- a/ansi-tests/call-arguments-limit.lsp +++ b/ansi-tests/call-arguments-limit.lsp @@ -19,7 +19,7 @@ (deftest call-arguments-limit.4 (let* ((m (min 65536 (1- call-arguments-limit))) - (args (make-list m :initial-element 'a))) + (args (make-list m :initial-element 'a))) (equalt (apply #'list args) args)) t) diff --git a/ansi-tests/call-next-method.lsp b/ansi-tests/call-next-method.lsp index 4a6b18d2..8f4ec10b 100644 --- a/ansi-tests/call-next-method.lsp +++ b/ansi-tests/call-next-method.lsp @@ -102,8 +102,8 @@ (:method ((x integer)) (list (incf x) (call-next-method))) (:method ((x symbol)) (list (setq x 'a) x (call-next-method))) (:method ((x cons)) (list x (let ((x :bad)) - (declare (ignorable x)) - (call-next-method)))) + (declare (ignorable x)) + (call-next-method)))) (:method ((x t)) x)) (deftest call-next-method.8 @@ -147,9 +147,9 @@ (defgeneric cnm-gf-10 (x &optional y z) (:method ((x integer) &optional (y 'a y-p) (z 'b z-p)) - (list* x y (notnot y-p) z (notnot z-p) (call-next-method (1+ x)))) + (list* x y (notnot y-p) z (notnot z-p) (call-next-method (1+ x)))) (:method ((x t) &optional (y 'c y-p) (z 'd z-p)) - (list x y (notnot y-p) z (notnot z-p)))) + (list x y (notnot y-p) z (notnot z-p)))) (deftest call-next-method.11 (values @@ -175,39 +175,39 @@ (defgeneric cnm-order-error-gf-01 (x) (declare (optimize (safety 3))) (:method ((x (eql 0))) - (declare (optimize (safety 3))) - (call-next-method 1)) ;; no longer EQL to 0 + (declare (optimize (safety 3))) + (call-next-method 1)) ;; no longer EQL to 0 (:method ((x t)) nil)) (deftest call-next-method.error.1 (locally (declare (optimize (safety 3))) - (handler-case + (handler-case (eval '(locally (declare (optimize (safety 3))) - (cnm-order-error-gf-01 0))) + (cnm-order-error-gf-01 0))) (error () :error))) :error) (defgeneric cnm-order-error-gf-02 (x) (declare (optimize (safety 3))) (:method ((x integer)) - (declare (optimize (safety 3))) - (call-next-method :bad)) + (declare (optimize (safety 3))) + (call-next-method :bad)) (:method ((x t)) x)) (deftest call-next-method.error.2 (locally (declare (optimize (safety 3))) - (handler-case + (handler-case (eval '(locally (declare (optimize (safety 3))) - (cnm-order-error-gf-02 0))) + (cnm-order-error-gf-02 0))) (error () :error))) :error) - - + + diff --git a/ansi-tests/case.lsp b/ansi-tests/case.lsp index 8b24d08f..3238d003 100644 --- a/ansi-tests/case.lsp +++ b/ansi-tests/case.lsp @@ -19,9 +19,9 @@ (deftest case.4 (case 'z ((a b c) 1) - ((d e) 2) - ((f z g) 3) - (t 4)) + ((d e) 2) + ((f z g) 3) + (t 4)) 3) (deftest case.5 @@ -171,8 +171,8 @@ (block done (tagbody (case 'a (a (go 10) - 10 - (return-from done 'bad))) + 10 + (return-from done 'bad))) 10 (return-from done 'good))) good) @@ -183,8 +183,8 @@ (case 'b (a 'bad) (otherwise (go 10) - 10 - (return-from done 'bad))) + 10 + (return-from done 'bad))) 10 (return-from done 'good))) good) @@ -196,10 +196,10 @@ (macrolet ((%m (z) z)) (case (expand-in-current-env (%m :b)) - (:a :bad1) - (:b :good) - (:c :bad2) - (t :bad3))) + (:a :bad1) + (:b :good) + (:c :bad2) + (t :bad3))) :good) ;;; (deftest case.error.1 @@ -208,15 +208,15 @@ (deftest case.error.1 (signals-error (funcall (macro-function 'case)) - program-error) + program-error) t) (deftest case.error.2 (signals-error (funcall (macro-function 'case) '(case t)) - program-error) + program-error) t) (deftest case.error.3 (signals-error (funcall (macro-function 'case) '(case t) nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/catch.lsp b/ansi-tests/catch.lsp index be735b4c..a98931dc 100644 --- a/ansi-tests/catch.lsp +++ b/ansi-tests/catch.lsp @@ -31,12 +31,12 @@ ;; ;; (deftest catch.6 ;; (let ((tag1 (1+ most-positive-fixnum)) -;; (tag2 (1+ most-positive-fixnum))) +;; (tag2 (1+ most-positive-fixnum))) ;; (if (eqt tag1 tag2) -;; 'good +;; 'good ;; (catch tag1 -;; (catch tag2 (throw tag1 'good)) -;; 'bad))) +;; (catch tag2 (throw tag1 'good)) +;; 'bad))) ;; good) (deftest catch.7 @@ -91,17 +91,17 @@ (deftest catch.14 (macrolet ((%m (z) z)) - (catch 'foo (expand-in-current-env (%m :good)))) + (catch 'foo (expand-in-current-env (%m :good)))) :good) (deftest catch.15 (macrolet ((%m (z) z)) - (catch 'foo (throw (expand-in-current-env (%m 'foo)) :good) :bad)) + (catch 'foo (throw (expand-in-current-env (%m 'foo)) :good) :bad)) :good) (deftest catch.16 (macrolet ((%m (z) z)) - (catch 'foo (throw 'foo (expand-in-current-env (%m :good))) :bad)) + (catch 'foo (throw 'foo (expand-in-current-env (%m :good))) :bad)) :good) (deftest throw-error diff --git a/ansi-tests/ccase.lsp b/ansi-tests/ccase.lsp index 68710519..0ef08422 100644 --- a/ansi-tests/ccase.lsp +++ b/ansi-tests/ccase.lsp @@ -37,9 +37,9 @@ (deftest ccase.7 (let ((x 'z)) (ccase x - ((a b c) 1) - ((d e) 2) - ((f z g) 3))) + ((a b c) 1) + ((d e) 2) + ((f z g) 3))) 3) (deftest ccase.8 @@ -94,10 +94,10 @@ (deftest ccase.20 (let ((x #\a)) (ccase x - ((#\b #\c) 10) - ((#\d #\e #\A) 20) - (() 30) - ((#\z #\a #\y) 40))) + ((#\b #\c) 10) + ((#\d #\e #\A) 20) + (() 30) + ((#\z #\a #\y) 40))) 40) (deftest ccase.21 (let ((x 1)) (ccase x (1 (values)) (2 'a)))) @@ -108,7 +108,7 @@ ;;; Show that the key expression is evaluated only once. (deftest ccase.25 (let ((a (vector 'a 'b 'c 'd 'e)) - (i 1)) + (i 1)) (values (ccase (aref a (incf i)) (a 1) @@ -168,8 +168,8 @@ (tagbody (let ((x 'a)) (ccase x (a (go 10) - 10 - (return-from done 'bad)))) + 10 + (return-from done 'bad)))) 10 (return-from done 'good))) good) @@ -182,9 +182,9 @@ (macrolet ((%m (z) z)) (ccase (expand-in-current-env (%m x)) - (:a :bad1) - (:b :good) - (:c :bad2)))) + (:a :bad1) + (:b :good) + (:c :bad2)))) :good) @@ -195,15 +195,15 @@ (deftest ccase.error.1 (signals-error (funcall (macro-function 'ccase)) - program-error) + program-error) t) (deftest ccase.error.2 (signals-error (funcall (macro-function 'ccase) '(ccase t)) - program-error) + program-error) t) (deftest ccase.error.3 (signals-error (funcall (macro-function 'ccase) '(ccase t) nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/ceiling-aux.lsp b/ansi-tests/ceiling-aux.lsp index ada69725..6e74c9ee 100644 --- a/ansi-tests/ceiling-aux.lsp +++ b/ansi-tests/ceiling-aux.lsp @@ -7,100 +7,100 @@ (defun ceiling.1-fn () (loop for n = (- (random 2000000000) - 1000000000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (ceiling n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (integerp r) - (< (- d) r 1)) - collect (list n d q r n2))) + 1000000000) + for d = (1+ (random 10000)) + for vals = (multiple-value-list (ceiling n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (= n n2) + (integerp r) + (< (- d) r 1)) + collect (list n d q r n2))) (defun ceiling.2-fn () (loop for num = (random 1000000000) - for denom = (1+ (random 1000)) - for n = (/ num denom) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (ceiling n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (<= r 0) - (< (- d) r) - (= n n2)) - collect (list n d q r n2))) + for denom = (1+ (random 1000)) + for n = (/ num denom) + for d = (1+ (random 10000)) + for vals = (multiple-value-list (ceiling n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (<= r 0) + (< (- d) r) + (= n n2)) + collect (list n d q r n2))) (defun ceiling.3-fn (width) (loop for n = (- (random width) (/ width 2)) - for vals = (multiple-value-list (ceiling n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (<= 0 (- r)) - (< (- r) 1) - ) - collect (list n q r n2))) + for vals = (multiple-value-list (ceiling n)) + for (q r) = vals + for n2 = (+ q r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (= n n2) + (<= 0 (- r)) + (< (- r) 1) + ) + collect (list n q r n2))) (defun ceiling.7-fn () (loop for numerator = (- (random 10000000000) 5000000000) - for denominator = (1+ (random 100000)) - for n = (/ numerator denominator) - for vals = (multiple-value-list (ceiling n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (= n n2) - (<= 0 (- r)) - (< (- r) 1) - ) - collect (list n q r n2))) + for denominator = (1+ (random 100000)) + for n = (/ numerator denominator) + for vals = (multiple-value-list (ceiling n)) + for (q r) = vals + for n2 = (+ q r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (rationalp r) + (= n n2) + (<= 0 (- r)) + (< (- r) 1) + ) + collect (list n q r n2))) (defun ceiling.8-fn () (loop for num1 = (- (random 10000000000) 5000000000) - for den1 = (1+ (random 100000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000))) - for den2 = (1+ (random 1000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (ceiling n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (<= 0 r) - (< r (- d)) - (= n n2)) - collect (list n q d r n2))) + for den1 = (1+ (random 100000)) + for n = (/ num1 den1) + for num2 = (- (1+ (random 1000000))) + for den2 = (1+ (random 1000000)) + for d = (/ num2 den2) + for vals = (multiple-value-list (ceiling n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (rationalp r) + (<= 0 r) + (< r (- d)) + (= n n2)) + collect (list n q d r n2))) (defun ceiling.9-fn () (loop for num1 = (- (random 1000000000000000) 500000000000000) - for den1 = (1+ (random 10000000000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000000))) - for den2 = (1+ (random 10000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (ceiling n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (<= 0 r) - (< r (- d)) - (= n n2)) - collect (list n q d r n2))) + for den1 = (1+ (random 10000000000)) + for n = (/ num1 den1) + for num2 = (- (1+ (random 1000000000))) + for den2 = (1+ (random 10000000)) + for d = (/ num2 den2) + for vals = (multiple-value-list (ceiling n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (rationalp r) + (<= 0 r) + (< r (- d)) + (= n n2)) + collect (list n q d r n2))) diff --git a/ansi-tests/ceiling.lsp b/ansi-tests/ceiling.lsp index 708a2a56..827b7850 100644 --- a/ansi-tests/ceiling.lsp +++ b/ansi-tests/ceiling.lsp @@ -56,118 +56,118 @@ (deftest ceiling.10 (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (ceiling x x)) - unless (and (eql q 1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) + for (q r) = (multiple-value-list (ceiling x x)) + unless (and (eql q 1) + (zerop r) + (if (rationalp x) (eql r 0) + (eql r (float 0 x)))) + collect x) nil) (deftest ceiling.11 (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (ceiling (- x) x)) - unless (and (eql q -1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) + for (q r) = (multiple-value-list (ceiling (- x) x)) + unless (and (eql q -1) + (zerop r) + (if (rationalp x) (eql r 0) + (eql r (float 0 x)))) + collect x) nil) (deftest ceiling.12 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q (1+ i)) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (ceiling x)) + unless (and (eql q (1+ i)) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest ceiling.13 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q i) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (ceiling x)) + unless (and (eql q i) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest ceiling.14 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q (1+ i)) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (ceiling x)) + unless (and (eql q (1+ i)) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest ceiling.15 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q i) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (ceiling x)) + unless (and (eql q i) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest ceiling.16 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q (1+ i)) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (ceiling x)) + unless (and (eql q (1+ i)) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest ceiling.17 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q i) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (ceiling x)) + unless (and (eql q i) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest ceiling.18 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q (1+ i)) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (ceiling x)) + unless (and (eql q (1+ i)) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest ceiling.19 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ceiling x)) - unless (and (eql q i) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (ceiling x)) + unless (and (eql q i) + (eql r (- rrad 1))) + collect (list i x q r))) nil) ;;; To add: tests that involve adding/subtracting EPSILON constants diff --git a/ansi-tests/cell-error-name.lsp b/ansi-tests/cell-error-name.lsp index 25b4b818..0ea7d46b 100644 --- a/ansi-tests/cell-error-name.lsp +++ b/ansi-tests/cell-error-name.lsp @@ -21,11 +21,11 @@ (deftest cell-error-name.3 (cell-error-name (make-condition 'unbound-variable :name 'x)) x) - + (deftest cell-error-name.4 (cell-error-name (make-condition 'undefined-function :name 'f)) f) - + (deftest cell-error-name.5 (cell-error-name (make-condition 'unbound-slot :name 's)) s) @@ -34,11 +34,11 @@ (let ((i 0)) (values (cell-error-name (progn (incf i) (make-condition - 'unbound-slot :name 's))) + 'unbound-slot :name 's))) i)) s 1) - + ;;; Need test raising condition unbound-slot @@ -48,5 +48,5 @@ (deftest cell-error-name.error.2 (signals-error (cell-error-name (make-condition 'unbound-variable :name 'foo) nil) - program-error) + program-error) t) diff --git a/ansi-tests/cerror.lsp b/ansi-tests/cerror.lsp index 16ac6c92..10f5c3c2 100644 --- a/ansi-tests/cerror.lsp +++ b/ansi-tests/cerror.lsp @@ -9,54 +9,54 @@ (deftest cerror.1 (let ((fmt "Cerror")) (handler-case (cerror "Keep going." fmt) - (simple-error (c) (frob-simple-error c fmt)))) + (simple-error (c) (frob-simple-error c fmt)))) t) (deftest cerror.2 (let* ((fmt "Cerror") - (cnd (make-condition 'simple-error :format-control fmt))) + (cnd (make-condition 'simple-error :format-control fmt))) (handler-case (cerror "Continue on." cnd) - (simple-error (c) (frob-simple-error c fmt)))) + (simple-error (c) (frob-simple-error c fmt)))) t) (deftest cerror.2a (let* ((fmt (formatter "Cerror")) - (cnd (make-condition 'simple-error :format-control fmt))) + (cnd (make-condition 'simple-error :format-control fmt))) (handler-case (cerror "Continue on." cnd) - (simple-error (c) (frob-simple-error c fmt)))) + (simple-error (c) (frob-simple-error c fmt)))) t) (deftest cerror.3 (let ((fmt "Cerror")) (handler-case (cerror "Continue" 'simple-error :format-control fmt) - (simple-error (c) (frob-simple-error c fmt)))) + (simple-error (c) (frob-simple-error c fmt)))) t) (deftest cerror.4 (let ((fmt "Cerror: ~A")) (handler-case (cerror "On on" fmt 10) - (simple-error (c) (frob-simple-error c fmt 10)))) + (simple-error (c) (frob-simple-error c fmt 10)))) t) (deftest cerror.4a (let ((fmt (formatter "Cerror: ~A"))) (handler-case (cerror "On on" fmt 10) - (simple-error (c) (frob-simple-error c fmt 10)))) + (simple-error (c) (frob-simple-error c fmt 10)))) t) (deftest cerror.5 (let ((fmt (formatter "Cerror"))) (handler-case (cerror "Keep going." fmt) - (simple-error (c) (frob-simple-error c fmt)))) + (simple-error (c) (frob-simple-error c fmt)))) t) ;;; Continuing from a cerror (deftest cerror.6 (handler-bind ((simple-error #'(lambda (c) (continue c)))) - (progn - (cerror "Wooo" 'simple-error) - 10)) + (progn + (cerror "Wooo" 'simple-error) + 10)) 10) ;;; Program error cases diff --git a/ansi-tests/change-class.lsp b/ansi-tests/change-class.lsp index 65a33819..ac5b9d71 100644 --- a/ansi-tests/change-class.lsp +++ b/ansi-tests/change-class.lsp @@ -13,7 +13,7 @@ (deftest change-class.1.1 (let ((obj (make-instance 'change-class-class-01a)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (values (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) @@ -29,7 +29,7 @@ (deftest change-class.1.2 (let ((obj (make-instance 'change-class-class-01a :a 1)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (values (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) @@ -45,7 +45,7 @@ (deftest change-class.1.3 (let ((obj (make-instance 'change-class-class-01a :b 2)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (values (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) @@ -62,7 +62,7 @@ (deftest change-class.1.4 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (values (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) @@ -79,7 +79,7 @@ (deftest change-class.1.5 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :b2 8 :c2 76)) (typep* obj 'change-class-class-01a) @@ -91,7 +91,7 @@ (deftest change-class.1.6 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :b2 19 :b2 34)) (typep* obj 'change-class-class-01a) @@ -103,7 +103,7 @@ (deftest change-class.1.7 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :allow-other-keys nil)) (typep* obj 'change-class-class-01a) @@ -115,7 +115,7 @@ (deftest change-class.1.8 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :allow-other-keys t)) (typep* obj 'change-class-class-01a) @@ -127,10 +127,10 @@ (deftest change-class.1.9 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :allow-other-keys t - :nonsense t)) + :nonsense t)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) @@ -140,10 +140,10 @@ (deftest change-class.1.10 (let ((obj (make-instance 'change-class-class-01a :a 1 :b 2 :c 5)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (values (eqt obj (change-class obj new-class :bad 0 :allow-other-keys t - :allow-other-keys nil :nonsense t)) + :allow-other-keys nil :nonsense t)) (typep* obj 'change-class-class-01a) (typep* obj 'change-class-class-01b) (slot-exists-p obj 'a) @@ -155,7 +155,7 @@ (handler-case (eval '(let ((obj (make-instance 'change-class-class-01a)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (declare (optimize (safety 3))) (eqt obj (change-class obj new-class :nonsense t)))) (error () :expected-error)) @@ -164,8 +164,8 @@ ;; test of class name as second argument (deftest change-class.1.12 (let ((obj (make-instance 'change-class-class-01a :b 1)) - ;; (new-class (find-class 'change-class-class-01b)) - ) + ;; (new-class (find-class 'change-class-class-01b)) + ) (values (eqt obj (change-class obj 'change-class-class-01b :c2 3)) (typep* obj 'change-class-class-01a) @@ -188,7 +188,7 @@ (deftest change-class.2.1 (let ((obj (make-instance 'change-class-class-02a)) - (new-class (find-class 'change-class-class-02b))) + (new-class (find-class 'change-class-class-02b))) (slot-makunbound obj 'a) (slot-makunbound obj 'b) (values @@ -205,9 +205,9 @@ (deftest change-class.2.2 (let ((obj (make-instance 'change-class-class-02a)) - (obj2 (make-instance 'change-class-class-02a)) - obj3 - (new-class (find-class 'change-class-class-02b))) + (obj2 (make-instance 'change-class-class-02a)) + obj3 + (new-class (find-class 'change-class-class-02b))) (setf (slot-value obj 'a) 'foo) (slot-makunbound obj 'b) (values @@ -218,7 +218,7 @@ (typep* obj 'change-class-class-02a) (typep* obj 'change-class-class-02b) (map-slot-boundp* (setf obj3 (make-instance 'change-class-class-02a)) - '(a b)) + '(a b)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj2 'a) @@ -235,10 +235,10 @@ (deftest change-class.2.3 (let ((obj (make-instance 'change-class-class-02a)) - (obj2 (make-instance 'change-class-class-02a)) - (new-class (find-class 'change-class-class-02b))) + (obj2 (make-instance 'change-class-class-02a)) + (new-class (find-class 'change-class-class-02b))) (setf (slot-value obj 'a) 1 - (slot-value obj 'b) 16) + (slot-value obj 'b) 16) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) @@ -248,9 +248,9 @@ (map-slot-boundp* (make-instance 'change-class-class-02a) '(a b)) (map-slot-boundp* obj '(a b)) (progn (slot-makunbound obj2 'a) - (slot-makunbound obj2 'b) - (map-slot-boundp* obj '(a b))))) - + (slot-makunbound obj2 'b) + (map-slot-boundp* obj '(a b))))) + (t t) t nil t (t t) @@ -269,9 +269,9 @@ (deftest change-class.3.1 (let* ((obj (make-instance 'change-class-class-03a)) - (new-class (find-class 'change-class-class-03b)) - (obj2 (make-instance new-class)) - obj3) + (new-class (find-class 'change-class-class-03b)) + (obj2 (make-instance new-class)) + obj3) (slot-makunbound obj2 'a) (slot-makunbound obj2 'b) (values @@ -288,9 +288,9 @@ (deftest change-class.3.2 (let* ((obj (make-instance 'change-class-class-03a :a 1)) - (new-class (find-class 'change-class-class-03b)) - (obj2 (make-instance new-class)) - obj3) + (new-class (find-class 'change-class-class-03b)) + (obj2 (make-instance new-class)) + obj3) (slot-makunbound obj2 'a) (setf (slot-value obj2 'b) 17) (values @@ -320,7 +320,7 @@ (deftest change-class.4.1 (let ((obj (make-instance 'change-class-class-04a)) - (new-class (find-class 'change-class-class-04b))) + (new-class (find-class 'change-class-class-04b))) (values (eqt obj (change-class obj new-class)) (map-slot-boundp* obj '(a c)) @@ -331,7 +331,7 @@ (deftest change-class.4.2 (let ((obj (make-instance 'change-class-class-04a)) - (new-class (find-class 'change-class-class-04b))) + (new-class (find-class 'change-class-class-04b))) (values (eqt obj (change-class obj new-class :a2 'z)) (map-slot-value obj '(a c)))) @@ -340,7 +340,7 @@ (deftest change-class.4.3 (let ((obj (make-instance 'change-class-class-04a :a 'p :b 'q)) - (new-class (find-class 'change-class-class-04b))) + (new-class (find-class 'change-class-class-04b))) (values (eqt obj (change-class obj new-class)) (map-slot-value obj '(a c)))) @@ -349,7 +349,7 @@ (deftest change-class.4.4 (let ((obj (make-instance 'change-class-class-04a)) - (new-class (find-class 'change-class-class-04b))) + (new-class (find-class 'change-class-class-04b))) (values (eqt obj (change-class obj new-class :c2 'k)) (map-slot-boundp* obj '(a c)) @@ -360,7 +360,7 @@ (deftest change-class.4.5 (let* ((class (find-class 'change-class-class-04b)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a c)) (eqt obj (change-class obj class)) @@ -368,7 +368,7 @@ (nil nil) t (nil nil)) - + ;;; Custom methods for change-class @@ -388,7 +388,7 @@ (deftest change-class.5 (let ((*changed-class-on-class-05* nil) - (obj (make-instance 'change-class-class-05))) + (obj (make-instance 'change-class-class-05))) (values (eqt obj (change-class obj (find-class 'change-class-class-05))) *changed-class-on-class-05*)) @@ -410,7 +410,7 @@ (deftest change-class.6.1 (let* ((class (find-class 'change-class-class-06)) - (obj (make-instance class))) + (obj (make-instance class))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class)) @@ -424,7 +424,7 @@ (deftest change-class.6.2 (let* ((class (find-class 'change-class-class-06)) - (obj (make-instance class :a 'bad))) + (obj (make-instance class :a 'bad))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class)) @@ -455,10 +455,10 @@ (declare (ignore initargs)) (setf (slot-value obj 'a) 'z) obj)) - + (deftest change-class.7.1 (let* ((class (find-class 'change-class-class-07)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class)) @@ -471,7 +471,7 @@ (deftest change-class.7.2 (let* ((class (find-class 'change-class-class-07)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class :a 10)) @@ -484,7 +484,7 @@ (deftest change-class.7.3 (let* ((class (find-class 'change-class-class-07)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b c)) (eqt obj (change-class obj class :b 10)) @@ -498,8 +498,8 @@ (deftest change-class.7.4 (let* ((class (find-class 'change-class-class-07)) - (new-class (find-class 'change-class-class-07b)) - (obj (allocate-instance class))) + (new-class (find-class 'change-class-class-07b)) + (obj (allocate-instance class))) (values (eqt obj (change-class obj new-class)) (map-slot-boundp* obj '(a d)) @@ -509,8 +509,8 @@ (deftest change-class.7.5 (let* ((class (find-class 'change-class-class-07)) - (new-class (find-class 'change-class-class-07b)) - (obj (allocate-instance class))) + (new-class (find-class 'change-class-class-07b)) + (obj (allocate-instance class))) (values (eqt obj (change-class obj new-class :allow-other-keys nil)) (map-slot-boundp* obj '(a d)) @@ -520,8 +520,8 @@ (deftest change-class.7.6 (let* ((class (find-class 'change-class-class-07)) - (new-class (find-class 'change-class-class-07b)) - (obj (allocate-instance class))) + (new-class (find-class 'change-class-class-07b)) + (obj (allocate-instance class))) (values (eqt obj (change-class obj new-class :allow-other-keys t)) (map-slot-boundp* obj '(a d)) @@ -547,7 +547,7 @@ (deftest change-class.8.1 (let* ((class (find-class 'change-class-class-08)) - (obj (make-instance class))) + (obj (make-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj class)) @@ -557,10 +557,10 @@ t (t nil) z) - + (deftest change-class.8.2 (let* ((class (find-class 'change-class-class-08)) - (obj (make-instance class :a 1 :b 2))) + (obj (make-instance class :a 1 :b 2))) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj class)) @@ -574,7 +574,7 @@ (deftest change-class.8.3 (let* ((class (find-class 'change-class-class-08)) - (obj (make-instance class))) + (obj (make-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj class :a 12 :b 17)) @@ -589,7 +589,7 @@ ;;; Put around method test here ;;; Put more inheritance tests here - + ;;; Error tests (deftest change-class.error.1 @@ -598,13 +598,13 @@ (deftest change-class.error.2 (signals-error (change-class (make-instance 'change-class-class-01a)) - program-error) + program-error) t) (deftest change-class.error.3 (signals-error (let ((obj (make-instance 'change-class-class-01a)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (change-class obj new-class :c2)) program-error) t) @@ -612,7 +612,7 @@ (deftest change-class.error.4 (signals-error (let ((obj (make-instance 'change-class-class-01a)) - (new-class (find-class 'change-class-class-01b))) + (new-class (find-class 'change-class-class-01b))) (change-class obj new-class '(nonsense) 'a)) program-error) t) @@ -624,26 +624,26 @@ (deftest change-class.error.5 (let ((built-in-class (find-class 'built-in-class))) (loop for e in *mini-universe* - for class = (class-of e) - when (and (eq (class-of class) built-in-class) - (handler-case - (progn - (change-class (make-instance 'change-class-class-01a) - class) - t) - (error () nil))) - collect e)) + for class = (class-of e) + when (and (eq (class-of class) built-in-class) + (handler-case + (progn + (change-class (make-instance 'change-class-class-01a) + class) + t) + (error () nil))) + collect e)) nil) (deftest change-class.error.6 (let ((built-in-class (find-class 'built-in-class))) (loop for e in *mini-universe* - for class = (class-of e) - when (and (eq (class-of class) built-in-class) - (handler-case - (progn - (change-class e (find-class 'change-class-class-01a)) - t) - (error () nil))) - collect e)) + for class = (class-of e) + when (and (eq (class-of class) built-in-class) + (handler-case + (progn + (change-class e (find-class 'change-class-class-01a)) + t) + (error () nil))) + collect e)) nil) diff --git a/ansi-tests/char-aux.lsp b/ansi-tests/char-aux.lsp index e2a421bb..ac7118b5 100644 --- a/ansi-tests/char-aux.lsp +++ b/ansi-tests/char-aux.lsp @@ -9,10 +9,10 @@ (declare (type function fn)) (let ((n (length seq))) (loop for i from 0 below (1- n) - for e = (elt seq i) - always - (loop for j from (1+ i) below n - always (funcall fn e (elt seq j)))))) + for e = (elt seq i) + always + (loop for j from (1+ i) below n + always (funcall fn e (elt seq j)))))) (defun is-antisymmetrically-ordered-by (seq fn) (declare (type function fn)) @@ -27,16 +27,16 @@ (locally (declare (type function fn)) (loop for c across +code-chars+ - for c1 = (char-upcase c) - for c2 = (if (eql c c1) (char-downcase c) c1) - always - (loop for d across +code-chars+ - for d1 = (char-upcase d) - for d2 = (if (eql d d1) (char-downcase d) d1) - always (equiv (funcall fn c d) - (funcall fn c2 d) - (funcall fn c d2) - (funcall fn c2 d2)))))) + for c1 = (char-upcase c) + for c2 = (if (eql c c1) (char-downcase c) c1) + always + (loop for d across +code-chars+ + for d1 = (char-upcase d) + for d2 = (if (eql d d1) (char-downcase d) d1) + always (equiv (funcall fn c d) + (funcall fn c2 d) + (funcall fn c d2) + (funcall fn c2 d2)))))) (defun equiv (&rest args) (declare (dynamic-extent args)) @@ -55,249 +55,249 @@ (locally (declare (type function fn)) (loop for x in *universe* - always (or (characterp x) - ;; FIXME -- catch the type error and check that datum - ;; is eql to x (and that datum is not in the expected type) - (eqt (catch-type-error (funcall fn x)) 'type-error))))) + always (or (characterp x) + ;; FIXME -- catch the type error and check that datum + ;; is eql to x (and that datum is not in the expected type) + (eqt (catch-type-error (funcall fn x)) 'type-error))))) (defun standard-char.5.body () (loop for i from 0 below (min 65536 char-code-limit) - always (let ((c (code-char i))) - (not (and (typep c 'standard-char) - (not (standard-char-p c))))))) + always (let ((c (code-char i))) + (not (and (typep c 'standard-char) + (not (standard-char-p c))))))) (defun extended-char.3.body () (loop for i from 0 below (min 65536 char-code-limit) - always (let ((c (code-char i))) - (not (and (typep c 'base-char) - (typep c 'extended-char) - ))))) + always (let ((c (code-char i))) + (not (and (typep c 'base-char) + (typep c 'extended-char) + ))))) (defun character.1.body () (loop for i from 0 below (min 65536 char-code-limit) - always (let ((c (code-char i))) - (or (null c) - (let ((s (string c))) - (and - (eqlt (character c) c) - (eqlt (character s) c) - (eqlt (character (make-symbol s)) c))))))) + always (let ((c (code-char i))) + (or (null c) + (let ((s (string c))) + (and + (eqlt (character c) c) + (eqlt (character s) c) + (eqlt (character (make-symbol s)) c))))))) (defun character.2.body () (loop for x in *universe* - when (not (or (characterp x) - (and (stringp x) (eqlt (length x) 1)) - (and (symbolp x) (eqlt (length (symbol-name x)) 1)) - (let ((c (catch-type-error (character x)))) - (or (eqlt c 'type-error) - (let ((s (catch-type-error (string x)))) - (and (stringp s) (eqlt (my-aref s 0) c))))))) - do (return x))) + when (not (or (characterp x) + (and (stringp x) (eqlt (length x) 1)) + (and (symbolp x) (eqlt (length (symbol-name x)) 1)) + (let ((c (catch-type-error (character x)))) + (or (eqlt c 'type-error) + (let ((s (catch-type-error (string x)))) + (and (stringp s) (eqlt (my-aref s 0) c))))))) + do (return x))) (defun characterp.2.body () (loop for i from 0 below (min 65536 char-code-limit) - always (let ((c (code-char i))) - (or (null c) (characterp c))))) + always (let ((c (code-char i))) + (or (null c) (characterp c))))) (defun characterp.3.body () (loop for x in *universe* - always (let ((p (characterp x)) - (q (typep x 'character))) - (if p (notnot q) (not q))))) + always (let ((p (characterp x)) + (q (typep x 'character))) + (if p (notnot q) (not q))))) (defun alphanumericp.4.body () (loop for x in *universe* - always (or (not (characterp x)) - (if (or (digit-char-p x) (alpha-char-p x)) - (alphanumericp x) - ;; The hyperspec has an example that claims alphanumeric == - ;; digit-char-p or alpha-char-p, but the text seems to suggest - ;; that there can be numeric characters for which digit-char-p - ;; returns NIL. Therefore, I've weakened the next line - ;; (not (alphanumericp x)) - t - )))) + always (or (not (characterp x)) + (if (or (digit-char-p x) (alpha-char-p x)) + (alphanumericp x) + ;; The hyperspec has an example that claims alphanumeric == + ;; digit-char-p or alpha-char-p, but the text seems to suggest + ;; that there can be numeric characters for which digit-char-p + ;; returns NIL. Therefore, I've weakened the next line + ;; (not (alphanumericp x)) + t + )))) (defun alphanumericp.5.body () (loop for i from 0 below (min 65536 char-code-limit) - for x = (code-char i) - always (or (not (characterp x)) - (if (or (digit-char-p x) (alpha-char-p x)) - (alphanumericp x) - ;; The hyperspec has an example that claims alphanumeric == - ;; digit-char-p or alpha-char-p, but the text seems to suggest - ;; that there can be numeric characters for which digit-char-p - ;; returns NIL. Therefore, I've weakened the next line - ;; (not (alphanumericp x)) - t - )))) + for x = (code-char i) + always (or (not (characterp x)) + (if (or (digit-char-p x) (alpha-char-p x)) + (alphanumericp x) + ;; The hyperspec has an example that claims alphanumeric == + ;; digit-char-p or alpha-char-p, but the text seems to suggest + ;; that there can be numeric characters for which digit-char-p + ;; returns NIL. Therefore, I've weakened the next line + ;; (not (alphanumericp x)) + t + )))) (defun digit-char.1.body.old () (loop for r from 2 to 36 always (loop for i from 0 to 36 - always (let* ((c (digit-char i r)) - (result - (if (>= i r) (null c) - (eqlt c (char +extended-digit-chars+ i))))) - (unless result - (format t "~A ~A ~A~%" r i c)) - result)))) + always (let* ((c (digit-char i r)) + (result + (if (>= i r) (null c) + (eqlt c (char +extended-digit-chars+ i))))) + (unless result + (format t "~A ~A ~A~%" r i c)) + result)))) (defun digit-char.1.body () (loop for r from 2 to 36 nconc (loop for i from 0 to 36 - for c = (digit-char i r) - unless (if (>= i r) (null c) - (eqlt c (char +extended-digit-chars+ i))) - collect (list r i c)))) + for c = (digit-char i r) + unless (if (>= i r) (null c) + (eqlt c (char +extended-digit-chars+ i))) + collect (list r i c)))) (defun digit-char-p.1.body () (loop for x in *universe* - always (not (and (characterp x) - (not (alphanumericp x)) - (digit-char-p x))))) + always (not (and (characterp x) + (not (alphanumericp x)) + (digit-char-p x))))) (defun digit-char-p.2.body () (loop for i from 0 below (min 65536 char-code-limit) - for x = (code-char i) - always (or (not x) - (not (and (not (alphanumericp x)) - (digit-char-p x)))))) + for x = (code-char i) + always (or (not x) + (not (and (not (alphanumericp x)) + (digit-char-p x)))))) (defun digit-char-p.3.body () (loop for r from 2 to 35 - always - (loop for i from r to 35 - for c = (char +extended-digit-chars+ i) - never (or (digit-char-p c r) - (digit-char-p (char-downcase c) r))))) + always + (loop for i from r to 35 + for c = (char +extended-digit-chars+ i) + never (or (digit-char-p c r) + (digit-char-p (char-downcase c) r))))) (defun digit-char-p.4.body () (loop for r from 2 to 35 - always - (loop for i from 0 below r - for c = (char +extended-digit-chars+ i) - always (and (eqlt (digit-char-p c r) i) - (eqlt (digit-char-p (char-downcase c) r) i))))) + always + (loop for i from 0 below r + for c = (char +extended-digit-chars+ i) + always (and (eqlt (digit-char-p c r) i) + (eqlt (digit-char-p (char-downcase c) r) i))))) (defun standard-char-p.2.body () (loop for x in *universe* - always (or (not (characterp x)) - (find x +standard-chars+) - (not (standard-char-p x))))) + always (or (not (characterp x)) + (find x +standard-chars+) + (not (standard-char-p x))))) (defun standard-char-p.2a.body () (loop for i from 0 below (min 65536 char-code-limit) - for x = (code-char i) - always (or (not (characterp x)) - (find x +standard-chars+) - (not (standard-char-p x))))) + for x = (code-char i) + always (or (not (characterp x)) + (find x +standard-chars+) + (not (standard-char-p x))))) (defun char-upcase.1.body () (loop for x in *universe* - always - (or (not (characterp x)) - (let ((u (char-upcase x))) - (and - (or (lower-case-p x) (eqlt u x)) - (eqlt u (char-upcase u))))))) + always + (or (not (characterp x)) + (let ((u (char-upcase x))) + (and + (or (lower-case-p x) (eqlt u x)) + (eqlt u (char-upcase u))))))) (defun char-upcase.2.body () (loop for i from 0 below (min 65536 char-code-limit) - for x = (code-char i) - always - (or (not x) - (let ((u (char-upcase x))) - (and - (or (lower-case-p x) (eqlt u x)) - (eqlt u (char-upcase u))))))) + for x = (code-char i) + always + (or (not x) + (let ((u (char-upcase x))) + (and + (or (lower-case-p x) (eqlt u x)) + (eqlt u (char-upcase u))))))) (defun char-downcase.1.body () (loop for x in *universe* - always - (or (not (characterp x)) - (let ((u (char-downcase x))) - (and - (or (upper-case-p x) (eqlt u x)) - (eqlt u (char-downcase u))))))) + always + (or (not (characterp x)) + (let ((u (char-downcase x))) + (and + (or (upper-case-p x) (eqlt u x)) + (eqlt u (char-downcase u))))))) (defun char-downcase.2.body () (loop for i from 0 below (min 65536 char-code-limit) - for x = (code-char i) - always - (or (not x) - (let ((u (char-downcase x))) - (and - (or (upper-case-p x) (eqlt u x)) - (eqlt u (char-downcase u))))))) + for x = (code-char i) + always + (or (not x) + (let ((u (char-downcase x))) + (and + (or (upper-case-p x) (eqlt u x)) + (eqlt u (char-downcase u))))))) (defun both-case-p.1.body () (loop for x in *universe* - always (or (not (characterp x)) - (if (both-case-p x) - (and (graphic-char-p x) - (or (upper-case-p x) - (lower-case-p x))) - (not (or (upper-case-p x) - (lower-case-p x))))))) + always (or (not (characterp x)) + (if (both-case-p x) + (and (graphic-char-p x) + (or (upper-case-p x) + (lower-case-p x))) + (not (or (upper-case-p x) + (lower-case-p x))))))) (defun both-case-p.2.body () (loop for i from 0 below (min 65536 char-code-limit) - for x = (code-char i) - always (or (not (characterp x)) - (if (both-case-p x) - (and (graphic-char-p x) - (or (upper-case-p x) - (lower-case-p x))) - (not (or (upper-case-p x) - (lower-case-p x))))))) + for x = (code-char i) + always (or (not (characterp x)) + (if (both-case-p x) + (and (graphic-char-p x) + (or (upper-case-p x) + (lower-case-p x))) + (not (or (upper-case-p x) + (lower-case-p x))))))) (defun char-code.2.body () (loop for i from 0 below (min 65536 char-code-limit) - for c = (code-char i) - always (or (not c) - (eqlt (char-code c) i)))) + for c = (code-char i) + always (or (not c) + (eqlt (char-code c) i)))) (defun char-int.2.fn () (declare (optimize (safety 3) (speed 1) (space 1))) (let ((c->i (make-hash-table :test #'equal)) - (i->c (make-hash-table :test #'eql))) + (i->c (make-hash-table :test #'eql))) (flet ((%insert - (c) - (or (not (characterp c)) - (let* ((i (char-int c)) - (j (gethash c c->i)) - (d (gethash i i->c))) - (and - (or (null j) (eqlt j i)) - (or (null d) (char= c d)) - (progn - (setf (gethash c c->i) i) - (setf (gethash i i->c) c) - t)))))) + (c) + (or (not (characterp c)) + (let* ((i (char-int c)) + (j (gethash c c->i)) + (d (gethash i i->c))) + (and + (or (null j) (eqlt j i)) + (or (null d) (char= c d)) + (progn + (setf (gethash c c->i) i) + (setf (gethash i i->c) c) + t)))))) (or (loop for i from 0 below (min (ash 1 16) char-code-limit) - unless (%insert (code-char i)) - collect i) + unless (%insert (code-char i)) + collect i) (loop for i = (random char-code-limit) - repeat 1000 - unless (%insert (code-char i)) - collect i) + repeat 1000 + unless (%insert (code-char i)) + collect i) (find-if-not #'%insert +standard-chars+) (find-if-not #'%insert *universe*))))) (defun char-name.1.fn () (declare (optimize (safety 3) (speed 1) (space 1))) (flet ((%check - (c) - (or (not (characterp c)) - (let ((name (char-name c))) - (or (null name) - (and (stringp name) - (eqlt c (name-char name)))))))) + (c) + (or (not (characterp c)) + (let ((name (char-name c))) + (or (null name) + (and (stringp name) + (eqlt c (name-char name)))))))) (and (loop for i from 0 below (min (ash 1 16) char-code-limit) - always (%check (code-char i))) + always (%check (code-char i))) (every #'%check +standard-chars+) (every #'%check *universe*) t))) @@ -305,17 +305,17 @@ (defun name-char.1.body () (declare (optimize (safety 3))) (loop for x in *universe* - for s = (catch-type-error (string x)) - always - (or (eqlt s 'type-error) - (let ((c (name-char x))) - (or (not c) - (characterp c) - ;; FIXME The rest of this wasn't reachable - #| - (let ((name (char-name c))) - (declare (type (or null string) name)) - (and name - (string-equal name s))) - |# - ))))) + for s = (catch-type-error (string x)) + always + (or (eqlt s 'type-error) + (let ((c (name-char x))) + (or (not c) + (characterp c) + ;; FIXME The rest of this wasn't reachable + #| + (let ((name (char-name c))) + (declare (type (or null string) name)) + (and name + (string-equal name s))) + |# + ))))) diff --git a/ansi-tests/char-compare.lsp b/ansi-tests/char-compare.lsp index 4c5f63e4..7799c680 100644 --- a/ansi-tests/char-compare.lsp +++ b/ansi-tests/char-compare.lsp @@ -9,9 +9,9 @@ ;;; safe-called with no arguments (deftest char-compare-no-args (loop for f in '(char= char/= char< char> char<= char>= - char-lessp char-greaterp char-equal - char-not-lessp char-not-greaterp char-not-equal) - collect (eval `(signals-error (funcall ',f) program-error))) + char-lessp char-greaterp char-equal + char-not-lessp char-not-greaterp char-not-equal) + collect (eval `(signals-error (funcall ',f) program-error))) (t t t t t t t t t t t t)) (deftest char=.1 @@ -20,7 +20,7 @@ (deftest char=.2 (loop for c across +code-chars+ - always (char= c c)) + always (char= c c)) t) (deftest char=.3 @@ -29,27 +29,27 @@ (deftest char=.4 (is-ordered-by +rev-code-chars+ - #'(lambda (c1 c2) (not (char= c1 c2)))) + #'(lambda (c1 c2) (not (char= c1 c2)))) t) (deftest char=.order.1 (let ((i 0)) (values (not (char= (progn (incf i) #\a))) i)) nil 1) - + (deftest char=.order.2 (let ((i 0) a b) (values (char= (progn (setf a (incf i)) #\a) - (progn (setf b (incf i)) #\b)) - i a b)) + (progn (setf b (incf i)) #\b)) + i a b)) nil 2 1 2) (deftest char=.order.3 (let ((i 0) a b c) (values (char= (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) @@ -61,7 +61,7 @@ (deftest char/=.2 (loop for c across +code-chars+ - never (char/= c c)) + never (char/= c c)) t) (deftest char/=.3 @@ -76,28 +76,28 @@ (let ((i 0)) (values (not (char/= (progn (incf i) #\a))) i)) nil 1) - + (deftest char/=.order.2 (let ((i 0) a b) (values (not (char/= (progn (setf a (incf i)) #\a) - (progn (setf b (incf i)) #\b))) - i a b)) + (progn (setf b (incf i)) #\b))) + i a b)) nil 2 1 2) (deftest char/=.order.3 (let ((i 0) a b c) (values (char/= (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\b)) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) ;;; - + (deftest char<=.1 (loop for c across +code-chars+ - always (char<= c c)) + always (char<= c c)) t) (deftest char<=.2 @@ -123,7 +123,7 @@ (deftest char<=.7 (notnot-mv (or (char<= #\9 #\A) (char<= #\Z #\0))) t) - + (deftest char<=.8 (notnot-mv (or (char<= #\9 #\a) (char<= #\z #\0))) t) @@ -132,20 +132,20 @@ (let ((i 0)) (values (not (char<= (progn (incf i) #\a))) i)) nil 1) - + (deftest char<=.order.2 (let ((i 0) a b) (values (not (char<= (progn (setf a (incf i)) #\a) - (progn (setf b (incf i)) #\b))) - i a b)) + (progn (setf b (incf i)) #\b))) + i a b)) nil 2 1 2) (deftest char<=.order.3 (let ((i 0) a b c) (values (char<= (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) @@ -153,7 +153,7 @@ (deftest char<.1 (loop for c across +code-chars+ - never (char< c c)) + never (char< c c)) t) (deftest char<.2 @@ -179,29 +179,29 @@ (deftest char<.7 (notnot-mv (or (char< #\9 #\A) (char< #\Z #\0))) t) - + (deftest char<.8 (notnot-mv (or (char< #\9 #\a) (char< #\z #\0))) t) - + (deftest char<.order.1 (let ((i 0)) (values (not (char< (progn (incf i) #\a))) i)) nil 1) - + (deftest char<.order.2 (let ((i 0) a b) (values (not (char< (progn (setf a (incf i)) #\a) - (progn (setf b (incf i)) #\b))) - i a b)) + (progn (setf b (incf i)) #\b))) + i a b)) nil 2 1 2) (deftest char<.order.3 (let ((i 0) a b c) (values (char< (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) @@ -209,8 +209,8 @@ (let ((i 0) a b c) (values (char< (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) @@ -218,7 +218,7 @@ (deftest char>=.1 (loop for c across +code-chars+ - always (char>= c c)) + always (char>= c c)) t) (deftest char>=.2 @@ -244,7 +244,7 @@ (deftest char>=.7 (notnot-mv (or (char>= #\A #\9) (char>= #\0 #\Z))) t) - + (deftest char>=.8 (notnot-mv (or (char>= #\a #\9) (char>= #\0 #\z))) t) @@ -253,20 +253,20 @@ (let ((i 0)) (values (not (char>= (progn (incf i) #\a))) i)) nil 1) - + (deftest char>=.order.2 (let ((i 0) a b) (values (not (char>= (progn (setf a (incf i)) #\b) - (progn (setf b (incf i)) #\a))) - i a b)) + (progn (setf b (incf i)) #\a))) + i a b)) nil 2 1 2) (deftest char>=.order.3 (let ((i 0) a b c) (values (char>= (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) @@ -274,8 +274,8 @@ (let ((i 0) a b c) (values (char>= (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) @@ -283,7 +283,7 @@ (deftest char>.1 (loop for c across +code-chars+ - never (char> c c)) + never (char> c c)) t) (deftest char>.2 @@ -309,7 +309,7 @@ (deftest char>.7 (notnot-mv (or (char> #\A #\9) (char> #\0 #\Z))) t) - + (deftest char>.8 (notnot-mv (or (char> #\a #\9) (char> #\0 #\z))) t) @@ -318,20 +318,20 @@ (let ((i 0)) (values (not (char> (progn (incf i) #\a))) i)) nil 1) - + (deftest char>.order.2 (let ((i 0) a b) (values (not (char> (progn (setf a (incf i)) #\b) - (progn (setf b (incf i)) #\a))) - i a b)) + (progn (setf b (incf i)) #\a))) + i a b)) nil 2 1 2) (deftest char>.order.3 (let ((i 0) a b c) (values (char> (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) @@ -339,8 +339,8 @@ (let ((i 0) a b c) (values (char> (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) @@ -348,48 +348,48 @@ (deftest char-equal.1 (is-ordered-by +code-chars+ - #'(lambda (c1 c2) - (or (char= (char-downcase c1) - (char-downcase c2)) - (not (char-equal c1 c2))))) + #'(lambda (c1 c2) + (or (char= (char-downcase c1) + (char-downcase c2)) + (not (char-equal c1 c2))))) t) (deftest char-equal.2 (loop for c across +code-chars+ - always (char-equal c c)) + always (char-equal c c)) t) (deftest char-equal.3 (loop for c across +code-chars+ - always (char-equal c)) + always (char-equal c)) t) (deftest char-equal.4 (is-ordered-by +rev-code-chars+ - #'(lambda (c1 c2) - (or (char= (char-downcase c1) - (char-downcase c2)) - (not (char-equal c1 c2))))) + #'(lambda (c1 c2) + (or (char= (char-downcase c1) + (char-downcase c2)) + (not (char-equal c1 c2))))) t) (deftest char-equal.order.1 (let ((i 0)) (values (not (char-equal (progn (incf i) #\a))) i)) nil 1) - + (deftest char-equal.order.2 (let ((i 0) a b) (values (char-equal (progn (setf a (incf i)) #\b) - (progn (setf b (incf i)) #\a)) - i a b)) + (progn (setf b (incf i)) #\a)) + i a b)) nil 2 1 2) (deftest char-equal.order.3 (let ((i 0) a b c) (values (char-equal (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) @@ -397,8 +397,8 @@ (let ((i 0) a b c) (values (char-equal (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) @@ -406,14 +406,14 @@ (deftest char-not-equal.1 (is-ordered-by +code-chars+ #'(lambda (c1 c2) - (or (char= (char-downcase c1) - (char-downcase c2)) - (char-not-equal c1 c2)))) + (or (char= (char-downcase c1) + (char-downcase c2)) + (char-not-equal c1 c2)))) t) (deftest char-not-equal.2 (loop for c across +code-chars+ - never (char-not-equal c c)) + never (char-not-equal c c)) t) (deftest char-not-equal.3 @@ -422,29 +422,29 @@ (deftest char-not-equal.4 (is-ordered-by +rev-code-chars+ #'(lambda (c1 c2) - (or (char= (char-downcase c1) - (char-downcase c2)) - (char-not-equal c1 c2)))) + (or (char= (char-downcase c1) + (char-downcase c2)) + (char-not-equal c1 c2)))) t) (deftest char-not-equal.order.1 (let ((i 0)) (values (not (char-not-equal (progn (incf i) #\a))) i)) nil 1) - + (deftest char-not-equal.order.2 (let ((i 0) a b) (values (not (char-not-equal (progn (setf a (incf i)) #\b) - (progn (setf b (incf i)) #\a))) - i a b)) + (progn (setf b (incf i)) #\a))) + i a b)) nil 2 1 2) (deftest char-not-equal.order.3 (let ((i 0) a b c) (values (char-not-equal (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\b)) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) @@ -452,8 +452,8 @@ (let ((i 0) a b c) (values (char-not-equal (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) @@ -461,7 +461,7 @@ (deftest char-not-greaterp.1 (loop for c across +code-chars+ - always (char-not-greaterp c c)) + always (char-not-greaterp c c)) t) (deftest char-not-greaterp.2 @@ -487,7 +487,7 @@ (deftest char-not-greaterp.7 (notnot-mv (or (char-not-greaterp #\9 #\A) (char-not-greaterp #\Z #\0))) t) - + (deftest char-not-greaterp.8 (notnot-mv (or (char-not-greaterp #\9 #\a) (char-not-greaterp #\z #\0))) t) @@ -496,20 +496,20 @@ (let ((i 0)) (values (not (char-not-greaterp (progn (incf i) #\a))) i)) nil 1) - + (deftest char-not-greaterp.order.2 (let ((i 0) a b) (values (not (char-not-greaterp (progn (setf a (incf i)) #\a) - (progn (setf b (incf i)) #\b))) - i a b)) + (progn (setf b (incf i)) #\b))) + i a b)) nil 2 1 2) (deftest char-not-greaterp.order.3 (let ((i 0) a b c) (values (char-not-greaterp (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) @@ -517,8 +517,8 @@ (let ((i 0) a b c) (values (char-not-greaterp (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\a)) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) @@ -526,7 +526,7 @@ (deftest char-lessp.1 (loop for c across +code-chars+ - never (char-lessp c c)) + never (char-lessp c c)) t) (deftest char-lessp.2 @@ -552,7 +552,7 @@ (deftest char-lessp.7 (notnot-mv (or (char-lessp #\9 #\A) (char-lessp #\Z #\0))) t) - + (deftest char-lessp.8 (notnot-mv (or (char-lessp #\9 #\a) (char-lessp #\z #\0))) t) @@ -561,20 +561,20 @@ (let ((i 0)) (values (not (char-lessp (progn (incf i) #\a))) i)) nil 1) - + (deftest char-lessp.order.2 (let ((i 0) a b) (values (not (char-lessp (progn (setf a (incf i)) #\a) - (progn (setf b (incf i)) #\b))) - i a b)) + (progn (setf b (incf i)) #\b))) + i a b)) nil 2 1 2) (deftest char-lessp.order.3 (let ((i 0) a b c) (values (char-lessp (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) @@ -582,8 +582,8 @@ (let ((i 0) a b c) (values (char-lessp (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\a)) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) @@ -591,7 +591,7 @@ (deftest char-not-lessp.1 (loop for c across +code-chars+ - always (char-not-lessp c c)) + always (char-not-lessp c c)) t) (deftest char-not-lessp.2 @@ -604,7 +604,7 @@ (deftest char-not-lessp.4 (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) - #'char-not-lessp) + #'char-not-lessp) t) (deftest char-not-lessp.5 @@ -618,7 +618,7 @@ (deftest char-not-lessp.7 (notnot-mv (or (char-not-lessp #\A #\9) (char-not-lessp #\0 #\Z))) t) - + (deftest char-not-lessp.8 (notnot-mv (or (char-not-lessp #\a #\9) (char-not-lessp #\0 #\z))) t) @@ -627,20 +627,20 @@ (let ((i 0)) (values (not (char-not-lessp (progn (incf i) #\a))) i)) nil 1) - + (deftest char-not-lessp.order.2 (let ((i 0) a b) (values (not (char-not-lessp (progn (setf a (incf i)) #\b) - (progn (setf b (incf i)) #\a))) - i a b)) + (progn (setf b (incf i)) #\a))) + i a b)) nil 2 1 2) (deftest char-not-lessp.order.3 (let ((i 0) a b c) (values (char-not-lessp (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) @@ -648,8 +648,8 @@ (let ((i 0) a b c) (values (char-not-lessp (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\b)) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) @@ -657,7 +657,7 @@ (deftest char-greaterp.1 (loop for c across +code-chars+ - never (char-greaterp c c)) + never (char-greaterp c c)) t) (deftest char-greaterp.2 @@ -670,7 +670,7 @@ (deftest char-greaterp.4 (is-antisymmetrically-ordered-by (reverse +lower-case-chars+) - #'char-greaterp) + #'char-greaterp) t) (deftest char-greaterp.5 @@ -684,7 +684,7 @@ (deftest char-greaterp.7 (notnot-mv (or (char-greaterp #\A #\9) (char-greaterp #\0 #\Z))) t) - + (deftest char-greaterp.8 (notnot-mv (or (char-greaterp #\a #\9) (char-greaterp #\0 #\z))) t) @@ -693,20 +693,20 @@ (let ((i 0)) (values (not (char-greaterp (progn (incf i) #\a))) i)) nil 1) - + (deftest char-greaterp.order.2 (let ((i 0) a b) (values (not (char-greaterp (progn (setf a (incf i)) #\b) - (progn (setf b (incf i)) #\a))) - i a b)) + (progn (setf b (incf i)) #\a))) + i a b)) nil 2 1 2) (deftest char-greaterp.order.3 (let ((i 0) a b c) (values (char-greaterp (progn (setq a (incf i)) #\b) - (progn (setq b (incf i)) #\a) - (progn (setq c (incf i)) #\b)) + (progn (setq b (incf i)) #\a) + (progn (setq c (incf i)) #\b)) i a b c)) nil 3 1 2 3) @@ -714,7 +714,7 @@ (let ((i 0) a b c) (values (char-greaterp (progn (setq a (incf i)) #\a) - (progn (setq b (incf i)) #\b) - (progn (setq c (incf i)) #\a)) + (progn (setq b (incf i)) #\b) + (progn (setq c (incf i)) #\a)) i a b c)) nil 3 1 2 3) diff --git a/ansi-tests/char-schar.lsp b/ansi-tests/char-schar.lsp index be10ed19..79f04ddf 100644 --- a/ansi-tests/char-schar.lsp +++ b/ansi-tests/char-schar.lsp @@ -12,9 +12,9 @@ (deftest char.2 (let ((s0 (copy-seq "abcd")) - (s1 (copy-seq "abcd")) - (s2 (copy-seq "abcd")) - (s3 (copy-seq "abcd"))) + (s1 (copy-seq "abcd")) + (s2 (copy-seq "abcd")) + (s3 (copy-seq "abcd"))) (setf (char s0 0) #\X) (setf (char s1 1) #\X) (setf (char s2 2) #\X) @@ -24,15 +24,15 @@ (deftest char.3 (let ((s (make-array 6 :element-type 'character - :initial-contents '(#\a #\b #\c #\d #\e #\f)))) + :initial-contents '(#\a #\b #\c #\d #\e #\f)))) (setf (char s 3) #\X) s) "abcXef") (deftest char.4 (let ((s (make-array 6 :element-type 'character - :initial-contents '(#\a #\b #\c #\d #\e #\f) - :fill-pointer 4))) + :initial-contents '(#\a #\b #\c #\d #\e #\f) + :fill-pointer 4))) (setf (char s 3) #\X) s) "abcX") @@ -57,8 +57,8 @@ (deftest char.8 (let ((s (make-array 6 :element-type 'character - :initial-contents '(#\a #\b #\c #\d #\e #\f) - :fill-pointer 4))) + :initial-contents '(#\a #\b #\c #\d #\e #\f) + :fill-pointer 4))) (setf (char s 5) #\X) (setf (fill-pointer s) 6) s) @@ -66,14 +66,14 @@ (deftest char.9 (let ((s (make-string 5 :initial-element #\a - :element-type 'base-char))) + :element-type 'base-char))) (setf (char s 3) #\X) s) "aaaXa") (deftest char.10 (let ((s (make-string 5 :initial-element #\a - :element-type 'standard-char))) + :element-type 'standard-char))) (setf (char s 3) #\X) s) "aaaXa") @@ -82,7 +82,7 @@ (let ((i 0) a b) (values (char (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) 1)) + (progn (setf b (incf i)) 1)) i a b)) #\b 2 1 2) @@ -91,7 +91,7 @@ (values (setf (char (progn (setf a (incf i)) s) - (progn (setf b (incf i)) 1)) + (progn (setf b (incf i)) 1)) (progn (setf c (incf i)) #\a)) s i a b c)) #\a "zazzz" 3 1 2 3) @@ -118,9 +118,9 @@ (deftest schar.2 (let ((s0 (copy-seq "abcd")) - (s1 (copy-seq "abcd")) - (s2 (copy-seq "abcd")) - (s3 (copy-seq "abcd"))) + (s1 (copy-seq "abcd")) + (s2 (copy-seq "abcd")) + (s3 (copy-seq "abcd"))) (setf (schar s0 0) #\X) (setf (schar s1 1) #\X) (setf (schar s2 2) #\X) @@ -154,7 +154,7 @@ (deftest schar.7 (let ((s (make-string 6 :initial-element #\x - :element-type 'standard-char))) + :element-type 'standard-char))) (setf (schar s 2) #\X) s) "xxXxxx") @@ -163,7 +163,7 @@ (let ((i 0) a b) (values (schar (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) 1)) + (progn (setf b (incf i)) 1)) i a b)) #\b 2 1 2) @@ -172,7 +172,7 @@ (values (setf (schar (progn (setf a (incf i)) s) - (progn (setf b (incf i)) 1)) + (progn (setf b (incf i)) 1)) (progn (setf c (incf i)) #\a)) s i a b c)) #\a "zazzz" 3 1 2 3) diff --git a/ansi-tests/character.lsp b/ansi-tests/character.lsp index 84bafe32..acf2b6b6 100644 --- a/ansi-tests/character.lsp +++ b/ansi-tests/character.lsp @@ -53,7 +53,7 @@ (extended-char.3.body) t) -;;; +;;; (deftest character.1 (character.1.body) @@ -110,9 +110,9 @@ (deftest alpha-char-p.1 (loop for c across +standard-chars+ - always - (or (find c +alpha-chars+) - (not (alpha-char-p c)))) + always + (or (find c +alpha-chars+) + (not (alpha-char-p c)))) t) ;;; @@ -148,9 +148,9 @@ (deftest alphanumericp.1 (loop for c across +standard-chars+ - always - (or (find c +alphanumeric-chars+) - (not (alphanumericp c)))) + always + (or (find c +alphanumeric-chars+) + (not (alphanumericp c)))) t) (deftest alphanumericp.2 @@ -232,7 +232,7 @@ (deftest digit-char-p.2 (digit-char-p.2.body) t) - + (deftest digit-char-p.3 (digit-char-p.3.body) t) @@ -243,15 +243,15 @@ (deftest digit-char-p.5 (loop for i from 10 to 35 - for c = (char +extended-digit-chars+ i) - never (or (digit-char-p c) - (digit-char-p (char-downcase c)))) + for c = (char +extended-digit-chars+ i) + never (or (digit-char-p c) + (digit-char-p (char-downcase c)))) t) (deftest digit-char-p.6 (loop for i from 0 below 10 - for c = (char +extended-digit-chars+ i) - always (eqlt (digit-char-p c) i)) + for c = (char +extended-digit-chars+ i) + always (eqlt (digit-char-p c) i)) t) (deftest digit-char-p.order.1 @@ -265,14 +265,14 @@ (let ((i 0) x y) (values (digit-char-p (progn (setf x (incf i)) #\0) - (progn (setf y (incf i)) 10)) + (progn (setf y (incf i)) 10)) i x y)) 0 2 1 2) (deftest digit-char-p.error.1 (signals-error (digit-char-p) program-error) t) - + (deftest digit-char-p.error.2 (signals-error (digit-char-p #\1 10 'foo) program-error) t) @@ -281,9 +281,9 @@ (deftest graphic-char-p.1 (loop for c across +standard-chars+ - always (if (eqlt c #\Newline) - (not (graphic-char-p c)) - (graphic-char-p c))) + always (if (eqlt c #\Newline) + (not (graphic-char-p c)) + (graphic-char-p c))) t) (deftest graphic-char-p.2 @@ -340,7 +340,7 @@ (deftest standard-char-p.error.1 (signals-error (standard-char-p) program-error) t) - + (deftest standard-char-p.error.2 (signals-error (standard-char-p #\a #\a) program-error) t) @@ -535,7 +535,7 @@ (deftest code-char.1 (loop for x across +standard-chars+ - always (eqlt (code-char (char-code x)) x)) + always (eqlt (code-char (char-code x)) x)) t) (deftest code-char.order.1 @@ -557,7 +557,7 @@ (deftest char-int.1 (loop for x across +standard-chars+ - always (eqlt (char-int x) (char-code x))) + always (eqlt (char-int x) (char-code x))) t) (deftest char-int.2 @@ -597,18 +597,18 @@ ;;; appropriate. This is complicated by the possibility that two different ;;; names may refer to the same character (as is allowed by the standard, ;;; for example in the case of Newline and Linefeed). - + (deftest char-name.4 (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed") - for c = (name-char s) - unless (or (not c) - ;; If the char-name is not even string-equal, - ;; assume we're sharing the character with some other - ;; name, and assume it's ok - (not (string-equal (char-name c) s)) - (string= (char-name c) s)) - ;; Collect list of cases that failed - collect (list s c (char-name c))) + for c = (name-char s) + unless (or (not c) + ;; If the char-name is not even string-equal, + ;; assume we're sharing the character with some other + ;; name, and assume it's ok + (not (string-equal (char-name c) s)) + (string= (char-name c) s)) + ;; Collect list of cases that failed + collect (list s c (char-name c))) nil) (deftest char-name.5 diff --git a/ansi-tests/check-type.lsp b/ansi-tests/check-type.lsp index 02feec94..66cbb323 100644 --- a/ansi-tests/check-type.lsp +++ b/ansi-tests/check-type.lsp @@ -18,10 +18,10 @@ (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) - (assert (eql (type-error-datum c) x)) - (assert (not (typep x (type-error-expected-type c)))) - ;; Can we assume the expected-type is NUMBER? - (store-value 15 c)))) + (assert (eql (type-error-datum c) x)) + (assert (not (typep x (type-error-expected-type c)))) + ;; Can we assume the expected-type is NUMBER? + (store-value 15 c)))) (values (check-type x number) x))) nil 15) @@ -34,10 +34,10 @@ (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) - (assert (eql (type-error-datum c) x)) - (assert (not (typep x (type-error-expected-type c)))) - ;; Can we assume the expected-type is STRING? - (store-value "abc" c)))) + (assert (eql (type-error-datum c) x)) + (assert (not (typep x (type-error-expected-type c)))) + ;; Can we assume the expected-type is STRING? + (store-value "abc" c)))) (values (check-type x string "a string") x))) nil "abc") @@ -45,10 +45,10 @@ (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) - (assert (eql (type-error-datum c) x)) - (assert (not (typep x (type-error-expected-type c)))) - ;; Can we assume the expected-type is NUMBER? - (store-value 15 nil)))) + (assert (eql (type-error-datum c) x)) + (assert (not (typep x (type-error-expected-type c)))) + ;; Can we assume the expected-type is NUMBER? + (store-value 15 nil)))) (values (check-type x number) x))) nil 15) @@ -56,10 +56,10 @@ (let ((x 'a)) (handler-bind ((type-error #'(lambda (c) - (assert (eql (type-error-datum c) x)) - (assert (not (typep x (type-error-expected-type c)))) - ;; Can we assume the expected-type is NUMBER? - (store-value 15)))) + (assert (eql (type-error-datum c) x)) + (assert (not (typep x (type-error-expected-type c)))) + ;; Can we assume the expected-type is NUMBER? + (store-value 15)))) (values (check-type x number) x))) nil 15) @@ -71,7 +71,7 @@ (macrolet ((%m (z) z)) (check-type (expand-in-current-env (%m x)) - (integer 8 13)))) + (integer 8 13)))) nil) (deftest check-type.9 diff --git a/ansi-tests/cis.lsp b/ansi-tests/cis.lsp index 753d860d..456edea2 100644 --- a/ansi-tests/cis.lsp +++ b/ansi-tests/cis.lsp @@ -18,34 +18,34 @@ (deftest cis.1 (let ((result (cis 0))) (or (=t result 1) - (eqlt #c(1.0 0.0)))) + (eqlt #c(1.0 0.0)))) t) (deftest cis.2 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - for vals = (multiple-value-list (cis x)) - for c = (car vals) - unless (and (= (length vals) 1) - (eql c (complex (float 1 x) x))) - collect (cons x vals)) + for vals = (multiple-value-list (cis x)) + for c = (car vals) + unless (and (= (length vals) 1) + (eql c (complex (float 1 x) x))) + collect (cons x vals)) nil) (deftest cis.3 (loop for x = (random (* 2 pi)) - for c = (cis x) - repeat 1000 - unless (and (complexp c) - (approx= (imagpart c) (sin x)) - (approx= (realpart c) (cos x))) - collect (list x c (cos x) (sin x))) + for c = (cis x) + repeat 1000 + unless (and (complexp c) + (approx= (imagpart c) (sin x)) + (approx= (realpart c) (cos x))) + collect (list x c (cos x) (sin x))) nil) (deftest cis.4 (loop for x = (random (coerce (* 2 pi) 'single-float)) - for c = (cis x) - repeat 1000 - unless (and (complexp c) - (approx= (imagpart c) (sin x)) - (approx= (realpart c) (cos x))) - collect (list x c (cos x) (sin x))) + for c = (cis x) + repeat 1000 + unless (and (complexp c) + (approx= (imagpart c) (sin x)) + (approx= (realpart c) (cos x))) + collect (list x c (cos x) (sin x))) nil) diff --git a/ansi-tests/cl-symbol-names.lsp b/ansi-tests/cl-symbol-names.lsp index 24993fcf..74370ca0 100644 --- a/ansi-tests/cl-symbol-names.lsp +++ b/ansi-tests/cl-symbol-names.lsp @@ -997,7 +997,7 @@ (#-clisp progn #+clisp ext:without-package-lock #+clisp ("COMMON-LISP") (mapcar #'(lambda (str) (intern str pkg)) - *cl-symbol-names*)))) + *cl-symbol-names*)))) (defparameter *cl-symbols-vector* (make-array (length *cl-symbols*) :initial-contents *cl-symbols*)) @@ -2144,22 +2144,22 @@ (defparameter *cl-all-type-symbols* (reduce #'union - (list *cl-type-symbols* *cl-types-that-are-classes-symbols* - *cl-system-class-symbols* *cl-class-symbols* - *cl-condition-type-symbols*))) + (list *cl-type-symbols* *cl-types-that-are-classes-symbols* + *cl-system-class-symbols* *cl-class-symbols* + *cl-condition-type-symbols*))) (defparameter *cl-non-function-macro-special-operator-symbols* (set-difference *cl-symbols* (reduce #'union - (list *cl-function-symbols* - *cl-macro-symbols* - *cl-accessor-symbols* - *cl-local-function-symbols* - *cl-local-macro-symbols* - *cl-special-operator-symbols* - *cl-standard-generic-function-symbols* - '(declare ed))))) + (list *cl-function-symbols* + *cl-macro-symbols* + *cl-accessor-symbols* + *cl-local-function-symbols* + *cl-local-macro-symbols* + *cl-special-operator-symbols* + *cl-standard-generic-function-symbols* + '(declare ed))))) (defparameter *cl-function-or-accessor-symbols* (append *cl-function-symbols* *cl-accessor-symbols*)) @@ -2168,4 +2168,4 @@ (set-difference *cl-symbols* (union *cl-variable-symbols* - *cl-constant-symbols*))) + *cl-constant-symbols*))) diff --git a/ansi-tests/cl-symbols-aux.lsp b/ansi-tests/cl-symbols-aux.lsp index 9436189e..0e88f776 100644 --- a/ansi-tests/cl-symbols-aux.lsp +++ b/ansi-tests/cl-symbols-aux.lsp @@ -11,7 +11,7 @@ (multiple-value-bind (sym2 status) (find-symbol (symbol-name sym) package) (and (eqt sym sym2) - (eqt status :external)))) + (eqt status :external)))) (defun test-if-not-in-cl-package (str) (multiple-value-bind (sym status) @@ -23,17 +23,17 @@ ;; external in any of the standard packages or are accessible ;; in CL-USER (let ((plist (symbol-plist sym))) - (loop for e = plist then (cddr e) - for indicator = (car e) - while e - when (and (symbolp indicator) - (or (is-external-symbol-of indicator - "COMMON-LISP") - (is-external-symbol-of indicator "KEYWORD") - (eqt indicator (find-symbol - (symbol-name indicator) - "COMMON-LISP-USER")))) - collect indicator))))) + (loop for e = plist then (cddr e) + for indicator = (car e) + while e + when (and (symbolp indicator) + (or (is-external-symbol-of indicator + "COMMON-LISP") + (is-external-symbol-of indicator "KEYWORD") + (eqt indicator (find-symbol + (symbol-name indicator) + "COMMON-LISP-USER")))) + collect indicator))))) (defun safe-symbol-name (sym) (catch-type-error (symbol-name sym))) diff --git a/ansi-tests/cl-symbols.lsp b/ansi-tests/cl-symbols.lsp index 95034a5c..e5bc0098 100644 --- a/ansi-tests/cl-symbols.lsp +++ b/ansi-tests/cl-symbols.lsp @@ -1016,8 +1016,8 @@ (loop for n in *cl-symbol-names* do (setf (gethash n ht) t)) (let ((extras nil)) (do-external-symbols (s "CL") - (unless (gethash (symbol-name s) ht) - (push s extras))) + (unless (gethash (symbol-name s) ht) + (push s extras))) extras)) nil) @@ -1029,18 +1029,18 @@ (deftest keyword-behavior (let ((result nil) - (keyword-package (find-package "KEYWORD"))) + (keyword-package (find-package "KEYWORD"))) (do-symbols (s keyword-package result) (multiple-value-bind (sym status) - (find-symbol (symbol-name s) keyword-package) - (cond - ((not (eqt s sym)) (push (list s sym) result)) - ((eqt status :internal) - (push (list s status) result)) - ((eqt status :external) - (unless (and (eqt (symbol-value s) s) - (constantp s)) - (push (list s sym 'not-constant) result))))))) + (find-symbol (symbol-name s) keyword-package) + (cond + ((not (eqt s sym)) (push (list s sym) result)) + ((eqt status :internal) + (push (list s status) result)) + ((eqt status :external) + (unless (and (eqt (symbol-value s) s) + (constantp s)) + (push (list s sym 'not-constant) result))))))) nil) ;;;;;;;;;;;;;;;;;;;; @@ -1054,9 +1054,9 @@ (loop for s in (append *cl-function-symbols* *cl-accessor-symbols*) when (or (not (fboundp s)) - (macro-function s) - (special-operator-p s) - (not (symbol-function s))) + (macro-function s) + (special-operator-p s) + (not (symbol-function s))) collect s) nil) @@ -1066,7 +1066,7 @@ (loop for s in *cl-macro-symbols* when (or (not (fboundp s)) - (not (macro-function s))) + (not (macro-function s))) collect s) nil) @@ -1076,7 +1076,7 @@ (loop for s in *cl-constant-symbols* when (or (not (boundp s)) - (not (constantp s))) + (not (constantp s))) collect s) nil) @@ -1088,7 +1088,7 @@ when (not (boundp s)) collect s) nil) - + ;;; Check that all types that are classes name classes. ;;; "Many but not all of the predefined type specifiers have @@ -1102,8 +1102,8 @@ for s in *cl-types-that-are-classes-symbols* for c = (find-class s nil) unless (and c - (eq (class-name c) s) - (typep c 'class)) + (eq (class-name c) s) + (typep c 'class)) collect s) nil) @@ -1115,8 +1115,8 @@ for s in *cl-types-that-are-classes-symbols* for c = (find-class s nil nil) unless (and c - (eq (class-name c) s) - (typep c 'class)) + (eq (class-name c) s) + (typep c 'class)) collect s) nil) @@ -1126,12 +1126,12 @@ (loop for s in *cl-types-that-are-classes-symbols* for c = (eval `(macrolet ((%foo (&environment env) - (list 'quote - (find-class ',s nil env)))) - (%foo))) + (list 'quote + (find-class ',s nil env)))) + (%foo))) unless (and c - (eq (class-name c) s) - (typep c 'class)) + (eq (class-name c) s) + (typep c 'class)) collect s) nil) @@ -1164,7 +1164,7 @@ (deftest symbol-plist.error.4 (check-type-error #'(lambda (x) (setf (symbol-plist x) nil)) - #'symbolp) + #'symbolp) nil) @@ -1189,7 +1189,7 @@ (let ((sym (gensym))) (declare (optimize safety)) (handler-case (progn (symbol-value sym) :bad) - (unbound-variable (c) - (assert (eq (cell-error-name c) sym)) - :good))) + (unbound-variable (c) + (assert (eq (cell-error-name c) sym)) + :good))) :good) diff --git a/ansi-tests/cl-test-package.lsp b/ansi-tests/cl-test-package.lsp index f1d50b88..c0b14878 100644 --- a/ansi-tests/cl-test-package.lsp +++ b/ansi-tests/cl-test-package.lsp @@ -9,13 +9,13 @@ (let ((*package* pkg)) (shadow '(#:handler-case #:handler-bind)) (import '(common-lisp-user::compile-and-load) - pkg) + pkg) (export (mapcar #'intern - (mapcar #'symbol-name - '(#:random-from-seq #:random-case #:coin - #:random-permute #:*universe* #:*mini-universe* - #:*cl-symbols* - #:signals-error #:typef))))) + (mapcar #'symbol-name + '(#:random-from-seq #:random-case #:coin + #:random-permute #:*universe* #:*mini-universe* + #:*cl-symbols* + #:signals-error #:typef))))) (let ((s (find-symbol "QUIT" "CL-USER"))) (when s (import s :cl-test)))) diff --git a/ansi-tests/class-name.lsp b/ansi-tests/class-name.lsp index b590ac0a..a109cce7 100644 --- a/ansi-tests/class-name.lsp +++ b/ansi-tests/class-name.lsp @@ -28,17 +28,17 @@ (deftest setf-class-name.2 (let ((sym (gensym)) - (newsym (gensym))) + (newsym (gensym))) (eval `(defclass ,sym () (a b c))) (let ((class (find-class sym))) (values (eqlt (class-name class) sym) (equalt - (multiple-value-list (setf (class-name (find-class sym)) newsym)) - (list newsym)) + (multiple-value-list (setf (class-name (find-class sym)) newsym)) + (list newsym)) (eqlt newsym (class-name class))))) t t t) - + ;;; Error tests @@ -48,5 +48,5 @@ (deftest class-name.error.2 (signals-error (class-name (find-class 'symbol) nil) - program-error) + program-error) t) diff --git a/ansi-tests/clear-input.lsp b/ansi-tests/clear-input.lsp index 73c12f81..7c507969 100644 --- a/ansi-tests/clear-input.lsp +++ b/ansi-tests/clear-input.lsp @@ -10,8 +10,8 @@ (deftest clear-input.1 (loop for s in (list *debug-io* *query-io* - *standard-input* *terminal-io*) - always (eq (clear-input s) nil)) + *standard-input* *terminal-io*) + always (eq (clear-input s) nil)) t) (deftest clear-input.2 diff --git a/ansi-tests/clear-output.lsp b/ansi-tests/clear-output.lsp index 03f0ae80..ca4396e1 100644 --- a/ansi-tests/clear-output.lsp +++ b/ansi-tests/clear-output.lsp @@ -19,17 +19,17 @@ (deftest clear-output.4 (loop for s in (list *debug-io* *error-output* *query-io* - *standard-output* *trace-output* *terminal-io*) - for dummy = (finish-output s) - for results = (multiple-value-list (clear-output s)) - unless (equal results '(nil)) - collect s) + *standard-output* *trace-output* *terminal-io*) + for dummy = (finish-output s) + for results = (multiple-value-list (clear-output s)) + unless (equal results '(nil)) + collect s) nil) (deftest clear-output.5 (let ((os (make-string-output-stream))) (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "") - os))) + os))) (clear-output t))) nil) diff --git a/ansi-tests/clrhash.lsp b/ansi-tests/clrhash.lsp index 2da117c9..75e77813 100644 --- a/ansi-tests/clrhash.lsp +++ b/ansi-tests/clrhash.lsp @@ -11,7 +11,7 @@ (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) - (list table)) + (list table)) (hash-table-count table))) 1 t 0) @@ -21,7 +21,7 @@ (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) - (list table)) + (list table)) (hash-table-count table))) 1 t 0) @@ -31,7 +31,7 @@ (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) - (list table)) + (list table)) (hash-table-count table))) 1 t 0) @@ -41,7 +41,7 @@ (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) - (list table)) + (list table)) (hash-table-count table))) 1 t 0) @@ -51,7 +51,7 @@ (values (hash-table-count table) (equalt (multiple-value-list (clrhash table)) - (list table)) + (list table)) (hash-table-count table))) 1 t 0) @@ -63,7 +63,7 @@ (deftest clrhash.error.2 (signals-error (clrhash (make-hash-table) nil) - program-error) + program-error) t) diff --git a/ansi-tests/coerce.lsp b/ansi-tests/coerce.lsp index ea4c7989..2cfa58f5 100644 --- a/ansi-tests/coerce.lsp +++ b/ansi-tests/coerce.lsp @@ -7,9 +7,9 @@ (deftest coerce.1 (check-predicate #'(lambda (x) - (let ((type (type-of x))) - (or (and (consp type) (eqt (car type) 'function)) - (eql (coerce x type) x))))) + (let ((type (type-of x))) + (or (and (consp type) (eqt (car type) 'function)) + (eql (coerce x type) x))))) nil) (deftest coerce.2 @@ -20,85 +20,85 @@ (check-predicate #'(lambda (x) (let ((class (class-of x))) - (eql (coerce x class) x)))) + (eql (coerce x class) x)))) nil) (deftest coerce.4 (loop for x in '(() #() #*) - never (coerce x 'list)) + never (coerce x 'list)) t) (deftest coerce.5 (loop for x in '((1 0) #(1 0) #*10) - always (equal (coerce x 'list) '(1 0))) + always (equal (coerce x 'list) '(1 0))) t) (deftest coerce.6 (loop for x in '(() #() #*) - always (equalp (coerce x 'vector) #())) + always (equalp (coerce x 'vector) #())) t) (deftest coerce.7 (loop for x in '((1 0) #(1 0) #*10) - for y = (coerce x 'vector) - always (and (equalp y #(1 0)) - (vectorp y))) + for y = (coerce x 'vector) + always (and (equalp y #(1 0)) + (vectorp y))) t) (deftest coerce.8 (loop for x in '((1 0) #(1 0) #*10) - for y = (coerce x '(vector *)) - always (and (equalp y #(1 0)) - (vectorp y))) + for y = (coerce x '(vector *)) + always (and (equalp y #(1 0)) + (vectorp y))) t) (deftest coerce.9 (loop for x in '((1 0) #(1 0) #*10) - for y = (coerce x '(vector * 2)) - always (and (equalp y #(1 0)) - (vectorp y))) + for y = (coerce x '(vector * 2)) + always (and (equalp y #(1 0)) + (vectorp y))) t) (deftest coerce.10 (values (coerce #\A 'character) - (coerce '|A| 'character) - (coerce "A" 'character)) + (coerce '|A| 'character) + (coerce "A" 'character)) #\A #\A #\A) (deftest coerce.11 (loop with class = (find-class 'vector) - for x in '((1 0) #(1 0) #*10) - for y = (coerce x class) - always (and (equalp y #(1 0)) - (vectorp y))) + for x in '((1 0) #(1 0) #*10) + for y = (coerce x class) + always (and (equalp y #(1 0)) + (vectorp y))) t) (deftest coerce.12 (loop for x in '((1 0) #(1 0) #*10) - for y = (coerce x 'bit-vector) - always (and (equalp y #*10) - (bit-vector-p y))) + for y = (coerce x 'bit-vector) + always (and (equalp y #*10) + (bit-vector-p y))) t) (deftest coerce.13 (loop for x in '((#\a #\b #\c) "abc") - for y = (coerce x 'string) - always (and (stringp y) - (string= y "abc"))) + for y = (coerce x 'string) + always (and (stringp y) + (string= y "abc"))) t) (deftest coerce.14 (loop for x in '((#\a #\b #\c) "abc") - for y = (coerce x 'simple-string) - always (and (typep y 'simple-string) - (string= y "abc"))) + for y = (coerce x 'simple-string) + always (and (typep y 'simple-string) + (string= y "abc"))) t) (deftest coerce.15 (loop for x in '((1 0) #(1 0) #*10) - for y = (coerce x 'simple-vector) - always (and (equalp y #(1 0)) - (simple-vector-p y))) + for y = (coerce x 'simple-vector) + always (and (equalp y #(1 0)) + (simple-vector-p y))) t) (deftest coerce.16 @@ -134,7 +134,7 @@ (let ((i 0) a b) (values (coerce (progn (setf a (incf i)) 10) - (progn (setf b (incf i)) 'single-float)) + (progn (setf b (incf i)) 'single-float)) i a b)) 10.0f0 2 1 2) @@ -189,19 +189,19 @@ (deftest coerce.error.10 :notes (:result-type-element-type-by-subtype) (let* ((tp1 '(vector character)) - (tp2 `(vector t)) - (tp3 `(or ,tp1 ,tp2))) + (tp2 `(vector t)) + (tp3 `(or ,tp1 ,tp2))) (if (not (subtypep tp3 'vector)) - t + t (handler-case (eval `(coerce '(#\a #\b #\c) ',tp3)) (type-error (c) - (cond - ((typep (type-error-datum c) - (type-error-expected-type c)) - `((typep ',(type-error-datum c) - ',(type-error-expected-type c)) - "==>" true)) - (t t))) + (cond + ((typep (type-error-datum c) + (type-error-expected-type c)) + `((typep ',(type-error-datum c) + ',(type-error-expected-type c)) + "==>" true)) + (t t))) (error (c) (declare (ignore c)) t)))) t) diff --git a/ansi-tests/compile-and-load.lsp b/ansi-tests/compile-and-load.lsp index 39e4effb..838e859a 100644 --- a/ansi-tests/compile-and-load.lsp +++ b/ansi-tests/compile-and-load.lsp @@ -23,25 +23,25 @@ "Find the file indicated by PATHSPEC, compiling it first if the associated compiled file is out of date." (let* ((pathname (pathname pathspec)) - (pathname (if *load-pathname* - (merge-pathnames pathname *load-pathname*) - pathname)) - (former-data (assoc pathname *compiled-and-loaded-files* - :test #'equalp)) - (compile-pathname (compile-file-pathname pathname)) - (source-write-time (file-write-date pathname)) - (target-write-time (and (probe-file compile-pathname) - (file-write-date compile-pathname)))) + (pathname (if *load-pathname* + (merge-pathnames pathname *load-pathname*) + pathname)) + (former-data (assoc pathname *compiled-and-loaded-files* + :test #'equalp)) + (compile-pathname (compile-file-pathname pathname)) + (source-write-time (file-write-date pathname)) + (target-write-time (and (probe-file compile-pathname) + (file-write-date compile-pathname)))) (unless (and (not force) - former-data - (>= (cadr former-data) source-write-time)) + former-data + (>= (cadr former-data) source-write-time)) (when (or (not target-write-time) - (<= target-write-time source-write-time)) - (handler-bind - #-sbcl () - #+sbcl ((sb-ext:code-deletion-note #'muffle-warning)) - (compile-file pathname))) + (<= target-write-time source-write-time)) + (handler-bind + #-sbcl () + #+sbcl ((sb-ext:code-deletion-note #'muffle-warning)) + (compile-file pathname))) (if former-data - (setf (cadr former-data) source-write-time) - (push (list pathname source-write-time) *compiled-and-loaded-files*)) + (setf (cadr former-data) source-write-time) + (push (list pathname source-write-time) *compiled-and-loaded-files*)) (load compile-pathname)))) diff --git a/ansi-tests/compile-file.lsp b/ansi-tests/compile-file.lsp index 1d2d7443..855ef273 100644 --- a/ansi-tests/compile-file.lsp +++ b/ansi-tests/compile-file.lsp @@ -6,62 +6,62 @@ (in-package :cl-test) (defun compile-file-test (file funname &rest args &key - expect-warnings - expect-style-warnings output-file - (print nil print-p) - (verbose nil verbose-p) - (*compile-print* nil) - (*compile-verbose* nil) - external-format) + expect-warnings + expect-style-warnings output-file + (print nil print-p) + (verbose nil verbose-p) + (*compile-print* nil) + (*compile-verbose* nil) + external-format) (declare (ignorable external-format)) (let* ((target-pathname (or output-file - (compile-file-pathname file))) - (actual-warnings-p nil) - (actual-style-warnings-p nil)) + (compile-file-pathname file))) + (actual-warnings-p nil) + (actual-style-warnings-p nil)) (when (probe-file target-pathname) (delete-file target-pathname)) (fmakunbound funname) (let* ((str (make-array '(0) :element-type 'character :adjustable t :fill-pointer 0)) - (vals (multiple-value-list - (handler-bind - ((style-warning #'(lambda (c) - (declare (ignore c)) - (setf actual-style-warnings-p t) - nil)) - ((or error warning) - #'(lambda (c) - (unless (typep c 'style-warning) - (setf actual-warnings-p t)) - nil))) - (with-output-to-string - (*standard-output* str) - (apply #'compile-file file :allow-other-keys t args)))))) + (vals (multiple-value-list + (handler-bind + ((style-warning #'(lambda (c) + (declare (ignore c)) + (setf actual-style-warnings-p t) + nil)) + ((or error warning) + #'(lambda (c) + (unless (typep c 'style-warning) + (setf actual-warnings-p t)) + nil))) + (with-output-to-string + (*standard-output* str) + (apply #'compile-file file :allow-other-keys t args)))))) (assert (= (length vals) 3)) (destructuring-bind - (output-truename warnings-p failure-p) - vals - (print (namestring (truename target-pathname))) - (print (namestring output-truename)) - (values - (let ((v1 (or print verbose - (and (not print-p) *compile-print*) - (and (not verbose-p) *compile-verbose*) - (string= str ""))) - (v2 (or (and verbose-p (not verbose)) - (and (not verbose-p) (not *compile-verbose*)) - (position #\; str))) - (v3 (if actual-warnings-p failure-p t)) - (v4 (if expect-warnings failure-p t)) - (v5 (if expect-style-warnings warnings-p t)) - (v6 (or (null output-truename) (pathnamep output-truename))) - (v7 (equalpt-or-report (namestring (truename target-pathname)) - (namestring output-truename))) - (v8 (not (fboundp funname)))) - (if (and v1 v2 v3 v4 v5 v6 (eql v7 t) v8) t - (list v1 v2 v3 v4 v5 v6 v7 v8))) - (progn - (load output-truename) - (funcall funname))))))) + (output-truename warnings-p failure-p) + vals + (print (namestring (truename target-pathname))) + (print (namestring output-truename)) + (values + (let ((v1 (or print verbose + (and (not print-p) *compile-print*) + (and (not verbose-p) *compile-verbose*) + (string= str ""))) + (v2 (or (and verbose-p (not verbose)) + (and (not verbose-p) (not *compile-verbose*)) + (position #\; str))) + (v3 (if actual-warnings-p failure-p t)) + (v4 (if expect-warnings failure-p t)) + (v5 (if expect-style-warnings warnings-p t)) + (v6 (or (null output-truename) (pathnamep output-truename))) + (v7 (equalpt-or-report (namestring (truename target-pathname)) + (namestring output-truename))) + (v8 (not (fboundp funname)))) + (if (and v1 v2 v3 v4 v5 v6 (eql v7 t) v8) t + (list v1 v2 v3 v4 v5 v6 v7 v8))) + (progn + (load output-truename) + (funcall funname))))))) (deftest compile-file.1 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1) @@ -69,12 +69,12 @@ (deftest compile-file.2 (compile-file-test "compile-file-test-file-2.lsp" 'compile-file-test-fun.2 - :expect-style-warnings t) + :expect-style-warnings t) t nil) (deftest compile-file.2a (compile-file-test "compile-file-test-file-2a.lsp" 'compile-file-test-fun.2a - :expect-warnings t) + :expect-warnings t) t nil) (deftest compile-file.3 @@ -93,57 +93,57 @@ (deftest compile-file.6 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :output-file "foo.fasl") + :output-file "foo.fasl") t nil) (deftest compile-file.6a (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :output-file "foo.ufsl") + :output-file "foo.ufsl") t nil) (deftest compile-file.7 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :external-format :default) + :external-format :default) t nil) (deftest compile-file.8 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :output-file #p"foo.fasl") + :output-file #p"foo.fasl") t nil) (deftest compile-file.9 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :print t) + :print t) t nil) (deftest compile-file.10 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :verbose t) + :verbose t) t nil) (deftest compile-file.11 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :print nil) + :print nil) t nil) (deftest compile-file.12 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :verbose nil) + :verbose nil) t nil) ;;; A file stream is a pathname designator (deftest compile-file.13 (with-open-file (s "compile-file-test-file.lsp" :direction :input) - (compile-file-test s 'compile-file-test-fun.1)) + (compile-file-test s 'compile-file-test-fun.1)) t nil) (deftest compile-file.14 (let ((s (open "foo.fasl" :direction :output :if-exists :supersede - :if-does-not-exist :create))) + :if-does-not-exist :create))) (close s) (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :output-file s)) + 'compile-file-test-fun.1 + :output-file s)) t nil) (deftest compile-file.15 @@ -156,9 +156,9 @@ (deftest compile-file.16 (let* ((file #p"compile-file-test-file-5.lsp") - (target-pathname (compile-file-pathname file)) - (*compile-print* nil) - (*compile-verbose* nil)) + (target-pathname (compile-file-pathname file)) + (*compile-print* nil) + (*compile-verbose* nil)) (when (probe-file target-pathname) (delete-file target-pathname)) (compile-file file) @@ -166,7 +166,7 @@ (values (equalpt-or-report (truename file) (funcall 'compile-file-test-fun.5)) (equalpt-or-report (pathname (merge-pathnames file)) - (funcall 'compile-file-test-fun.5a)))) + (funcall 'compile-file-test-fun.5a)))) t t) ;;; Add tests of logical pathnames @@ -184,19 +184,19 @@ (with-open-file (s file :direction :output :if-exists :supersede :if-does-not-exist :create)) (compile-file-test "compile-file-test-file.lsp" - 'compile-file-test-fun.1 - :output-file file)) + 'compile-file-test-fun.1 + :output-file file)) t nil) (deftest compile-file.19 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :*compile-verbose* t) + :*compile-verbose* t) t nil) (deftest compile-file.20 (compile-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :*compile-print* t) - t nil) + :*compile-print* t) + t nil) (deftest compile-file-pathname.1 *compile-file-pathname* diff --git a/ansi-tests/compile.lsp b/ansi-tests/compile.lsp index df93b95c..64dbd6e2 100644 --- a/ansi-tests/compile.lsp +++ b/ansi-tests/compile.lsp @@ -13,7 +13,7 @@ (compiled-function-p 'compile.1-fn) (let ((x (compile 'compile.1-fn))) (or (eqt x 'compile.1-fn) - (notnot (compiled-function-p x)))) + (notnot (compiled-function-p x)))) (compiled-function-p 'compile.1-fn) (not (compiled-function-p #'compile.1-fn)) (fmakunbound 'compile.1-fn))) @@ -28,12 +28,12 @@ ;;; COMPILE returns three values (function, warnings-p, failure-p) (deftest compile.2 (let* ((results (multiple-value-list - (compile nil '(lambda (x y) (cons y x))))) - (fn (car results))) + (compile nil '(lambda (x y) (cons y x))))) + (fn (car results))) (values (length results) - (funcall fn 'a 'b) - (second results) - (third results))) + (funcall fn 'a 'b) + (second results) + (third results))) 3 (b . a) nil @@ -42,16 +42,16 @@ ;;; Compile does not coalesce literal constants (deftest compile.3 (let ((x (list 'a 'b)) - (y (list 'a 'b))) + (y (list 'a 'b))) (and (not (eqt x y)) - (funcall (compile nil `(lambda () (eqt ',x ',y)))))) + (funcall (compile nil `(lambda () (eqt ',x ',y)))))) nil) (deftest compile.4 (let ((x (copy-seq "abc")) - (y (copy-seq "abc"))) + (y (copy-seq "abc"))) (and (not (eqt x y)) - (funcall (compile nil `(lambda () (eqt ,x ,y)))))) + (funcall (compile nil `(lambda () (eqt ,x ,y)))))) nil) (deftest compile.5 @@ -78,7 +78,7 @@ (let ((i 0) a b) (values (funcall (compile (progn (setf a (incf i)) nil) - (progn (setf b (incf i)) '(lambda () 'z)))) + (progn (setf b (incf i)) '(lambda () 'z)))) i a b)) z 2 1 2) @@ -90,5 +90,5 @@ (deftest compile.error.2 (signals-error (compile nil '(lambda () nil) 'garbage) - program-error) + program-error) t) diff --git a/ansi-tests/complement.lsp b/ansi-tests/complement.lsp index fefb1a3c..b442d47a 100644 --- a/ansi-tests/complement.lsp +++ b/ansi-tests/complement.lsp @@ -16,15 +16,15 @@ (deftest complement.3 (check-predicate #'(lambda (x) (eql (funcall (cl::complement #'not) x) - (not (not x))))) + (not (not x))))) nil) (deftest complement.4 (let ((x '(#\b))) (loop for i from 2 to (min 256 (1- call-arguments-limit)) - always (progn - (push #\a x) - (apply (complement #'char=) x)))) + always (progn + (push #\a x) + (apply (complement #'char=) x)))) t) (deftest complement.5 @@ -61,15 +61,15 @@ (%f :y nil) (%f :y t :y nil) (%f :x nil :y nil) (%f :x t :y nil) (%f :y t :x nil) (%f :x t :y t)) - + (list - (funcall cf) (funcall cf :x nil) (funcall cf :x t) - (funcall cf :y nil) (funcall cf :y t) - (funcall cf :x nil :y nil) (funcall cf :x t :y nil) - (funcall cf :y t :x nil) (funcall cf :x t :y t :x nil)) + (funcall cf) (funcall cf :x nil) (funcall cf :x t) + (funcall cf :y nil) (funcall cf :y t) + (funcall cf :x nil :y nil) (funcall cf :x t :y nil) + (funcall cf :y t :x nil) (funcall cf :x t :y t :x nil)) (list - (funcall cf :x nil :y t :foo nil :allow-other-keys t) - (funcall cf :x nil :y t :allow-other-keys nil))))) + (funcall cf :x nil :y t :foo nil :allow-other-keys t) + (funcall cf :x nil :y t :allow-other-keys nil))))) (nil nil t nil t nil t t nil) (t t nil t nil t nil nil t) (nil nil)) @@ -81,19 +81,19 @@ (eval `(defmethod ,sym ((x t) (y t)) nil)) (let ((cf (complement (symbol-function sym)))) (values (funcall cf 'a 'b) - (funcall cf 0 0) - (funcall cf 0 1) - (funcall cf 1 0) - (funcall cf 1 1)))) + (funcall cf 0 0) + (funcall cf 0 1) + (funcall cf 1 0) + (funcall cf 1 1)))) t nil t t nil) (deftest complement.10 (let ((cf (complement (compile nil '(lambda (x y) (evenp (+ x y))))))) (values (funcall cf 0 0) - (funcall cf 0 1) - (funcall cf 1 0) - (funcall cf 1 1))) - nil t t nil) + (funcall cf 0 1) + (funcall cf 1 0) + (funcall cf 1 1))) + nil t t nil) (deftest complement.order.1 (let ((i 0)) @@ -116,12 +116,12 @@ (deftest complement.error.3 (signals-error (funcall (complement #'identity)) - program-error) + program-error) t) (deftest complement.error.4 (signals-error (funcall (complement #'identity) t t) - program-error) + program-error) t) (deftest complement.error.5 @@ -130,10 +130,10 @@ (deftest complement.error.6 (signals-error (funcall (complement #'(lambda (&key) t)) :allow-other-keys nil - :allow-other-keys t :foo t) program-error) + :allow-other-keys t :foo t) program-error) t) (deftest complement.error.7 (signals-error (funcall (complement #'(lambda (x &rest y) (and x (evenp (length y)))))) - program-error) + program-error) t) diff --git a/ansi-tests/complex.lsp b/ansi-tests/complex.lsp index 64e9f050..28eb6c25 100644 --- a/ansi-tests/complex.lsp +++ b/ansi-tests/complex.lsp @@ -19,43 +19,43 @@ (deftest complex.1 (loop for x in *rationals* - for c = (complex x) - always (eql c x)) + for c = (complex x) + always (eql c x)) t) (deftest complex.2 (loop for x in *floats* - for c = (complex x) - always (and (complexp c) - (eql x (realpart c)) - (eql (float 0 x) (imagpart c)))) + for c = (complex x) + always (and (complexp c) + (eql x (realpart c)) + (eql (float 0 x) (imagpart c)))) t) (deftest complex.3 (loop for x in *rationals* - for c = (complex 0 x) - unless (or (zerop x) - (and (complexp c) - (eql (realpart c) 0) - (eql (imagpart c) x))) - collect (list c x)) + for c = (complex 0 x) + unless (or (zerop x) + (and (complexp c) + (eql (realpart c) 0) + (eql (imagpart c) x))) + collect (list c x)) nil) (deftest complex.4 (loop for x in *floats* - for c = (complex 0 x) - always (and (complexp c) - (eql (float 0 x) (realpart c)) - (eql x (imagpart c)))) + for c = (complex 0 x) + always (and (complexp c) + (eql (float 0 x) (realpart c)) + (eql x (imagpart c)))) t) ;;; Tests of some properties of complex numbers (deftest complex.5 (loop for c in *complexes* - unless (loop for type in '(short-float single-float double-float long-float) - always (if (typep (realpart c) type) - (typep (imagpart c) type) - (not (typep (imagpart c) type)))) - collect c) + unless (loop for type in '(short-float single-float double-float long-float) + always (if (typep (realpart c) type) + (typep (imagpart c) type) + (not (typep (imagpart c) type)))) + collect c) nil) diff --git a/ansi-tests/compute-applicable-methods.lsp b/ansi-tests/compute-applicable-methods.lsp index 44c7244d..40aa4a1d 100644 --- a/ansi-tests/compute-applicable-methods.lsp +++ b/ansi-tests/compute-applicable-methods.lsp @@ -22,20 +22,20 @@ (deftest compute-applicable-methods.1 (let ((methods (compute-applicable-methods #'cam-gf-01 (list 1 2)))) (equalt methods - (list *cam-gf-01-method1* *cam-gf-01-method2* - *cam-gf-01-method3* *cam-gf-01-method4*))) + (list *cam-gf-01-method1* *cam-gf-01-method2* + *cam-gf-01-method3* *cam-gf-01-method4*))) t) (deftest compute-applicable-methods.2 (let ((methods (compute-applicable-methods #'cam-gf-01 (list 1 'x)))) (equalt methods - (list *cam-gf-01-method2* *cam-gf-01-method4*))) + (list *cam-gf-01-method2* *cam-gf-01-method4*))) t) (deftest compute-applicable-methods.3 (let ((methods (compute-applicable-methods #'cam-gf-01 (list 'x 10)))) (equalt methods - (list *cam-gf-01-method3* *cam-gf-01-method4*))) + (list *cam-gf-01-method3* *cam-gf-01-method4*))) t) (deftest compute-applicable-methods.4 @@ -53,53 +53,53 @@ (report-and-ignore-errors (defgeneric cam-gf-03 (x) (:method-combination + :most-specific-first)) - + (defparameter *cam-gf-03-method1* (defmethod cam-gf-03 + ((x integer)) 1)) - + (defparameter *cam-gf-03-method2* (defmethod cam-gf-03 + ((x rational)) 2)) - + (defparameter *cam-gf-03-method3* (defmethod cam-gf-03 + ((x real)) 4)) - + (defparameter *cam-gf-03-method4* (defmethod cam-gf-03 + ((x number)) 8)) - + (defparameter *cam-gf-03-method5* (defmethod cam-gf-03 + ((x t)) 16)))) (deftest compute-applicable-methods.6 (equalt (compute-applicable-methods #'cam-gf-03 (list 0)) - (list *cam-gf-03-method1* *cam-gf-03-method2* *cam-gf-03-method3* - *cam-gf-03-method4* *cam-gf-03-method5*)) + (list *cam-gf-03-method1* *cam-gf-03-method2* *cam-gf-03-method3* + *cam-gf-03-method4* *cam-gf-03-method5*)) t) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defgeneric cam-gf-04 (x) (:method-combination + :most-specific-last)) - + (defparameter *cam-gf-04-method1* (defmethod cam-gf-04 + ((x integer)) 1)) - + (defparameter *cam-gf-04-method2* (defmethod cam-gf-04 + ((x rational)) 2)) - + (defparameter *cam-gf-04-method3* (defmethod cam-gf-04 + ((x real)) 4)) - + (defparameter *cam-gf-04-method4* (defmethod cam-gf-04 + ((x number)) 8)) - + (defparameter *cam-gf-04-method5* (defmethod cam-gf-04 + ((x t)) 16)) )) - + (deftest compute-applicable-methods.7 (equalt (compute-applicable-methods #'cam-gf-04 (list 0)) - (list *cam-gf-04-method1* *cam-gf-04-method2* *cam-gf-04-method3* - *cam-gf-04-method4* *cam-gf-04-method5*)) + (list *cam-gf-04-method1* *cam-gf-04-method2* *cam-gf-04-method3* + *cam-gf-04-method4* *cam-gf-04-method5*)) t) ;;; Need tests with :around, :before, :after methods @@ -108,15 +108,15 @@ (deftest compute-applicable-methods.error.1 (signals-error (compute-applicable-methods) - program-error) + program-error) t) (deftest compute-applicable-methods.error.2 (signals-error (compute-applicable-methods #'cam-gf-01) - program-error) + program-error) t) (deftest compute-applicable-methods.error.3 (signals-error (compute-applicable-methods #'cam-gf-01 '(1 2) nil) - program-error) + program-error) t) diff --git a/ansi-tests/compute-restarts.lsp b/ansi-tests/compute-restarts.lsp index 04a6b2ee..3890c55a 100644 --- a/ansi-tests/compute-restarts.lsp +++ b/ansi-tests/compute-restarts.lsp @@ -7,12 +7,12 @@ (deftest compute-restarts.1 (loop for r in (compute-restarts) - always (typep r 'restart)) + always (typep r 'restart)) t) (deftest compute-restarts.2 (loop for r in (compute-restarts) - always (typep r (find-class 'restart))) + always (typep r (find-class 'restart))) t) (deftest compute-restarts.3 @@ -24,15 +24,15 @@ (deftest compute-restarts.4 (loop for r1 in (compute-restarts) - for r2 in (compute-restarts) - always (eq r1 r2)) + for r2 in (compute-restarts) + always (eq r1 r2)) t) (deftest compute-restarts.5 (restart-case (loop for r1 in (compute-restarts) - for r2 in (compute-restarts) - always (eq r1 r2)) + for r2 in (compute-restarts) + always (eq r1 r2)) (foo () t) (bar () t) (foo () nil)) @@ -41,8 +41,8 @@ (deftest compute-restarts.6 (restart-case (let* ((restarts (compute-restarts)) - (p (position 'foo restarts :key #'restart-name)) - (r (find 'foo restarts :start (1+ p) :key #'restart-name))) + (p (position 'foo restarts :key #'restart-name)) + (r (find 'foo restarts :start (1+ p) :key #'restart-name))) (invoke-restart r)) (foo () 'bad) (foo () 'good) @@ -52,11 +52,11 @@ (deftest compute-restarts.7 (handler-bind ((error #'(lambda (c) - (let* ((restarts (compute-restarts c)) - (r (remove 'foo restarts - :test-not #'eq - :key #'restart-name))) - (invoke-restart (second r)))))) + (let* ((restarts (compute-restarts c)) + (r (remove 'foo restarts + :test-not #'eq + :key #'restart-name))) + (invoke-restart (second r)))))) (restart-case (error "an error") (foo () 'bad) @@ -67,12 +67,12 @@ (deftest compute-restarts.8 (handler-bind ((error #'(lambda (c) - (declare (ignore c)) - (let* ((restarts (compute-restarts)) - (r (remove 'foo restarts - :test-not #'eq - :key #'restart-name))) - (invoke-restart (second r)))))) + (declare (ignore c)) + (let* ((restarts (compute-restarts)) + (r (remove 'foo restarts + :test-not #'eq + :key #'restart-name))) + (invoke-restart (second r)))))) (restart-case (error "an error") (foo () 'bad) @@ -85,19 +85,19 @@ (block done (handler-bind ((error #'(lambda (c) - (declare (ignore c)) - (let* ((restarts (compute-restarts c2)) - (r (remove 'foo restarts - :test-not #'eq - :key #'restart-name))) - ;; (write restarts) - (return-from done - (values r - (mapcar #'restart-name r))))))) + (declare (ignore c)) + (let* ((restarts (compute-restarts c2)) + (r (remove 'foo restarts + :test-not #'eq + :key #'restart-name))) + ;; (write restarts) + (return-from done + (values r + (mapcar #'restart-name r))))))) (restart-case - (error "an error") - (foo () 'bad) - (foo () 'also-bad))))) + (error "an error") + (foo () 'bad) + (foo () 'also-bad))))) nil nil) ;;; This test is disabled until I figure out how to fix @@ -108,21 +108,21 @@ (block done (handler-bind ((error #'(lambda (c) - (declare (ignore c)) - (let* ((restarts (compute-restarts c2)) - (r (remove 'foo restarts - :test-not #'eq - :key #'restart-name))) - ;; (write restarts) - (return-from done - (values r - (mapcar #'restart-name r))))))) + (declare (ignore c)) + (let* ((restarts (compute-restarts c2)) + (r (remove 'foo restarts + :test-not #'eq + :key #'restart-name))) + ;; (write restarts) + (return-from done + (values r + (mapcar #'restart-name r))))))) (restart-case - (progn (error "an error")) - (foo () :test (lambda (c) (or (null c) (not (eq c c2)))) - 'bad) - (foo () :test (lambda (c) (or (null c) (not (eq c c2)))) - 'also-bad))))) + (progn (error "an error")) + (foo () :test (lambda (c) (or (null c) (not (eq c c2)))) + 'bad) + (foo () :test (lambda (c) (or (null c) (not (eq c c2)))) + 'also-bad))))) nil nil) |# diff --git a/ansi-tests/concatenate.lsp b/ansi-tests/concatenate.lsp index 5bfceb63..e33d094b 100644 --- a/ansi-tests/concatenate.lsp +++ b/ansi-tests/concatenate.lsp @@ -11,12 +11,12 @@ (deftest concatenate.2 (let* ((orig (list 'a 'b 'c 'd 'e)) - (copy (concatenate 'list orig))) + (copy (concatenate 'list orig))) (values copy (intersection (loop for e on orig collect e) - (loop for e on copy collect e) - :test #'eq))) + (loop for e on copy collect e) + :test #'eq))) (a b c d e) nil) @@ -38,7 +38,7 @@ (deftest concatenate.7 (let* ((orig (vector 'a 'b 'c 'd 'e)) - (copy (concatenate 'vector orig))) + (copy (concatenate 'vector orig))) (values copy (eqt copy orig))) @@ -133,28 +133,28 @@ (deftest concatenate.25 (let ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) - :fill-pointer 5))) + :fill-pointer 5))) (concatenate 'list x x)) (a b c d e a b c d e)) (deftest concatenate.26 (let ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) - :fill-pointer 5))) + :fill-pointer 5))) (concatenate 'list x)) (a b c d e)) (deftest concatenate.27 (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j) - :fill-pointer 5)) - (result (concatenate 'vector x))) + :fill-pointer 5)) + (result (concatenate 'vector x))) (values (not (simple-vector-p result)) - result)) + result)) nil #(a b c d e)) (deftest concatenate.28 (let* ((x (make-array '(10) :initial-contents "abcdefghij" - :fill-pointer 5 :element-type 'character))) + :fill-pointer 5 :element-type 'character))) (values (concatenate 'string x '(#\z)) (concatenate 'string '(#\z) x) @@ -170,7 +170,7 @@ (deftest concatenate.29 (let* ((x (make-array '(10) :initial-contents "abcdefghij" - :fill-pointer 5 :element-type 'base-char))) + :fill-pointer 5 :element-type 'base-char))) (values (concatenate 'string x '(#\z)) (concatenate 'string '(#\z) x) @@ -186,7 +186,7 @@ (deftest concatenate.30 (let* ((x (make-array '(10) :initial-contents #*0110010111 - :fill-pointer 5 :element-type 'bit))) + :fill-pointer 5 :element-type 'bit))) (values (concatenate 'bit-vector x '(0)) (concatenate '(bit-vector) '(0) x) @@ -202,7 +202,7 @@ (deftest concatenate.30a (let* ((x (make-array '(10) :initial-contents #*0110010111 - :fill-pointer 5 :element-type 'bit))) + :fill-pointer 5 :element-type 'bit))) (values (concatenate 'simple-bit-vector x '(0)) (concatenate 'simple-bit-vector '(0) x) @@ -240,40 +240,40 @@ (deftest concatenate.34 (concatenate 'simple-string "abc" "def") "abcdef") - + (deftest concatenate.35 (concatenate '(simple-string) "abc" "def") "abcdef") - + (deftest concatenate.36 (concatenate '(simple-string *) "abc" "def") "abcdef") - + (deftest concatenate.37 (concatenate '(simple-string 6) "abc" "def") "abcdef") - + (deftest concatenate.38 (concatenate '(string) "abc" "def") "abcdef") - + (deftest concatenate.39 (concatenate '(string *) "abc" "def") "abcdef") - + (deftest concatenate.40 (concatenate '(string 6) "abc" "def") "abcdef") ;;; Order of evaluation tests - + (deftest concatenate.order.1 (let ((i 0) w x y z) (values (concatenate (progn (setf w (incf i)) 'string) - (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "def") - (progn (setf z (incf i)) "ghi")) + (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "def") + (progn (setf z (incf i)) "ghi")) i w x y z)) "abcdefghi" 4 1 2 3 4) @@ -281,9 +281,9 @@ (let ((i 0) x y z) (values (concatenate 'string - (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "def") - (progn (setf z (incf i)) "ghi")) + (progn (setf x (incf i)) "abc") + (progn (setf y (incf i)) "def") + (progn (setf z (incf i)) "ghi")) i x y z)) "abcdefghi" 3 1 2 3) @@ -297,7 +297,7 @@ (def-fold-test concatenate.fold.6 (concatenate 'vector #(a b c d))) (def-fold-test concatenate.fold.7 (concatenate 'bit-vector #*110101101)) (def-fold-test concatenate.fold.8 (concatenate 'string "abcdef")) - + ;;; Error tests (deftest concatenate.error.1 @@ -310,7 +310,7 @@ (deftest concatenate.error.3 (signals-error (concatenate '(vector * 3) '(a b c d e)) - type-error) + type-error) t) (deftest concatenate.error.4 @@ -319,14 +319,14 @@ (deftest concatenate.error.5 (signals-error (locally (concatenate '(vector * 3) '(a b c d e)) t) - type-error) + type-error) t) (deftest concatenate.error.6 :notes (:result-type-element-type-by-subtype) (let ((type '(or (vector bit) (vector t)))) (if (subtypep type 'vector) - (eval `(signals-error-always (concatenate ',type '(0 1 0) '(1 1 0)) error)) + (eval `(signals-error-always (concatenate ',type '(0 1 0) '(1 1 0)) error)) (values t t))) t t) diff --git a/ansi-tests/concatenated-stream-streams.lsp b/ansi-tests/concatenated-stream-streams.lsp index 0cc7e296..22d55243 100644 --- a/ansi-tests/concatenated-stream-streams.lsp +++ b/ansi-tests/concatenated-stream-streams.lsp @@ -11,9 +11,9 @@ (deftest concatenated-stream-streams.2 (equalt (list (list *standard-input*)) - (multiple-value-list - (concatenated-stream-streams - (make-concatenated-stream *standard-input*)))) + (multiple-value-list + (concatenated-stream-streams + (make-concatenated-stream *standard-input*)))) t) (deftest concatenated-stream-streams.3 @@ -23,8 +23,8 @@ (s2 "def") (let ((s (make-concatenated-stream s1 s2))) (equalt (list (list s1 s2)) - (multiple-value-list - (concatenated-stream-streams s)))))) + (multiple-value-list + (concatenated-stream-streams s)))))) t) (deftest concatenated-stream-streams.4 @@ -34,8 +34,8 @@ (s2 "def") (let ((s (make-concatenated-stream s1 s2))) (equalt (list (list s1 s2)) - (multiple-value-list - (concatenated-stream-streams s)))))) + (multiple-value-list + (concatenated-stream-streams s)))))) t) (deftest concatenated-stream-streams.5 @@ -47,8 +47,8 @@ (values (read-char s) (equalt (list (list s2)) - (multiple-value-list - (concatenated-stream-streams s))))))) + (multiple-value-list + (concatenated-stream-streams s))))))) #\d t) ;;; Error cases @@ -59,9 +59,9 @@ (deftest concatenated-stream-streams.error.2 (signals-error (concatenated-stream-streams - (make-concatenated-stream) - nil) - program-error) + (make-concatenated-stream) + nil) + program-error) t) diff --git a/ansi-tests/cond.lsp b/ansi-tests/cond.lsp index 02b91901..1eaabefe 100644 --- a/ansi-tests/cond.lsp +++ b/ansi-tests/cond.lsp @@ -40,9 +40,9 @@ (let ((x 0)) (values (cond (nil (incf x) 'a) - (nil (incf x 10) 'b) - (t (incf x 2) 'c) - (t (incf x 100) 'd)) + (nil (incf x 10) 'b) + (t (incf x 2) 'c) + (t (incf x 100) 'd)) x)) c 2) @@ -75,8 +75,8 @@ (block done (tagbody (cond (t (go 10) - 10 - (return-from done 'bad))) + 10 + (return-from done 'bad))) 10 (return-from done 'good))) good) @@ -88,31 +88,31 @@ (macrolet ((%m (z) z)) (cond ((expand-in-current-env (%m nil)) :bad) - (t :good))) + (t :good))) :good) (deftest cond.17 (macrolet ((%m (z) z)) (cond (nil :bad1) - ((expand-in-current-env (%m :good))) - (t :bad2))) + ((expand-in-current-env (%m :good))) + (t :bad2))) :good) ;;; Error tests (deftest cond.error.1 (signals-error (funcall (macro-function 'cond)) - program-error) + program-error) t) (deftest cond.error.2 (signals-error (funcall (macro-function 'cond) '(cond)) - program-error) + program-error) t) (deftest cond.error.3 (signals-error (funcall (macro-function 'cond) '(cond) nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/condition.lsp b/ansi-tests/condition.lsp index a42ea742..0a52a4d8 100644 --- a/ansi-tests/condition.lsp +++ b/ansi-tests/condition.lsp @@ -47,17 +47,17 @@ ;;; subtype relationships allowed on condition types (deftest condition.2 (loop for (cnd . supers) in *allowed-condition-inclusions* - append (loop for super in supers - unless (subtypep cnd super) - collect (list cnd super))) + append (loop for super in supers + unless (subtypep cnd super) + collect (list cnd super))) nil) (deftest condition.3 ;; Relationships given in *allowed-condition-inclusions* are the only ;; subtype relationships allowed on condition types (loop for cnds in *allowed-condition-inclusions* - for cnd = (first cnds) - append (loop for super in (set-difference *condition-types* cnds) - when (subtypep cnd super) - collect (list cnd super))) + for cnd = (first cnds) + append (loop for super in (set-difference *condition-types* cnds) + when (subtypep cnd super) + collect (list cnd super))) nil) diff --git a/ansi-tests/conjugate.lsp b/ansi-tests/conjugate.lsp index 10d5f21a..cbcb48fc 100644 --- a/ansi-tests/conjugate.lsp +++ b/ansi-tests/conjugate.lsp @@ -19,19 +19,19 @@ (deftest conjugate.1 (loop for x in *reals* - for vals = (multiple-value-list (conjugate x)) - for xc = (car vals) - always (and (= (length vals) 1) - (eql x xc))) + for vals = (multiple-value-list (conjugate x)) + for xc = (car vals) + always (and (= (length vals) 1) + (eql x xc))) t) (deftest conjugate.2 (loop for x in *complexes* - for vals = (multiple-value-list (conjugate x)) - for xc = (car vals) - always (and (= (length vals) 1) - (eql (realpart x) (realpart xc)) - (eql (- (imagpart x)) (imagpart xc)))) + for vals = (multiple-value-list (conjugate x)) + for xc = (car vals) + always (and (= (length vals) 1) + (eql (realpart x) (realpart xc)) + (eql (- (imagpart x)) (imagpart xc)))) t) (deftest conjugate.3 diff --git a/ansi-tests/cons-aux.lsp b/ansi-tests/cons-aux.lsp index a47467ac..6d5003c8 100644 --- a/ansi-tests/cons-aux.lsp +++ b/ansi-tests/cons-aux.lsp @@ -22,11 +22,11 @@ (if (consp x) (make-scaffold :node x - :car (make-scaffold-copy (car x)) - :cdr (make-scaffold-copy (cdr x))) + :car (make-scaffold-copy (car x)) + :cdr (make-scaffold-copy (cdr x))) (make-scaffold :node x - :car nil - :cdr nil))) + :car nil + :cdr nil))) (defun check-scaffold-copy (x xcopy) "Return t if xcopy were produced from x by make-scaffold-copy, @@ -35,17 +35,17 @@ (and (eq x (scaffold-node xcopy)) (or - (not (consp x)) - (and - (check-scaffold-copy (car x) (scaffold-car xcopy)) - (check-scaffold-copy (cdr x) (scaffold-cdr xcopy)))))) + (not (consp x)) + (and + (check-scaffold-copy (car x) (scaffold-car xcopy)) + (check-scaffold-copy (cdr x) (scaffold-cdr xcopy)))))) (defun create-c*r-test (n) (cond ((<= n 0) 'none) (t (cons (create-c*r-test (1- n)) - (create-c*r-test (1- n)))))) + (create-c*r-test (1- n)))))) (defun nth-1-body (x) (loop @@ -59,9 +59,9 @@ (cond ((consp x) (and (consp y) - (not (eqt x y)) - (check-cons-copy (car x) (car y)) - (check-cons-copy (cdr x) (cdr y)))) + (not (eqt x y)) + (check-cons-copy (car x) (car y)) + (check-cons-copy (cdr x) (cdr y)))) ((eqt x y) t) (t nil))) @@ -72,12 +72,12 @@ (setf a (copy-tree a)) (setf al (copy-tree al)) (let ((acopy (make-scaffold-copy a)) - (alcopy (make-scaffold-copy al))) + (alcopy (make-scaffold-copy al))) (let ((as - (apply #'sublis al a - `(,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)) - ,@(unless (eqt key 'no-key) `(:key ,key)))))) + (apply #'sublis al a + `(,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)) + ,@(unless (eqt key 'no-key) `(:key ,key)))))) (and (check-scaffold-copy a acopy) (check-scaffold-copy al alcopy) @@ -88,10 +88,10 @@ (setf a (copy-tree a)) (setf al (copy-tree al)) (let ((as - (apply #'sublis (copy-tree al) (copy-tree a) - `(,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)) - ,@(unless (eqt key 'no-key) `(:key ,key)))))) + (apply #'sublis (copy-tree al) (copy-tree a) + `(,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)) + ,@(unless (eqt key 'no-key) `(:key ,key)))))) as)) (defun check-subst (new old tree &key (key 'no-key) test test-not) @@ -101,17 +101,17 @@ (setf old (copy-tree old)) (setf tree (copy-tree tree)) (let ((newcopy (make-scaffold-copy new)) - (oldcopy (make-scaffold-copy old)) - (treecopy (make-scaffold-copy tree))) + (oldcopy (make-scaffold-copy old)) + (treecopy (make-scaffold-copy tree))) (let ((result - (apply #'subst new old tree - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)))))) + (apply #'subst new old tree + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) (and (check-scaffold-copy new newcopy) - (check-scaffold-copy old oldcopy) - (check-scaffold-copy tree treecopy) - result)))) + (check-scaffold-copy old oldcopy) + (check-scaffold-copy tree treecopy) + result)))) (defun check-subst-if (new pred tree &key (key 'no-key)) @@ -120,15 +120,15 @@ (setf new (copy-tree new)) (setf tree (copy-tree tree)) (let ((newcopy (make-scaffold-copy new)) - (predcopy (make-scaffold-copy pred)) - (treecopy (make-scaffold-copy tree))) + (predcopy (make-scaffold-copy pred)) + (treecopy (make-scaffold-copy tree))) (let ((result - (apply #'subst-if new pred tree - (unless (eqt key 'no-key) `(:key ,key))))) + (apply #'subst-if new pred tree + (unless (eqt key 'no-key) `(:key ,key))))) (and (check-scaffold-copy new newcopy) - (check-scaffold-copy pred predcopy) - (check-scaffold-copy tree treecopy) - result)))) + (check-scaffold-copy pred predcopy) + (check-scaffold-copy tree treecopy) + result)))) (defun check-subst-if-not (new pred tree &key (key 'no-key)) "Call subst-if-not new pred tree, with various keyword arguments @@ -136,15 +136,15 @@ (setf new (copy-tree new)) (setf tree (copy-tree tree)) (let ((newcopy (make-scaffold-copy new)) - (predcopy (make-scaffold-copy pred)) - (treecopy (make-scaffold-copy tree))) + (predcopy (make-scaffold-copy pred)) + (treecopy (make-scaffold-copy tree))) (let ((result - (apply #'subst-if-not new pred tree - (unless (eqt key 'no-key) `(:key ,key))))) + (apply #'subst-if-not new pred tree + (unless (eqt key 'no-key) `(:key ,key))))) (and (check-scaffold-copy new newcopy) - (check-scaffold-copy pred predcopy) - (check-scaffold-copy tree treecopy) - result)))) + (check-scaffold-copy pred predcopy) + (check-scaffold-copy tree treecopy) + result)))) (defun check-nsubst (new old tree &key (key 'no-key) test test-not) "Call nsubst new old tree, with keyword arguments if present." @@ -152,32 +152,32 @@ (setf old (copy-tree old)) (setf tree (copy-tree tree)) (apply #'nsubst new old tree - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not))))) + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not))))) (defun check-nsubst-if (new pred tree &key (key 'no-key)) "Call nsubst-if new pred tree, with keyword arguments if present." (setf new (copy-tree new)) (setf tree (copy-tree tree)) (apply #'nsubst-if new pred tree - (unless (eqt key 'no-key) `(:key ,key)))) + (unless (eqt key 'no-key) `(:key ,key)))) (defun check-nsubst-if-not (new pred tree &key (key 'no-key)) "Call nsubst-if-not new pred tree, with keyword arguments if present." (setf new (copy-tree new)) (setf tree (copy-tree tree)) (apply #'nsubst-if-not new pred tree - (unless (eqt key 'no-key) `(:key ,key)))) + (unless (eqt key 'no-key) `(:key ,key)))) (defun check-copy-list-copy (x y) "Check that y is a copy of the list x." (if (consp x) (and (consp y) - (not (eqt x y)) - (eqt (car x) (car y)) - (check-copy-list-copy (cdr x) (cdr y))) + (not (eqt x y)) + (eqt (car x) (car y)) + (check-copy-list-copy (cdr x) (cdr y))) (and (eqt x y) t))) (defun check-copy-list (x) @@ -192,7 +192,7 @@ (defun append-6-body () (let* ((cal (min 2048 call-arguments-limit)) - (step (max 1 (floor (/ cal) 64)))) + (step (max 1 (floor (/ cal) 64)))) (loop for n from 0 below cal @@ -201,7 +201,7 @@ (not (equal (apply #'append (loop for i from 1 to n - collect '(a))) + collect '(a))) (make-list n :initial-element 'a)))))) (defun is-intersection (x y z) @@ -211,13 +211,13 @@ (listp y) (listp z) (loop for e in x - always (or (not (member e y)) - (member e z))) + always (or (not (member e y)) + (member e z))) (loop for e in y - always (or (not (member e x)) - (member e z))) + always (or (not (member e x)) + (member e z))) (loop for e in z - always (and (member e x) (member e y))) + always (and (member e x) (member e y))) t)) (defun shuffle (x) @@ -226,8 +226,8 @@ ((null (cdr x)) x) (t (multiple-value-bind - (y z) - (split-list x) + (y z) + (split-list x) (append (shuffle y) (shuffle z)))))) (defun split-list (x) @@ -236,8 +236,8 @@ ((null (cdr x)) (values x nil)) (t (multiple-value-bind - (y z) - (split-list (cddr x)) + (y z) + (split-list (cddr x)) (values (cons (car x) y) (cons (cadr x) z)))))) (defun intersection-12-body (size niters &optional (maxelem (* 2 size))) @@ -245,61 +245,61 @@ (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size - collect (random maxelem state)))) - (y (shuffle (loop for j from 1 to size - collect (random maxelem state))))) + collect (random maxelem state)))) + (y (shuffle (loop for j from 1 to size + collect (random maxelem state))))) (let ((z (intersection x y))) - (let ((is-good (is-intersection x y z))) - (unless is-good (return (values x y z))))))) + (let ((is-good (is-intersection x y z))) + (unless is-good (return (values x y z))))))) nil)) (defun nintersection-with-check (x y &key test) (let ((ycopy (make-scaffold-copy y))) (let ((result (if test - (nintersection x y :test test) - (nintersection x y)))) + (nintersection x y :test test) + (nintersection x y)))) (if (check-scaffold-copy y ycopy) - result - 'failed)))) + result + 'failed)))) (defun nintersection-12-body (size niters &optional (maxelem (* 2 size))) (let ((state (make-random-state t))) (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size - collect (random maxelem state)))) - (y (shuffle (loop for j from 1 to size - collect (random maxelem state))))) + collect (random maxelem state)))) + (y (shuffle (loop for j from 1 to size + collect (random maxelem state))))) (let ((z (nintersection-with-check (copy-list x) y))) - (when (eqt z 'failed) (return (values x y z))) - (let ((is-good (is-intersection x y z))) - (unless is-good (return (values x y z))))))) + (when (eqt z 'failed) (return (values x y z))) + (let ((is-good (is-intersection x y z))) + (unless is-good (return (values x y z))))))) nil)) (defun union-with-check (x y &key test test-not) (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) + (ycopy (make-scaffold-copy y))) (let ((result (cond - (test (union x y :test test)) - (test-not (union x y :test-not test-not)) - (t (union x y))))) + (test (union x y :test test)) + (test-not (union x y :test-not test-not)) + (t (union x y))))) (if (and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - result - 'failed)))) + (check-scaffold-copy y ycopy)) + result + 'failed)))) (defun union-with-check-and-key (x y key &key test test-not) (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) + (ycopy (make-scaffold-copy y))) (let ((result (cond - (test (union x y :key key :test test)) - (test-not (union x y :key key :test-not test-not)) - (t (union x y :key key))))) + (test (union x y :key key :test test)) + (test-not (union x y :key key :test-not test-not)) + (t (union x y :key key))))) (if (and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - result - 'failed)))) + (check-scaffold-copy y ycopy)) + result + 'failed)))) (defun check-union (x y z) (and (listp x) @@ -314,13 +314,13 @@ (let ((state (make-random-state))) (loop for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (union x y))) - (let ((is-good (check-union x y z))) - (unless is-good (return (values x y z))))))) + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (union x y))) + (let ((is-good (check-union x y z))) + (unless is-good (return (values x y z))))))) nil)) (defun nunion-with-copy (x y &key test test-not) @@ -343,35 +343,35 @@ (let ((state (make-random-state))) (loop for i from 1 to niters do - (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) - (let ((z (nunion-with-copy x y))) - (let ((is-good (check-union x y z))) - (unless is-good (return (values x y z))))))) + (let ((x (shuffle (loop for j from 1 to size collect + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) + (let ((z (nunion-with-copy x y))) + (let ((is-good (check-union x y z))) + (unless is-good (return (values x y z))))))) nil)) (defun set-difference-with-check (x y &key (key 'no-key) - test test-not) + test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) + (ycopy (make-scaffold-copy y))) (let ((result (apply #'set-difference - x y - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)))))) + x y + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) (cond ((and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - result) + (check-scaffold-copy y ycopy)) + result) (t - 'failed))))) + 'failed))))) (defun check-set-difference (x y z &key (key #'identity) - (test #'eql)) + (test #'eql)) (and ;; (not (eqt 'failed z)) (listp x) @@ -379,7 +379,7 @@ (listp z) (loop for e in z always (member e x :key key :test test)) (loop for e in x always (or (member e y :key key :test test) - (member e z :key key :test test))) + (member e z :key key :test test))) (loop for e in y never (member e z :key key :test test)) t)) @@ -388,32 +388,32 @@ (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) (let ((z (set-difference-with-check x y))) - (let ((is-good (check-set-difference x y z))) - (unless is-good (return (values x y z))))))) + (let ((is-good (check-set-difference x y z))) + (unless is-good (return (values x y z))))))) nil)) (defun nset-difference-with-check (x y &key (key 'no-key) - test test-not) + test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (apply #'nset-difference - x y - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not))))) + x y + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not))))) (defun check-nset-difference (x y z &key (key #'identity) - (test #'eql)) + (test #'eql)) (and (listp x) (listp y) (listp z) (loop for e in z always (member e x :key key :test test)) (loop for e in x always (or (member e y :key key :test test) - (member e z :key key :test test))) + (member e z :key key :test test))) (loop for e in y never (member e z :key key :test test)) t)) @@ -422,47 +422,47 @@ (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) (let ((z (nset-difference-with-check x y))) - (let ((is-good (check-nset-difference x y z))) - (unless is-good (return (values x y z))))))) + (let ((is-good (check-nset-difference x y z))) + (unless is-good (return (values x y z))))))) nil)) (defun set-exclusive-or-with-check (x y &key (key 'no-key) - test test-not) + test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) + (ycopy (make-scaffold-copy y))) (let ((result (apply #'set-exclusive-or - x y - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)))))) + x y + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) (cond ((and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - result) + (check-scaffold-copy y ycopy)) + result) (t - 'failed))))) + 'failed))))) (defun check-set-exclusive-or (x y z &key (key #'identity) - (test #'eql)) + (test #'eql)) (and ;; (not (eqt 'failed z)) (listp x) (listp y) (listp z) (loop for e in z always (or (member e x :key key :test test) - (member e y :key key :test test))) + (member e y :key key :test test))) (loop for e in x always (if (member e y :key key :test test) - (not (member e z :key key :test test)) - (member e z :key key :test test))) + (not (member e z :key key :test test)) + (member e z :key key :test test))) (loop for e in y always (if (member e x :key key :test test) - (not (member e z :key key :test test)) - (member e z :key key :test test))) + (not (member e z :key key :test test)) + (member e z :key key :test test))) t)) #| @@ -471,24 +471,24 @@ (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) (let ((z (set-exclusive-or-with-check x y))) - (let ((is-good (check-set-exclusive-or x y z))) - (unless is-good (return (values x y z))))))) + (let ((is-good (check-set-exclusive-or x y z))) + (unless is-good (return (values x y z))))))) nil)) |# (defun nset-exclusive-or-with-check (x y &key (key 'no-key) - test test-not) + test test-not) (setf x (copy-list x)) (setf y (copy-list y)) (apply #'nset-exclusive-or - x y - `(,@(unless (eqt key 'no-key) `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not))))) + x y + `(,@(unless (eqt key 'no-key) `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not))))) #| (defun do-random-nset-exclusive-ors (size niters &optional (maxelem (* 2 size))) @@ -496,28 +496,28 @@ (loop for i from 1 to niters do (let ((x (shuffle (loop for j from 1 to size collect - (random maxelem state)))) - (y (shuffle (loop for j from 1 to size collect - (random maxelem state))))) + (random maxelem state)))) + (y (shuffle (loop for j from 1 to size collect + (random maxelem state))))) (let ((z (nset-exclusive-or-with-check x y))) - (let ((is-good (check-set-exclusive-or x y z))) - (unless is-good (return (values x y z))))))) + (let ((is-good (check-set-exclusive-or x y z))) + (unless is-good (return (values x y z))))))) nil)) |# (defun subsetp-with-check (x y &key (key 'no-key) test test-not) (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) + (ycopy (make-scaffold-copy y))) (let ((result - (apply #'subsetp x y - `(,@(unless (eqt key 'no-key) - `(:key ,key)) - ,@(when test `(:test ,test)) - ,@(when test-not `(:test-not ,test-not)))))) + (apply #'subsetp x y + `(,@(unless (eqt key 'no-key) + `(:key ,key)) + ,@(when test `(:test ,test)) + ,@(when test-not `(:test-not ,test-not)))))) (cond ((and (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)) - (not (not result))) + (check-scaffold-copy y ycopy)) + (not (not result))) (t 'failed))))) (defun my-set-exclusive-or (set1 set2 &key key test test-not) @@ -526,8 +526,8 @@ (cond (test-not (when (symbolp test-not) - (setq test-not (symbol-function test-not))) - (setq test (complement test-not))) + (setq test-not (symbol-function test-not))) + (setq test (complement test-not))) ((not test) (setq test #'eql))) ;;; (when (symbolp test) (setq test (symbol-function test))) @@ -541,74 +541,74 @@ (function nil)) (let* ((keys1 (if key (mapcar (the function key) set1) set1)) - (keys2 (if key (mapcar (the function key) set2) set2)) - (mask1 (make-array (length set1) :element-type 'bit - :initial-element 0)) - (mask2 (make-array (length set2) :element-type 'bit - :initial-element 0))) + (keys2 (if key (mapcar (the function key) set2) set2)) + (mask1 (make-array (length set1) :element-type 'bit + :initial-element 0)) + (mask2 (make-array (length set2) :element-type 'bit + :initial-element 0))) (loop for i1 from 0 - for k1 in keys1 - do - (loop for i2 from 0 - for k2 in keys2 - when (funcall (the function test) k1 k2) - do (setf (sbit mask1 i1) 1 - (sbit mask2 i2) 1))) + for k1 in keys1 + do + (loop for i2 from 0 + for k2 in keys2 + when (funcall (the function test) k1 k2) + do (setf (sbit mask1 i1) 1 + (sbit mask2 i2) 1))) (nconc (loop for e in set1 - for i across mask1 - when (= i 0) - collect e) + for i across mask1 + when (= i 0) + collect e) (loop for e in set2 - for i across mask2 - when (= i 0) - collect e)))) + for i across mask2 + when (= i 0) + collect e)))) (defun make-random-set-exclusive-or-input (n) (let* ((set1 (loop for i from 1 to n collect (random n))) - (set2 (loop for i from 1 to n collect (random n))) - (test-args - (random-case nil nil nil - (list :test 'eql) - (list :test #'eql) - (list :test (complement #'eql)))) - (test-not-args - (and (not test-args) - (random-case nil nil (list :test-not 'eql) - (list :test-not #'eql) - (list :test-not (complement #'eql))))) - (key-args - (random-case nil nil nil nil - (list :key nil) - (list :key 'identity) - (list :key 'not)))) + (set2 (loop for i from 1 to n collect (random n))) + (test-args + (random-case nil nil nil + (list :test 'eql) + (list :test #'eql) + (list :test (complement #'eql)))) + (test-not-args + (and (not test-args) + (random-case nil nil (list :test-not 'eql) + (list :test-not #'eql) + (list :test-not (complement #'eql))))) + (key-args + (random-case nil nil nil nil + (list :key nil) + (list :key 'identity) + (list :key 'not)))) (list* set1 set2 - (reduce #'append (random-permute - (list test-args test-not-args key-args)))))) + (reduce #'append (random-permute + (list test-args test-not-args key-args)))))) (defun random-set-exclusive-or-test (n reps &optional (fn 'set-exclusive-or)) (let ((actual-fn (etypecase fn - (symbol (symbol-function fn)) - (function fn)))) + (symbol (symbol-function fn)) + (function fn)))) (declare (type function actual-fn)) (loop for i below reps - for args = (make-random-set-exclusive-or-input n) - for set1 = (car args) - for set2 = (cadr args) - for result1 = (apply #'remove-duplicates - (sort (copy-list (apply #'my-set-exclusive-or args)) - #'<) - (cddr args)) - for result2 = (apply #'remove-duplicates - (sort (copy-list (apply actual-fn - (copy-list set1) - (copy-list set2) - (cddr args))) - #'<) - (cddr args)) - unless (equal result1 result2) - return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...") - "actual: " result2 "should be: " result1)))) + for args = (make-random-set-exclusive-or-input n) + for set1 = (car args) + for set2 = (cadr args) + for result1 = (apply #'remove-duplicates + (sort (copy-list (apply #'my-set-exclusive-or args)) + #'<) + (cddr args)) + for result2 = (apply #'remove-duplicates + (sort (copy-list (apply actual-fn + (copy-list set1) + (copy-list set2) + (cddr args))) + #'<) + (cddr args)) + unless (equal result1 result2) + return (list (list 'remove-duplicates (list 'sort (cons fn args) '<) "...") + "actual: " result2 "should be: " result1)))) (defun rev-assoc-list (x) (cond diff --git a/ansi-tests/cons-test-01.lsp b/ansi-tests/cons-test-01.lsp index 18cd3f60..28ba178a 100644 --- a/ansi-tests/cons-test-01.lsp +++ b/ansi-tests/cons-test-01.lsp @@ -58,51 +58,51 @@ (defvar *cons-fns* (list 'cons 'consp 'atom 'rplaca 'rplacd - 'car 'cdr 'caar 'cadr 'cdar 'cddr - 'caaar 'caadr 'cadar 'caddr - 'cdaar 'cdadr 'cddar 'cdddr - 'caaaar 'caaadr 'caadar 'caaddr - 'cadaar 'cadadr 'caddar 'cadddr - 'cdaaar 'cdaadr 'cdadar 'cdaddr - 'cddaar 'cddadr 'cdddar 'cddddr - 'copy-tree 'sublis 'nsublis - 'subst 'subst-if 'subst-if-not - 'nsubst 'nsubst-if 'nsubst-if-not - 'tree-equal - 'copy-list - 'list - 'list* - 'list-length - 'listp - 'make-list - 'first 'second 'third 'fourth - 'fifth 'sixth 'seventh 'eighth 'ninth 'tenth - 'nth - 'endp - 'null - 'nconc - 'append - 'revappend 'nreconc - 'butlast 'nbutlast - 'last 'ldiff 'tailp - 'nthcdr 'rest - 'member 'member-if 'member-if-not - 'mapc 'mapcar 'mapcan 'mapl 'maplist 'mapcon - 'acons - 'assoc 'assoc-if 'assoc-if-not - 'copy-alist - 'pairlis - 'rassoc 'rassoc-if 'rassoc-if-not - 'get-properties - 'getf - 'intersection - 'nintersection - 'adjoin - 'set-difference 'nset-difference - 'set-exclusive-or 'nset-exclusive-or - 'subsetp - 'union 'nunion - )) + 'car 'cdr 'caar 'cadr 'cdar 'cddr + 'caaar 'caadr 'cadar 'caddr + 'cdaar 'cdadr 'cddar 'cdddr + 'caaaar 'caaadr 'caadar 'caaddr + 'cadaar 'cadadr 'caddar 'cadddr + 'cdaaar 'cdaadr 'cdadar 'cdaddr + 'cddaar 'cddadr 'cdddar 'cddddr + 'copy-tree 'sublis 'nsublis + 'subst 'subst-if 'subst-if-not + 'nsubst 'nsubst-if 'nsubst-if-not + 'tree-equal + 'copy-list + 'list + 'list* + 'list-length + 'listp + 'make-list + 'first 'second 'third 'fourth + 'fifth 'sixth 'seventh 'eighth 'ninth 'tenth + 'nth + 'endp + 'null + 'nconc + 'append + 'revappend 'nreconc + 'butlast 'nbutlast + 'last 'ldiff 'tailp + 'nthcdr 'rest + 'member 'member-if 'member-if-not + 'mapc 'mapcar 'mapcan 'mapl 'maplist 'mapcon + 'acons + 'assoc 'assoc-if 'assoc-if-not + 'copy-alist + 'pairlis + 'rassoc 'rassoc-if 'rassoc-if-not + 'get-properties + 'getf + 'intersection + 'nintersection + 'adjoin + 'set-difference 'nset-difference + 'set-exclusive-or 'nset-exclusive-or + 'subsetp + 'union 'nunion + )) ;; All the cons functions have a function binding @@ -110,7 +110,7 @@ (loop for x in *cons-fns* count (when (or (not (fboundp x)) - (not (functionp (symbol-function x)))) + (not (functionp (symbol-function x)))) (format t "~%~S not bound to a function" x) t)) 0) @@ -118,7 +118,7 @@ ;; All the cons-related macros have a macro binding (deftest macro-bound-cons-macros (notnot-mv (every #'macro-function - (list 'push 'pop 'pushnew 'remf))) + (list 'push 'pop 'pushnew 'remf))) t) ;; None of the cons-related functions have macro bindings diff --git a/ansi-tests/cons-test-05.lsp b/ansi-tests/cons-test-05.lsp index 1c4f80db..f56d087a 100644 --- a/ansi-tests/cons-test-05.lsp +++ b/ansi-tests/cons-test-05.lsp @@ -20,15 +20,15 @@ (deftest first-etc-1 (let ((x (loop for i from 1 to 20 collect i))) (list (first x) - (second x) - (third x) - (fourth x) - (fifth x) - (sixth x) - (seventh x) - (eighth x) - (ninth x) - (tenth x))) + (second x) + (third x) + (fourth x) + (fifth x) + (sixth x) + (seventh x) + (eighth x) + (ninth x) + (tenth x))) (1 2 3 4 5 6 7 8 9 10)) (deftest first-etc-2 @@ -59,82 +59,82 @@ (loop for fn in '(car cdr caar cadr cdar cddr - caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) do (let ((level (- (length (symbol-name fn)) 2))) (eval `(deftest ,(intern - (concatenate 'string - (symbol-name fn) - "-SET") - :cl-test) - (let ((x (create-c*r-test ,level)) - (y (list (create-c*r-test ,level))) - (i 0)) - (and - (setf (,fn (progn (incf i) x)) 'a) - (eqlt (,fn x) 'a) - (eqlt i 1) - (setf (,fn x) 'none) - (equalt x (create-c*r-test ,level)) - (setf (,fn (progn (incf i) (car y))) 'a) - (eqlt (,fn (car y)) 'a) - (eqlt i 2) - (setf (,fn (car y)) 'none) - (null (cdr y)) - (equalt (car y) (create-c*r-test ,level)) - )) - t)))) + (concatenate 'string + (symbol-name fn) + "-SET") + :cl-test) + (let ((x (create-c*r-test ,level)) + (y (list (create-c*r-test ,level))) + (i 0)) + (and + (setf (,fn (progn (incf i) x)) 'a) + (eqlt (,fn x) 'a) + (eqlt i 1) + (setf (,fn x) 'none) + (equalt x (create-c*r-test ,level)) + (setf (,fn (progn (incf i) (car y))) 'a) + (eqlt (,fn (car y)) 'a) + (eqlt i 2) + (setf (,fn (car y)) 'none) + (null (cdr y)) + (equalt (car y) (create-c*r-test ,level)) + )) + t)))) (loop for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) - (fifth 5) (sixth 6) (seventh 7) (eighth 8) - (ninth 9) (tenth 10)) + (fifth 5) (sixth 6) (seventh 7) (eighth 8) + (ninth 9) (tenth 10)) do (eval `(deftest ,(intern - (concatenate 'string - (symbol-name fn) - "-SET") - :cl-test) + (concatenate 'string + (symbol-name fn) + "-SET") + :cl-test) (let* ((x (make-list 20 :initial-element nil)) - (y (list (copy-list x))) - (cnt 0)) + (y (list (copy-list x))) + (cnt 0)) (and - (setf (,fn (progn (incf cnt) x)) 'a) - (eqlt cnt 1) - (loop - for i from 1 to 20 - do (when (and (not (eql i ,len)) - (nth (1- i) x)) - (return nil)) - finally (return t)) - (setf (,fn (car y)) 'a) - (loop - for i from 1 to 20 - do (when (and (not (eql i ,len)) - (nth (1- i) (car y))) - (return nil)) - finally (return t)) - (eqlt (,fn x) 'a) - (eqlt (nth ,(1- len) x) 'a) - (eqlt (,fn (car y)) 'a) - (nth ,(1- len) (car y)))) + (setf (,fn (progn (incf cnt) x)) 'a) + (eqlt cnt 1) + (loop + for i from 1 to 20 + do (when (and (not (eql i ,len)) + (nth (1- i) x)) + (return nil)) + finally (return t)) + (setf (,fn (car y)) 'a) + (loop + for i from 1 to 20 + do (when (and (not (eql i ,len)) + (nth (1- i) (car y))) + (return nil)) + finally (return t)) + (eqlt (,fn x) 'a) + (eqlt (nth ,(1- len) x) 'a) + (eqlt (,fn (car y)) 'a) + (nth ,(1- len) (car y)))) a))) ;; set up program-error tests (loop for name in *cons-accessors* do (eval - `(deftest ,(intern (concatenate 'string (symbol-name name) - ".ERROR.NO-ARGS") - :cl-test) - (signals-error (,name) program-error) - t)) + `(deftest ,(intern (concatenate 'string (symbol-name name) + ".ERROR.NO-ARGS") + :cl-test) + (signals-error (,name) program-error) + t)) do (eval - `(deftest ,(intern (concatenate 'string (symbol-name name) - ".ERROR.EXCESS-ARGS") - :cl-test) - (signals-error (,name nil nil) program-error) - t))) + `(deftest ,(intern (concatenate 'string (symbol-name name) + ".ERROR.EXCESS-ARGS") + :cl-test) + (signals-error (,name nil nil) program-error) + t))) diff --git a/ansi-tests/cons.lsp b/ansi-tests/cons.lsp index 2e1edab3..565c122f 100644 --- a/ansi-tests/cons.lsp +++ b/ansi-tests/cons.lsp @@ -20,15 +20,15 @@ ;;; successive calls to cons produces results that are equal, but not eq (deftest cons-eq-equal (let ((x (cons 'a 'b)) - (y (cons 'a 'b))) + (y (cons 'a 'b))) (and (not (eqt x y)) - (equalt x y))) + (equalt x y))) t) ;;; list can be expressed as a bunch of conses (with nil) (deftest cons-equal-list (equalt (cons 'a (cons 'b (cons 'c nil))) - (list 'a 'b 'c)) + (list 'a 'b 'c)) t) ;;; Order of evaluation of cons arguments diff --git a/ansi-tests/consp.lsp b/ansi-tests/consp.lsp index c141d54d..c2e7f4c3 100644 --- a/ansi-tests/consp.lsp +++ b/ansi-tests/consp.lsp @@ -36,7 +36,7 @@ ;; consp, but not both (deftest consp-xor-atom-universe (check-predicate #'(lambda (x) (or (and (consp x) (not (atom x))) - (and (not (consp x)) (atom x))))) + (and (not (consp x)) (atom x))))) nil) ;; Everything in type cons satisfies consp, and vice versa diff --git a/ansi-tests/constantly.lsp b/ansi-tests/constantly.lsp index 37dd8be9..55dce3ab 100644 --- a/ansi-tests/constantly.lsp +++ b/ansi-tests/constantly.lsp @@ -7,10 +7,10 @@ (deftest constantly.1 (let ((fn (cl:constantly 10)) - (x nil)) + (x nil)) (loop for i from 0 to (min 256 (1- call-arguments-limit)) - always (prog1 (eql (apply fn x) 10) - (push 'a x)))) + always (prog1 (eql (apply fn x) 10) + (push 'a x)))) t) (deftest constantly.2 diff --git a/ansi-tests/constantp.lsp b/ansi-tests/constantp.lsp index c9eb62e5..eb935183 100644 --- a/ansi-tests/constantp.lsp +++ b/ansi-tests/constantp.lsp @@ -26,7 +26,7 @@ (deftest constantp.2 (notnot-mv (constantp t)) t) - + (deftest constantp.3 (notnot-mv (constantp nil)) t) @@ -47,7 +47,7 @@ (deftest constantp.6 (constantp-macro constantp-test-symbol) t) - + (deftest constantp.7 (constantp '(incf x)) nil) @@ -68,15 +68,15 @@ (deftest constantp.11 (macrolet ((macro-for-constantp.11 (y) - (declare (ignore y)) - '*standard-input*)) + (declare (ignore y)) + '*standard-input*)) (macrolet ((%m (&environment env) - (if (constantp '(macro-for-constantp.11 0) env) - :bad - :good))) + (if (constantp '(macro-for-constantp.11 0) env) + :bad + :good))) (%m))) :good) - + (deftest constantp.order.1 (let ((i 0)) @@ -89,9 +89,9 @@ (let ((i 0) x y) (values (notnot (constantp (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) nil))) + (progn (setf y (incf i)) nil))) i x y)) t 2 1 2) - + diff --git a/ansi-tests/continue.lsp b/ansi-tests/continue.lsp index bc3c1c77..ba063ab8 100644 --- a/ansi-tests/continue.lsp +++ b/ansi-tests/continue.lsp @@ -13,7 +13,7 @@ (deftest continue.2 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 @@ -31,7 +31,7 @@ (deftest continue.4 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 @@ -43,7 +43,7 @@ (deftest continue.5 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) diff --git a/ansi-tests/copy-alist.lsp b/ansi-tests/copy-alist.lsp index c43bfc18..41e3739f 100644 --- a/ansi-tests/copy-alist.lsp +++ b/ansi-tests/copy-alist.lsp @@ -9,19 +9,19 @@ (deftest copy-alist.1 (let* ((x (copy-tree '((a . b) (c . d) nil (e f) ((x) ((y z)) w) - ("foo" . "bar") (#\w . 1.234) - (1/3 . 4123.4d5)))) - (xcopy (make-scaffold-copy x)) - (result (copy-alist x))) + ("foo" . "bar") (#\w . 1.234) + (1/3 . 4123.4d5)))) + (xcopy (make-scaffold-copy x)) + (result (copy-alist x))) (and (check-scaffold-copy x xcopy) (= (length x) (length result)) (every #'(lambda (p1 p2) - (or (and (null p1) (null p2)) - (and (not (eqt p1 p2)) - (eqlt (car p1) (car p2)) - (eqlt (cdr p1) (cdr p2))))) - x result) + (or (and (null p1) (null p2)) + (and (not (eqt p1 p2)) + (eqlt (car p1) (car p2)) + (eqlt (cdr p1) (cdr p2))))) + x result) t)) t) diff --git a/ansi-tests/copy-list.lsp b/ansi-tests/copy-list.lsp index 53336e33..c085c089 100644 --- a/ansi-tests/copy-list.lsp +++ b/ansi-tests/copy-list.lsp @@ -24,7 +24,7 @@ (deftest copy-list.4 (let ((i 0)) (values (copy-list (progn (incf i) '(a b c))) - i)) + i)) (a b c) 1) (def-fold-test copy-list.fold.1 (copy-list '(a b c d))) diff --git a/ansi-tests/copy-pprint-dispatch.lsp b/ansi-tests/copy-pprint-dispatch.lsp index 3bb4fbd6..bde35df0 100644 --- a/ansi-tests/copy-pprint-dispatch.lsp +++ b/ansi-tests/copy-pprint-dispatch.lsp @@ -8,17 +8,17 @@ (deftest copy-pprint-dispatch.1 (with-standard-io-syntax (let ((obj '(foo bar)) - (*package* (find-package :cl-test)) - (*print-readably* nil) - (*print-pretty* t)) + (*package* (find-package :cl-test)) + (*print-readably* nil) + (*print-pretty* t)) (values (prin1-to-string obj) (let ((*print-pprint-dispatch* (copy-pprint-dispatch))) - (set-pprint-dispatch - `(eql ,obj) - #'(lambda (s obj2) (let ((*print-pretty* nil)) - (format s "#.'~S" obj2)))) - (prin1-to-string obj)) + (set-pprint-dispatch + `(eql ,obj) + #'(lambda (s obj2) (let ((*print-pretty* nil)) + (format s "#.'~S" obj2)))) + (prin1-to-string obj)) (prin1-to-string obj)))) "(FOO BAR)" "#.'(FOO BAR)" @@ -27,18 +27,18 @@ (deftest copy-pprint-dispatch.2 (with-standard-io-syntax (let ((obj '(foo bar)) - (*package* (find-package :cl-test)) - (*print-readably* nil) - (*print-pretty* t)) + (*package* (find-package :cl-test)) + (*print-readably* nil) + (*print-pretty* t)) (values (prin1-to-string obj) (let ((*print-pprint-dispatch* (copy-pprint-dispatch - *print-pprint-dispatch*))) - (set-pprint-dispatch - `(eql ,obj) - #'(lambda (s obj2) (let ((*print-pretty* nil)) - (format s "#.'~S" obj2)))) - (prin1-to-string obj)) + *print-pprint-dispatch*))) + (set-pprint-dispatch + `(eql ,obj) + #'(lambda (s obj2) (let ((*print-pretty* nil)) + (format s "#.'~S" obj2)))) + (prin1-to-string obj)) (prin1-to-string obj)))) "(FOO BAR)" "#.'(FOO BAR)" @@ -47,17 +47,17 @@ (deftest copy-pprint-dispatch.3 (with-standard-io-syntax (let ((obj '(foo bar)) - (*package* (find-package :cl-test)) - (*print-readably* nil) - (*print-pretty* t)) + (*package* (find-package :cl-test)) + (*print-readably* nil) + (*print-pretty* t)) (values (prin1-to-string obj) (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) - (set-pprint-dispatch - `(eql ,obj) - #'(lambda (s obj2) (let ((*print-pretty* nil)) - (format s "#.'~S" obj2)))) - (prin1-to-string obj)) + (set-pprint-dispatch + `(eql ,obj) + #'(lambda (s obj2) (let ((*print-pretty* nil)) + (format s "#.'~S" obj2)))) + (prin1-to-string obj)) (prin1-to-string obj)))) "(FOO BAR)" "#.'(FOO BAR)" @@ -66,20 +66,20 @@ (deftest copy-pprint-dispatch.4 (with-standard-io-syntax (let ((obj '(foo bar)) - (*package* (find-package :cl-test)) - (*print-readably* nil) - (*print-pretty* t)) + (*package* (find-package :cl-test)) + (*print-readably* nil) + (*print-pretty* t)) (values (prin1-to-string obj) (let ((table (copy-pprint-dispatch))) - (set-pprint-dispatch - `(eql ,obj) - #'(lambda (s obj2) (let ((*print-pretty* nil)) - (format s "#.'~S" obj2))) - 0 - table) - (let ((*print-pprint-dispatch* (copy-pprint-dispatch table))) - (prin1-to-string obj))) + (set-pprint-dispatch + `(eql ,obj) + #'(lambda (s obj2) (let ((*print-pretty* nil)) + (format s "#.'~S" obj2))) + 0 + table) + (let ((*print-pprint-dispatch* (copy-pprint-dispatch table))) + (prin1-to-string obj))) (prin1-to-string obj)))) "(FOO BAR)" "#.'(FOO BAR)" @@ -109,7 +109,7 @@ (deftest copy-pprint-dispatch.8 (let* ((table1 (copy-pprint-dispatch)) - (table2 (copy-pprint-dispatch table1))) + (table2 (copy-pprint-dispatch table1))) (eql table1 table2)) nil) diff --git a/ansi-tests/copy-readtable.lsp b/ansi-tests/copy-readtable.lsp index 26d61ab3..d92b1506 100644 --- a/ansi-tests/copy-readtable.lsp +++ b/ansi-tests/copy-readtable.lsp @@ -29,7 +29,7 @@ (deftest copy-readtable.6 (let* ((rt (copy-readtable)) - (rt2 (copy-readtable *readtable* rt))) + (rt2 (copy-readtable *readtable* rt))) (notnot (eql rt rt2))) t) diff --git a/ansi-tests/copy-seq.lsp b/ansi-tests/copy-seq.lsp index a3a9f761..eb170407 100644 --- a/ansi-tests/copy-seq.lsp +++ b/ansi-tests/copy-seq.lsp @@ -14,126 +14,126 @@ (deftest copy-seq.2 (let* ((s1 '(a b c)) - (s2 (check-values (copy-seq s1)))) + (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) - (equalt s1 s2))) + (equalt s1 s2))) t) (deftest copy-seq.3 (let* ((s1 #(a b c)) - (s2 (check-values (copy-seq s1)))) + (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) s2)) #(a b c)) (deftest copy-seq.4 (let* ((s1 (make-array '(4) :initial-contents '(a b c d) - :adjustable t)) - (s2 (check-values (copy-seq s1)))) + :adjustable t)) + (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) - (simple-vector-p s2) - s2)) + (simple-vector-p s2) + s2)) #(a b c d)) (deftest copy-seq.5 (let* ((s1 (make-array '(4) :initial-contents '(a b c d) - :fill-pointer 3)) - (s2 (check-values (copy-seq s1)))) + :fill-pointer 3)) + (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) - (simple-vector-p s2) - s2)) + (simple-vector-p s2) + s2)) #(a b c)) (deftest copy-seq.6 (let* ((a1 (make-array '(6) :initial-contents '(a b c d e f))) - (a2 (make-array '(4) :displaced-to a1 - :displaced-index-offset 1)) - (s2 (check-values (copy-seq a2)))) + (a2 (make-array '(4) :displaced-to a1 + :displaced-index-offset 1)) + (s2 (check-values (copy-seq a2)))) (and (not (eql a2 s2)) - (simple-vector-p s2) - s2)) + (simple-vector-p s2) + s2)) #(b c d e)) (deftest copy-seq.7 (let* ((s1 (make-array '(4) - :element-type 'base-char - :initial-contents '(#\a #\b #\c #\d) - :adjustable t)) - (s2 (check-values (copy-seq s1)))) + :element-type 'base-char + :initial-contents '(#\a #\b #\c #\d) + :adjustable t)) + (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) - (simple-string-p s2) - s2)) + (simple-string-p s2) + s2)) "abcd") (deftest copy-seq.8 (let* ((s1 (make-array '(4) - :element-type 'base-char - :initial-contents '(#\a #\b #\c #\d) - :fill-pointer 3)) - (s2 (check-values (copy-seq s1)))) + :element-type 'base-char + :initial-contents '(#\a #\b #\c #\d) + :fill-pointer 3)) + (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) - (simple-string-p s2) - s2)) + (simple-string-p s2) + s2)) "abc") (deftest copy-seq.9 (let* ((a1 (make-array '(6) :initial-contents '(#\a #\b #\c #\d #\e #\f) - :element-type 'base-char)) - (a2 (make-array '(4) :displaced-to a1 - :element-type 'base-char - :displaced-index-offset 1)) - (s2 (check-values (copy-seq a2)))) + :element-type 'base-char)) + (a2 (make-array '(4) :displaced-to a1 + :element-type 'base-char + :displaced-index-offset 1)) + (s2 (check-values (copy-seq a2)))) (and (not (eql a2 s2)) - (simple-string-p s2) - s2)) + (simple-string-p s2) + s2)) "bcde") (deftest copy-seq.10 (let*((s1 "abcd") - (s2 (check-values (copy-seq s1)))) + (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) - s2)) + s2)) "abcd") (deftest copy-seq.11 (let* ((s1 #*0010110) - (s2 (check-values (copy-seq s1)))) + (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) - (simple-bit-vector-p s2) - s2)) + (simple-bit-vector-p s2) + s2)) #*0010110) (deftest copy-seq.12 (let* ((s1 (make-array '(4) :initial-contents '(0 0 1 0) - :element-type 'bit - :adjustable t)) - (s2 (check-values (copy-seq s1)))) + :element-type 'bit + :adjustable t)) + (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) - (simple-bit-vector-p s2) - s2)) + (simple-bit-vector-p s2) + s2)) #*0010) (deftest copy-seq.13 (let* ((s1 (make-array '(4) :initial-contents '(0 0 1 0) - :element-type 'bit - :fill-pointer 3)) - (s2 (check-values (copy-seq s1)))) + :element-type 'bit + :fill-pointer 3)) + (s2 (check-values (copy-seq s1)))) (and (not (eql s1 s2)) - (simple-bit-vector-p s2) - s2)) + (simple-bit-vector-p s2) + s2)) #*001) (deftest copy-seq.14 (let* ((a1 (make-array '(6) :initial-contents '(0 0 1 0 1 1) - :element-type 'bit)) - (a2 (make-array '(4) :displaced-to a1 - :displaced-index-offset 1 - :element-type 'bit)) - (s2 (check-values (copy-seq a2)))) + :element-type 'bit)) + (a2 (make-array '(4) :displaced-to a1 + :displaced-index-offset 1 + :element-type 'bit)) + (s2 (check-values (copy-seq a2)))) (and (not (eql a2 s2)) - (simple-bit-vector-p s2) - s2)) + (simple-bit-vector-p s2) + s2)) #*0101) (deftest copy-seq.15 @@ -150,7 +150,7 @@ (deftest copy-seq.18 (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j))) - (y (check-values (copy-seq x)))) + (y (check-values (copy-seq x)))) (equal-array x y)) t) @@ -196,28 +196,28 @@ (deftest copy-seq.23 (loop for type in '(short-float single-float long-float double-float) - for len = 10 - for vals = (loop for i from 1 to len collect (coerce i type)) - for vec = (make-array len :element-type type :initial-contents vals) - for result = (copy-seq vec) - unless (and (= (length result) len) - (equal (array-element-type vec) (array-element-type result)) - (equalp vec result)) - collect (list type vals result)) + for len = 10 + for vals = (loop for i from 1 to len collect (coerce i type)) + for vec = (make-array len :element-type type :initial-contents vals) + for result = (copy-seq vec) + unless (and (= (length result) len) + (equal (array-element-type vec) (array-element-type result)) + (equalp vec result)) + collect (list type vals result)) nil) (deftest copy-seq.24 (loop for etype in '(short-float single-float long-float double-float) - for type = `(complex ,etype) - for len = 10 - for vals = (loop for i from 1 to len collect (complex (coerce i etype) - (coerce (- i) etype))) - for vec = (make-array len :element-type type :initial-contents vals) - for result = (copy-seq vec) - unless (and (= (length result) len) - (equal (array-element-type vec) (array-element-type result)) - (equalp vec result)) - collect (list type vals result)) + for type = `(complex ,etype) + for len = 10 + for vals = (loop for i from 1 to len collect (complex (coerce i etype) + (coerce (- i) etype))) + for vec = (make-array len :element-type type :initial-contents vals) + for result = (copy-seq vec) + unless (and (= (length result) len) + (equal (array-element-type vec) (array-element-type result)) + (equalp vec result)) + collect (list type vals result)) nil) ;;; Order of evaluation test diff --git a/ansi-tests/copy-symbol.lsp b/ansi-tests/copy-symbol.lsp index 3f6c228f..6020b2ab 100644 --- a/ansi-tests/copy-symbol.lsp +++ b/ansi-tests/copy-symbol.lsp @@ -9,15 +9,15 @@ (notnot-mv (every #'(lambda (x) - (let ((y (copy-symbol x))) - (and (null (symbol-plist y)) - (symbolp y) - (not (boundp y)) - (not (fboundp y)) - (null (symbol-package y)) - (string= (symbol-name x) (symbol-name y)) - (symbolp (copy-symbol y)) - ))) + (let ((y (copy-symbol x))) + (and (null (symbol-plist y)) + (symbolp y) + (not (boundp y)) + (not (fboundp y)) + (null (symbol-package y)) + (string= (symbol-name x) (symbol-name y)) + (symbolp (copy-symbol y)) + ))) '(nil t a b |a| |123|))) t) @@ -28,17 +28,17 @@ (notnot-mv (every #'(lambda (x) - (let ((y (copy-symbol x t))) - (and - (equal (symbol-plist y) (symbol-plist x)) - (symbolp y) - (if (boundp x) - (boundp y) - (not (boundp y))) - (if (fboundp x) (fboundp y) (not (fboundp y))) - (null (symbol-package y)) - (string= (symbol-name x) (symbol-name y)) - ))) + (let ((y (copy-symbol x t))) + (and + (equal (symbol-plist y) (symbol-plist x)) + (symbolp y) + (if (boundp x) + (boundp y) + (not (boundp y))) + (if (fboundp x) (fboundp y) (not (fboundp y))) + (null (symbol-package y)) + (string= (symbol-name x) (symbol-name y)) + ))) '(nil t a b |foo| |a| |123|)))) t) @@ -49,23 +49,23 @@ (notnot-mv (every #'(lambda (x) - (let ((y (copy-symbol x t))) - (and - (eql (length (symbol-plist y)) - (length (symbol-plist x))) - ;; Is a list copy - (every #'eq (symbol-plist y) (symbol-plist x)) - (symbolp y) - (if (boundp x) - (eqt (symbol-value x) - (symbol-value y)) - (not (boundp y))) - (if (fboundp x) (fboundp y) (not (fboundp y))) - (null (symbol-package y)) - (string= (symbol-name x) (symbol-name y)) - (eql (length (symbol-plist x)) - (length (symbol-plist y))) - ))) + (let ((y (copy-symbol x t))) + (and + (eql (length (symbol-plist y)) + (length (symbol-plist x))) + ;; Is a list copy + (every #'eq (symbol-plist y) (symbol-plist x)) + (symbolp y) + (if (boundp x) + (eqt (symbol-value x) + (symbol-value y)) + (not (boundp y))) + (if (fboundp x) (fboundp y) (not (fboundp y))) + (null (symbol-package y)) + (string= (symbol-name x) (symbol-name y)) + (eql (length (symbol-plist x)) + (length (symbol-plist y))) + ))) '(nil t a b |foo| |a| |123|)))) t) @@ -76,8 +76,8 @@ (deftest copy-symbol.5 (let ((i 0) x y (s '#:|x|)) (let ((s2 (copy-symbol - (progn (setf x (incf i)) s) - (progn (setf y (incf i)) nil)))) + (progn (setf x (incf i)) s) + (progn (setf y (incf i)) nil)))) (values (symbol-name s2) (eq s s2) diff --git a/ansi-tests/copy-tree.lsp b/ansi-tests/copy-tree.lsp index 1c6ad0e7..8dd04243 100644 --- a/ansi-tests/copy-tree.lsp +++ b/ansi-tests/copy-tree.lsp @@ -10,20 +10,20 @@ ;; Try copy-tree on a tree containing elements of various kinds (deftest copy-tree.1 (let* ((x (cons 'a (list - (cons 'b 'c) - (cons 1 1.2) - (list (list "abcde" - (make-array '(10) :initial-element - (cons 'e 'f))) - 'g)))) - (y (copy-tree x))) + (cons 'b 'c) + (cons 1 1.2) + (list (list "abcde" + (make-array '(10) :initial-element + (cons 'e 'f))) + 'g)))) + (y (copy-tree x))) (check-cons-copy x y)) t) ;; Try copy-tree on *universe* (deftest copy-tree.2 (let* ((x (copy-list *universe*)) - (y (copy-tree x))) + (y (copy-tree x))) (check-cons-copy x y)) t) diff --git a/ansi-tests/cos.lsp b/ansi-tests/cos.lsp index 3cd38f6d..6d86e499 100644 --- a/ansi-tests/cos.lsp +++ b/ansi-tests/cos.lsp @@ -7,51 +7,51 @@ (deftest cos.1 (loop for i from -1000 to 1000 - for rlist = (multiple-value-list (cos i)) - for y = (car rlist) - always (and (null (cdr rlist)) - (<= -1 y 1) - (or (rationalp y) (typep y 'single-float)))) + for rlist = (multiple-value-list (cos i)) + for y = (car rlist) + always (and (null (cdr rlist)) + (<= -1 y 1) + (or (rationalp y) (typep y 'single-float)))) t) (deftest cos.2 (loop for x = (- (random 2000.0s0) 1000.0s0) - for rlist = (multiple-value-list (cos x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'short-float))) + for rlist = (multiple-value-list (cos x)) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (<= -1 y 1) + (typep y 'short-float))) t) (deftest cos.3 (loop for x = (- (random 2000.0f0) 1000.0f0) - for rlist = (multiple-value-list (cos x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'single-float))) + for rlist = (multiple-value-list (cos x)) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (<= -1 y 1) + (typep y 'single-float))) t) (deftest cos.4 (loop for x = (- (random 2000.0d0) 1000.0d0) - for rlist = (multiple-value-list (cos x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'double-float))) + for rlist = (multiple-value-list (cos x)) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (<= -1 y 1) + (typep y 'double-float))) t) (deftest cos.5 (loop for x = (- (random 2000.0l0) 1000.0l0) - for rlist = (multiple-value-list (cos x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'long-float))) + for rlist = (multiple-value-list (cos x)) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (<= -1 y 1) + (typep y 'long-float))) t) (deftest cos.6 @@ -77,8 +77,8 @@ (deftest cos.11 (loop for i from 1 to 100 - unless (approx= (cos i) (cos (coerce i 'single-float))) - collect i) + unless (approx= (cos i) (cos (coerce i 'single-float))) + collect i) nil) (deftest cos.12 @@ -115,42 +115,42 @@ (deftest cos.20 (loop for r = (- (random 2000) 1000) - for i = (- (random 20) 10) - for y = (cos (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20) 10) + for y = (cos (complex r i)) + repeat 1000 + always (numberp y)) t) (deftest cos.21 (loop for r = (- (random 2000.0s0) 1000.0s0) - for i = (- (random 20.0s0) 10.0s0) - for y = (cos (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20.0s0) 10.0s0) + for y = (cos (complex r i)) + repeat 1000 + always (numberp y)) t) (deftest cos.22 (loop for r = (- (random 2000.0f0) 1000.0f0) - for i = (- (random 20.0f0) 10.0f0) - for y = (cos (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20.0f0) 10.0f0) + for y = (cos (complex r i)) + repeat 1000 + always (numberp y)) t) (deftest cos.23 (loop for r = (- (random 2000.0d0) 1000.0d0) - for i = (- (random 20.0d0) 10.0d0) - for y = (cos (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20.0d0) 10.0d0) + for y = (cos (complex r i)) + repeat 1000 + always (numberp y)) t) (deftest cos.24 (loop for r = (- (random 2000.0l0) 1000.0l0) - for i = (- (random 20.0l0) 10.0l0) - for y = (cos (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20.0l0) 10.0l0) + for y = (cos (complex r i)) + repeat 1000 + always (numberp y)) t) ;;; FIXME diff --git a/ansi-tests/cosh.lsp b/ansi-tests/cosh.lsp index 60b07581..60d6b7a4 100644 --- a/ansi-tests/cosh.lsp +++ b/ansi-tests/cosh.lsp @@ -8,64 +8,64 @@ (deftest cosh.1 (let ((result (cosh 0))) (or (eqlt result 1) - (eqlt result 1.0))) + (eqlt result 1.0))) t) (deftest cosh.2 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - for one = (coerce 1 type) - unless (equal (multiple-value-list (cosh zero)) - (list one)) - collect type) + for zero = (coerce 0 type) + for one = (coerce 1 type) + unless (equal (multiple-value-list (cosh zero)) + (list one)) + collect type) nil) (deftest cosh.3 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 `(complex ,type)) - for one = (coerce 1 `(complex ,type)) - unless (equal (multiple-value-list (cosh zero)) - (list one)) - collect type) + for zero = (coerce 0 `(complex ,type)) + for one = (coerce 1 `(complex ,type)) + unless (equal (multiple-value-list (cosh zero)) + (list one)) + collect type) nil) (deftest cosh.4 (loop for den = (1+ (random 10000)) - for num = (random (* 10 den)) - for x = (/ num den) - for rlist = (multiple-value-list (cosh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (numberp y)) - collect (list x rlist)) + for num = (random (* 10 den)) + for x = (/ num den) + for rlist = (multiple-value-list (cosh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (numberp y)) + collect (list x rlist)) nil) (deftest cosh.5 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (cosh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) + nconc + (loop + for x = (- (random (coerce 20 type)) 10) + for rlist = (multiple-value-list (cosh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y type)) + collect (list x rlist))) nil) (deftest cosh.6 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 20 type)) 10) - for x2 = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (cosh (complex x1 x2))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 x2 rlist))) + nconc + (loop + for x1 = (- (random (coerce 20 type)) 10) + for x2 = (- (random (coerce 20 type)) 10) + for rlist = (multiple-value-list (cosh (complex x1 x2))) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y `(complex ,type))) + collect (list x1 x2 rlist))) nil) ;;; FIXME @@ -89,7 +89,7 @@ - - - + + + diff --git a/ansi-tests/count-if-not.lsp b/ansi-tests/count-if-not.lsp index ecab1f7e..a2f7dfd6 100644 --- a/ansi-tests/count-if-not.lsp +++ b/ansi-tests/count-if-not.lsp @@ -44,38 +44,38 @@ (deftest count-if-not-list.11 (let ((c 0)) (count-if-not #'oddp '(1 2 3 4 4 1 8 10 1) - :key #'(lambda (x) (+ x (incf c))))) + :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-not-list.12 (let ((c 0)) (count-if-not #'oddp '(0 1 2 3 4 4 1 7 10 1) - :from-end t - :key #'(lambda (x) (+ x (incf c))))) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-not-list.13 (count-if-not #'(lambda (x) (not (eqt x 'a))) - '(a b c d a e f a e f f a a) :start 2) + '(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-not-list.14 (count-if-not #'(lambda (x) (not (eqt x 'a))) - '(a b c d a e f a e f f a a) :end 7) + '(a b c d a e f a e f f a a) :end 7) 2) - + (deftest count-if-not-list.15 (count-if-not #'(lambda (x) (not (eqt x 'a))) - '(a b c d a e f a e f f a a) :end 7 - :start 2) + '(a b c d a e f a e f f a a) :end 7 + :start 2) 1) - + (deftest count-if-not-list.16 (count-if-not #'(lambda (x) (not (eqt x 'a))) - '(a b c d a e f a e f f a a) :end 7 - :start 2 :from-end t) + '(a b c d a e f a e f f a a) :end 7 + :start 2 :from-end t) 1) - + ;;; tests on vectors @@ -118,157 +118,157 @@ (deftest count-if-not-vector.11 (let ((c 0)) (count-if-not #'oddp #(1 2 3 4 4 1 8 10 1) - :key #'(lambda (x) (+ x (incf c))))) + :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-not-vector.12 (let ((c 0)) (count-if-not #'oddp #(0 1 2 3 4 4 1 7 10 1) - :from-end t - :key #'(lambda (x) (+ x (incf c))))) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-not-vector.13 (count-if-not #'(lambda (x) (not (eqt x 'a))) - #(a b c d a e f a e f f a a) :start 2) + #(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-not-vector.14 (count-if-not #'(lambda (x) (not (eqt x 'a))) - #(a b c d a e f a e f f a a) :end 7) + #(a b c d a e f a e f f a a) :end 7) 2) - + (deftest count-if-not-vector.15 (count-if-not #'(lambda (x) (not (eqt x 'a))) - #(a b c d a e f a e f f a a) :end 7 - :start 2) + #(a b c d a e f a e f f a a) :end 7 + :start 2) 1) - + (deftest count-if-not-vector.16 (count-if-not #'(lambda (x) (not (eqt x 'a))) - #(a b c d a e f a e f f a a) :end 7 - :start 2 :from-end t) + #(a b c d a e f a e f f a a) :end 7 + :start 2 :from-end t) 1) ;;; Non-simple vectors (deftest count-if-not-nonsimple-vector.1 (count-if-not #'identity (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t)) + :fill-pointer t + :adjustable t)) 2) (deftest count-if-not-nonsimple-vector.2 (count-if-not #'not (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t)) + :fill-pointer t + :adjustable t)) 5) (deftest count-if-not-nonsimple-vector.3 (count-if-not #'(lambda (x) (break)) (make-array 0 - :fill-pointer t - :adjustable t)) + :fill-pointer t + :adjustable t)) 0) (deftest count-if-not-nonsimple-vector.4 (count-if-not #'not - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key #'identity) + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key #'identity) 5) (deftest count-if-not-nonsimple-vector.5 (count-if-not 'not - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key #'identity) + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key #'identity) 5) (deftest count-if-not-nonsimple-vector.6 (count-if-not #'not - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key 'identity) + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key 'identity) 5) (deftest count-if-not-nonsimple-vector.8 (count-if-not #'not - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key 'not) + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key 'not) 2) (deftest count-if-not-nonsimple-vector.9 (count-if-not #'oddp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) - :fill-pointer t :adjustable t)) + :fill-pointer t :adjustable t)) 5) (deftest count-if-not-nonsimple-vector.10 (count-if-not #'oddp - (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) - :fill-pointer t :adjustable t) - :key #'1+) + (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t) + :key #'1+) 4) (deftest count-if-not-nonsimple-vector.11 (let ((c 0)) (count-if-not #'oddp - (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) - :fill-pointer t :adjustable t) - :key #'(lambda (x) (+ x (incf c))))) + (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t) + :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-not-nonsimple-vector.12 (let ((c 0)) (count-if-not #'oddp - (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) - :fill-pointer t :adjustable t) - :from-end t - :key #'(lambda (x) (+ x (incf c))))) + (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) + :fill-pointer t :adjustable t) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-not-nonsimple-vector.13 (count-if-not #'(lambda (x) (not (eqt x 'a))) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :start 2) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :start 2) 4) (deftest count-if-not-nonsimple-vector.14 (count-if-not #'(lambda (x) (not (eqt x 'a))) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :end 7) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7) 2) - + (deftest count-if-not-nonsimple-vector.15 (count-if-not #'(lambda (x) (not (eqt x 'a))) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :end 7 :start 2) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7 :start 2) 1) - + (deftest count-if-not-nonsimple-vector.16 (count-if-not #'(lambda (x) (not (eqt x 'a))) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :end 7 :start 2 :from-end t) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7 :start 2 :from-end t) 1) (deftest count-if-not-nonsimple-vector.17 (flet ((%a (c) (not (eqt c 'a))) - (%f (c) (not (eqt c 'f)))) + (%f (c) (not (eqt c 'f)))) (let ((a (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer 9))) + :fill-pointer 9))) (values (count-if-not #'%a a) - (count-if-not #'%a a :from-end t) - (count-if-not #'%f a) - (count-if-not #'%f a :from-end t) - ))) + (count-if-not #'%a a :from-end t) + (count-if-not #'%f a) + (count-if-not #'%f a :from-end t) + ))) 3 3 1 1) ;;; Other special vectors @@ -293,23 +293,23 @@ (deftest count-if-not.special-vector.3 (loop for etype in '(short-float single-float double-float long-float) - for vals = (loop for e in '(0 1 2 1 3 0 4 5 6 0) - collect (coerce e etype)) - for vec = (make-array (length vals) :element-type etype :initial-contents vals) - for result = (count-if-not #'zerop vec) - unless (= result 7) - collect (list etype vals vec result)) + for vals = (loop for e in '(0 1 2 1 3 0 4 5 6 0) + collect (coerce e etype)) + for vec = (make-array (length vals) :element-type etype :initial-contents vals) + for result = (count-if-not #'zerop vec) + unless (= result 7) + collect (list etype vals vec result)) nil) (deftest count-if-not.special-vector.4 (loop for cetype in '(short-float single-float double-float long-float integer rational) - for etype = `(complex ,cetype) - for vals = (loop for e in '(6 1 2 1 3 -4 4 5 6 100) - collect (complex 0 (coerce e cetype))) - for vec = (make-array (length vals) :element-type etype :initial-contents vals) - for result = (count-if-not #'(lambda (x) (< (abs x) 5/2)) vec) - unless (= result 7) - collect (list etype vals vec result)) + for etype = `(complex ,cetype) + for vals = (loop for e in '(6 1 2 1 3 -4 4 5 6 100) + collect (complex 0 (coerce e cetype))) + for vec = (make-array (length vals) :element-type etype :initial-contents vals) + for result = (count-if-not #'(lambda (x) (< (abs x) 5/2)) vec) + unless (= result 7) + collect (list etype vals vec result)) nil) @@ -350,14 +350,14 @@ (deftest count-if-not-bit-vector.11 (let ((c 0)) (count-if-not #'oddp #*001011101101 - :key #'(lambda (x) (+ x (incf c))))) + :key #'(lambda (x) (+ x (incf c))))) 7) (deftest count-if-not-bit-vector.12 (let ((c 0)) (count-if-not #'oddp #*001011101101 - :from-end t - :key #'(lambda (x) (+ x (incf c))))) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) 5) (deftest count-if-not-bit-vector.13 @@ -367,24 +367,24 @@ (deftest count-if-not-bit-vector.14 (count-if-not #'zerop #*0111011011100 :end 7) 5) - + (deftest count-if-not-bit-vector.15 (count-if-not #'zerop #*0111011011100 :end 7 :start 2) 4) - + (deftest count-if-not-bit-vector.16 (count-if-not #'zerop #*0111011011100 :end 7 :start 2 :from-end t) 4) (deftest count-if-not-bit-vector.17 (let ((a (make-array '(10) :initial-contents '(0 0 0 1 1 1 0 1 0 0) - :fill-pointer 5 - :element-type 'bit))) + :fill-pointer 5 + :element-type 'bit))) (and (bit-vector-p a) - (values (count-if-not #'zerop a) - (count-if-not #'oddp a) - (count-if-not #'zerop a :from-end t) - (count-if-not #'oddp a :from-end t)))) + (values (count-if-not #'zerop a) + (count-if-not #'oddp a) + (count-if-not #'zerop a :from-end t) + (count-if-not #'oddp a :from-end t)))) 2 3 2 3) ;;; tests on strings @@ -420,14 +420,14 @@ (deftest count-if-not-string.11 (let ((c 0)) (count-if-not #'oddp "001011101101" - :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) + :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) 7) (deftest count-if-not-string.12 (let ((c 0)) (count-if-not #'oddp "001011101101" - :from-end t - :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) + :from-end t + :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) 5) (deftest count-if-not-string.13 @@ -437,27 +437,27 @@ (deftest count-if-not-string.14 (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7) 5) - + (deftest count-if-not-string.15 (count-if-not #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2) 4) - + (deftest count-if-not-string.16 (count-if-not #'(lambda (x) (eql x #\0)) - "0111011011100" :end 7 :start 2 :from-end t) + "0111011011100" :end 7 :start 2 :from-end t) 4) (deftest count-if-not-string.17 (flet ((%zerop (c) (eql c #\0)) - (%onep (c) (eql c #\1))) + (%onep (c) (eql c #\1))) (let ((a (make-array '(10) :initial-contents "0001110100" - :fill-pointer 5 - :element-type 'character))) + :fill-pointer 5 + :element-type 'character))) (and (stringp a) - (values (count-if-not #'%zerop a) - (count-if-not #'%onep a) - (count-if-not #'%zerop a :from-end t) - (count-if-not #'%onep a :from-end t))))) + (values (count-if-not #'%zerop a) + (count-if-not #'%onep a) + (count-if-not #'%zerop a :from-end t) + (count-if-not #'%onep a :from-end t))))) 2 3 2 3) (deftest count-if-not-string.18 @@ -509,9 +509,9 @@ ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest count-if-not.keywords.3 (count-if-not #'oddp '(1 2 3 4 5) - :allow-other-keys t - :allow-other-keys nil - :bad t) + :allow-other-keys t + :allow-other-keys nil + :bad t) 2) (deftest count-if-not.keywords.4 @@ -542,7 +542,7 @@ (deftest count-if-not.error.7 (signals-error (count-if-not #'null nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest count-if-not.error.8 @@ -556,14 +556,14 @@ ;;; Only leftmost :allow-other-keys argument matters (deftest count-if-not.error.10 (signals-error (count-if-not #'null nil :bad t - :allow-other-keys nil - :allow-other-keys t) - program-error) + :allow-other-keys nil + :allow-other-keys t) + program-error) t) (deftest count-if-not.error.11 (signals-error (locally (count-if-not #'identity 1) t) - type-error) + type-error) t) (deftest count-if-not.error.12 @@ -576,10 +576,10 @@ (deftest count-if-not.error.14 (signals-error (count-if-not #'identity '(a b c) :key #'cdr) - type-error) + type-error) t) (deftest count-if-not.error.15 (signals-error (count-if-not #'identity '(a b c) :key #'cons) - program-error) + program-error) t) diff --git a/ansi-tests/count-if.lsp b/ansi-tests/count-if.lsp index 9558dbf6..26d62c13 100644 --- a/ansi-tests/count-if.lsp +++ b/ansi-tests/count-if.lsp @@ -44,38 +44,38 @@ (deftest count-if-list.11 (let ((c 0)) (count-if #'evenp '(1 2 3 4 4 1 8 10 1) - :key #'(lambda (x) (+ x (incf c))))) + :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-list.12 (let ((c 0)) (count-if #'evenp '(0 1 2 3 4 4 1 7 10 1) - :from-end t - :key #'(lambda (x) (+ x (incf c))))) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-list.13 (count-if #'(lambda (x) (eqt x 'a)) - '(a b c d a e f a e f f a a) :start 2) + '(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-list.14 (count-if #'(lambda (x) (eqt x 'a)) - '(a b c d a e f a e f f a a) :end 7) + '(a b c d a e f a e f f a a) :end 7) 2) - + (deftest count-if-list.15 (count-if #'(lambda (x) (eqt x 'a)) - '(a b c d a e f a e f f a a) :end 7 - :start 2) + '(a b c d a e f a e f f a a) :end 7 + :start 2) 1) - + (deftest count-if-list.16 (count-if #'(lambda (x) (eqt x 'a)) - '(a b c d a e f a e f f a a) :end 7 - :start 2 :from-end t) + '(a b c d a e f a e f f a a) :end 7 + :start 2 :from-end t) 1) - + ;;; tests on vectors @@ -118,157 +118,157 @@ (deftest count-if-vector.11 (let ((c 0)) (count-if #'evenp #(1 2 3 4 4 1 8 10 1) - :key #'(lambda (x) (+ x (incf c))))) + :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-vector.12 (let ((c 0)) (count-if #'evenp #(0 1 2 3 4 4 1 7 10 1) - :from-end t - :key #'(lambda (x) (+ x (incf c))))) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-vector.13 (count-if #'(lambda (x) (eqt x 'a)) - #(a b c d a e f a e f f a a) :start 2) + #(a b c d a e f a e f f a a) :start 2) 4) (deftest count-if-vector.14 (count-if #'(lambda (x) (eqt x 'a)) - #(a b c d a e f a e f f a a) :end 7) + #(a b c d a e f a e f f a a) :end 7) 2) - + (deftest count-if-vector.15 (count-if #'(lambda (x) (eqt x 'a)) - #(a b c d a e f a e f f a a) :end 7 - :start 2) + #(a b c d a e f a e f f a a) :end 7 + :start 2) 1) - + (deftest count-if-vector.16 (count-if #'(lambda (x) (eqt x 'a)) - #(a b c d a e f a e f f a a) :end 7 - :start 2 :from-end t) + #(a b c d a e f a e f f a a) :end 7 + :start 2 :from-end t) 1) ;;; Non-simple vectors (deftest count-if-nonsimple-vector.1 (count-if #'identity (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t)) + :fill-pointer t + :adjustable t)) 5) (deftest count-if-nonsimple-vector.2 (count-if #'not (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t)) + :fill-pointer t + :adjustable t)) 2) (deftest count-if-nonsimple-vector.3 (count-if #'(lambda (x) (break)) (make-array 0 - :fill-pointer t - :adjustable t)) + :fill-pointer t + :adjustable t)) 0) (deftest count-if-nonsimple-vector.4 (count-if #'identity - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key #'identity) + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key #'identity) 5) (deftest count-if-nonsimple-vector.5 (count-if 'identity - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key #'identity) + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key #'identity) 5) (deftest count-if-nonsimple-vector.6 (count-if #'identity - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key 'identity) + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key 'identity) 5) (deftest count-if-nonsimple-vector.8 (count-if #'identity - (make-array 7 :initial-contents '(a b nil c d nil e) - :fill-pointer t - :adjustable t) - :key 'not) + (make-array 7 :initial-contents '(a b nil c d nil e) + :fill-pointer t + :adjustable t) + :key 'not) 2) (deftest count-if-nonsimple-vector.9 (count-if #'evenp (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) - :fill-pointer t :adjustable t)) + :fill-pointer t :adjustable t)) 5) (deftest count-if-nonsimple-vector.10 (count-if #'evenp - (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) - :fill-pointer t :adjustable t) - :key #'1+) + (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t) + :key #'1+) 4) (deftest count-if-nonsimple-vector.11 (let ((c 0)) (count-if #'evenp - (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) - :fill-pointer t :adjustable t) - :key #'(lambda (x) (+ x (incf c))))) + (make-array 9 :initial-contents '(1 2 3 4 4 1 8 10 1) + :fill-pointer t :adjustable t) + :key #'(lambda (x) (+ x (incf c))))) 6) (deftest count-if-nonsimple-vector.12 (let ((c 0)) (count-if #'evenp - (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) - :fill-pointer t :adjustable t) - :from-end t - :key #'(lambda (x) (+ x (incf c))))) + (make-array 10 :initial-contents '(0 1 2 3 4 4 1 7 10 1) + :fill-pointer t :adjustable t) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) 8) (deftest count-if-nonsimple-vector.13 (count-if #'(lambda (x) (eqt x 'a)) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :start 2) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :start 2) 4) (deftest count-if-nonsimple-vector.14 (count-if #'(lambda (x) (eqt x 'a)) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :end 7) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7) 2) - + (deftest count-if-nonsimple-vector.15 (count-if #'(lambda (x) (eqt x 'a)) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :end 7 :start 2) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7 :start 2) 1) - + (deftest count-if-nonsimple-vector.16 (count-if #'(lambda (x) (eqt x 'a)) - (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer t :adjustable t) - :end 7 :start 2 :from-end t) + (make-array 13 :initial-contents '(a b c d a e f a e f f a a) + :fill-pointer t :adjustable t) + :end 7 :start 2 :from-end t) 1) (deftest count-if-nonsimple-vector.17 (flet ((%f (x) (eqt x 'a))) (let ((s (make-array 13 :initial-contents '(a b c d a e f a e f f a a) - :fill-pointer 6))) + :fill-pointer 6))) (values (count-if #'%f s) - (count-if #'%f s :end nil) - (count-if #'%f s :end 4) - (count-if #'%f s :start 1) - (count-if #'%f s :start 1 :end 4) - (count-if #'%f s :start 1 :end 4 :from-end t)))) + (count-if #'%f s :end nil) + (count-if #'%f s :end 4) + (count-if #'%f s :start 1) + (count-if #'%f s :start 1 :end 4) + (count-if #'%f s :start 1 :end 4 :from-end t)))) 2 2 1 1 0 0) ;;; Other special vectors @@ -293,23 +293,23 @@ (deftest count-if.special-vector.3 (loop for etype in '(short-float single-float double-float long-float) - for vals = (loop for e in '(0 1 2 1 3 0 4 5 6 0) - collect (coerce e etype)) - for vec = (make-array (length vals) :element-type etype :initial-contents vals) - for result = (count-if #'zerop vec) - unless (= result 3) - collect (list etype vals vec result)) + for vals = (loop for e in '(0 1 2 1 3 0 4 5 6 0) + collect (coerce e etype)) + for vec = (make-array (length vals) :element-type etype :initial-contents vals) + for result = (count-if #'zerop vec) + unless (= result 3) + collect (list etype vals vec result)) nil) (deftest count-if.special-vector.4 (loop for cetype in '(short-float single-float double-float long-float integer rational) - for etype = `(complex ,cetype) - for vals = (loop for e in '(6 1 2 1 3 -4 4 5 6 100) - collect (complex 0 (coerce e cetype))) - for vec = (make-array (length vals) :element-type etype :initial-contents vals) - for result = (count-if #'(lambda (x) (< (abs x) 5/2)) vec) - unless (= result 3) - collect (list etype vals vec result)) + for etype = `(complex ,cetype) + for vals = (loop for e in '(6 1 2 1 3 -4 4 5 6 100) + collect (complex 0 (coerce e cetype))) + for vec = (make-array (length vals) :element-type etype :initial-contents vals) + for result = (count-if #'(lambda (x) (< (abs x) 5/2)) vec) + unless (= result 3) + collect (list etype vals vec result)) nil) @@ -350,14 +350,14 @@ (deftest count-if-bit-vector.11 (let ((c 0)) (count-if #'evenp #*001011101101 - :key #'(lambda (x) (+ x (incf c))))) + :key #'(lambda (x) (+ x (incf c))))) 7) (deftest count-if-bit-vector.12 (let ((c 0)) (count-if #'evenp #*001011101101 - :from-end t - :key #'(lambda (x) (+ x (incf c))))) + :from-end t + :key #'(lambda (x) (+ x (incf c))))) 5) (deftest count-if-bit-vector.13 @@ -367,24 +367,24 @@ (deftest count-if-bit-vector.14 (count-if #'zerop #*0111011011100 :end 7) 2) - + (deftest count-if-bit-vector.15 (count-if #'zerop #*0111011011100 :end 7 :start 2) 1) - + (deftest count-if-bit-vector.16 (count-if #'zerop #*0111011011100 :end 7 :start 2 :from-end t) 1) (deftest count-if-bit-vector.17 (let ((s (make-array '(10) :initial-contents '(0 0 1 0 1 0 0 1 1 0) - :element-type 'bit - :fill-pointer 6))) + :element-type 'bit + :fill-pointer 6))) (values (count-if #'zerop s) - (count-if #'zerop s :end nil) - (count-if #'zerop s :end 4) - (count-if #'zerop s :start 5) - (count-if #'zerop s :start 1 :end 4))) + (count-if #'zerop s :end nil) + (count-if #'zerop s :end 4) + (count-if #'zerop s :start 5) + (count-if #'zerop s :start 1 :end 4))) 4 4 3 1 2) ;;; tests on strings @@ -420,14 +420,14 @@ (deftest count-if-string.11 (let ((c 0)) (count-if #'evenp "001011101101" - :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) + :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) 7) (deftest count-if-string.12 (let ((c 0)) (count-if #'evenp "001011101101" - :from-end t - :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) + :from-end t + :key #'(lambda (x) (+ (if (eql x #\0) 0 1) (incf c))))) 5) (deftest count-if-string.13 @@ -437,26 +437,26 @@ (deftest count-if-string.14 (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7) 2) - + (deftest count-if-string.15 (count-if #'(lambda (x) (eql x #\0)) "0111011011100" :end 7 :start 2) 1) - + (deftest count-if-string.16 (count-if #'(lambda (x) (eql x #\0)) - "0111011011100" :end 7 :start 2 :from-end t) + "0111011011100" :end 7 :start 2 :from-end t) 1) (deftest count-if-string.17 (let ((s (make-array '(10) - :initial-contents "00a0aa0a0a" - :element-type 'character - :fill-pointer 6))) + :initial-contents "00a0aa0a0a" + :element-type 'character + :fill-pointer 6))) (values (count-if #'digit-char-p s) - (count-if #'digit-char-p s :end nil) - (count-if #'digit-char-p s :start 1) - (count-if #'digit-char-p s :end 2) - (count-if #'digit-char-p s :start 1 :end 2))) + (count-if #'digit-char-p s :end nil) + (count-if #'digit-char-p s :start 1) + (count-if #'digit-char-p s :end 2) + (count-if #'digit-char-p s :start 1 :end 2))) 3 3 2 2 1) (deftest count-if-string.18 @@ -471,12 +471,12 @@ (let ((i 0) c1 c2 c3 c4 c5 c6) (values (count-if (progn (setf c1 (incf i)) #'null) - (progn (setf c2 (incf i)) '(a nil b c nil d e)) - :start (progn (setf c3 (incf i)) 0) - :end (progn (setf c4 (incf i)) 3) - :key (progn (setf c5 (incf i)) #'identity) - :from-end (progn (setf c6 (incf i)) nil) - ) + (progn (setf c2 (incf i)) '(a nil b c nil d e)) + :start (progn (setf c3 (incf i)) 0) + :end (progn (setf c4 (incf i)) 3) + :key (progn (setf c5 (incf i)) #'identity) + :from-end (progn (setf c6 (incf i)) nil) + ) i c1 c2 c3 c4 c5 c6)) 1 6 1 2 3 4 5 6) @@ -484,12 +484,12 @@ (let ((i 0) c1 c2 c3 c4 c5 c6) (values (count-if (progn (setf c1 (incf i)) #'null) - (progn (setf c2 (incf i)) '(a nil b c nil d e)) - :from-end (progn (setf c3 (incf i)) nil) - :key (progn (setf c4 (incf i)) #'identity) - :end (progn (setf c5 (incf i)) 3) - :start (progn (setf c6 (incf i)) 0) - ) + (progn (setf c2 (incf i)) '(a nil b c nil d e)) + :from-end (progn (setf c3 (incf i)) nil) + :key (progn (setf c4 (incf i)) #'identity) + :end (progn (setf c5 (incf i)) 3) + :start (progn (setf c6 (incf i)) 0) + ) i c1 c2 c3 c4 c5 c6)) 1 6 1 2 3 4 5 6) @@ -507,9 +507,9 @@ ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest count-if.allow-other-keys.3 (count-if #'evenp '(1 2 3 4 5) - :allow-other-keys t - :allow-other-keys nil - :bad t) + :allow-other-keys t + :allow-other-keys nil + :bad t) 2) (deftest count-if.keywords.4 @@ -520,12 +520,12 @@ (count-if #'evenp '(1 2 3 4 5) :allow-other-keys nil) 2) - + ;;; Error tests (deftest count-if.error.1 (check-type-error #'(lambda (x) (count-if #'identity x)) - #'sequencep) + #'sequencep) nil) (deftest count-if.error.4 @@ -542,7 +542,7 @@ (deftest count-if.error.7 (signals-error (count-if #'null nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest count-if.error.8 @@ -556,9 +556,9 @@ ;;; Only leftmost :allow-other-keys argument matters (deftest count-if.error.10 (signals-error (count-if #'null nil :bad t - :allow-other-keys nil - :allow-other-keys t) - program-error) + :allow-other-keys nil + :allow-other-keys t) + program-error) t) (deftest count-if.error.11 @@ -575,10 +575,10 @@ (deftest count-if.error.14 (signals-error (count-if #'identity '(a b c) :key #'cdr) - type-error) + type-error) t) (deftest count-if.error.15 (signals-error (count-if #'identity '(a b c) :key #'cons) - program-error) + program-error) t) diff --git a/ansi-tests/count.lsp b/ansi-tests/count.lsp index c2d87356..269c39a1 100644 --- a/ansi-tests/count.lsp +++ b/ansi-tests/count.lsp @@ -36,18 +36,18 @@ (deftest count-list.8 (let ((c 0)) (count 1 '(1 2 3 1 4 1 7 6 1 8) - :key #'(lambda (x) - ;; (format t "~%~A ~A" x c) - (prog1 (- x c) (incf c))))) + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) 4) (deftest count-list.9 (let ((c 0)) (count 1 '(1 2 3 7 4 5 7 6 2 8) - :from-end t - :key #'(lambda (x) - ;; (format t "~%~A ~A" x c) - (prog1 (- x c) (incf c))))) + :from-end t + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) 3) (deftest count-list.10 @@ -76,7 +76,7 @@ (deftest count-list.16 (count 1 '(1 1 1 3 1 2 1 1) :start 2 :end 7 - :test #'(lambda (x y) (declare (ignore x y)) t)) + :test #'(lambda (x y) (declare (ignore x y)) t)) 5) (deftest count-list.17 @@ -126,18 +126,18 @@ (deftest count-vector.8 (let ((c 0)) (count 1 #(1 2 3 1 4 1 7 6 1 8) - :key #'(lambda (x) - ;; (format t "~%~A ~A" x c) - (prog1 (- x c) (incf c))))) + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) 4) (deftest count-vector.9 (let ((c 0)) (count 1 #(1 2 3 7 4 5 7 6 2 8) - :from-end t - :key #'(lambda (x) - ;; (format t "~%~A ~A" x c) - (prog1 (- x c) (incf c))))) + :from-end t + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) 3) (deftest count-vector.10 @@ -166,7 +166,7 @@ (deftest count-vector.16 (count 1 #(1 1 1 3 1 2 1 1) :start 2 :end 7 - :test #'(lambda (x y) (declare (ignore x y)) t)) + :test #'(lambda (x y) (declare (ignore x y)) t)) 5) (deftest count-vector.17 @@ -187,127 +187,127 @@ (deftest count-filled-vector.1 (count 'a (make-array 8 :initial-contents '(a b c d e a e f) - :fill-pointer t)) + :fill-pointer t)) 2) (deftest count-filled-vector.2 (count 'a (make-array 8 :initial-contents '(a b c d e a e f) - :fill-pointer t) - :test #'eql) + :fill-pointer t) + :test #'eql) 2) (deftest count-filled-vector.3 (count 'a (make-array 8 :initial-contents '(a b c d e a e f) - :fill-pointer t) - :test 'eql) + :fill-pointer t) + :test 'eql) 2) (deftest count-filled-vector.4 (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) - :fill-pointer t) - :key #'1-) + :fill-pointer t) + :key #'1-) 5) (deftest count-filled-vector.5 (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) - :fill-pointer t) - :key '1-) + :fill-pointer t) + :key '1-) 5) (deftest count-filled-vector.6 (count 1 (make-array 10 :initial-contents '(1 2 2 3 2 1 2 2 5 4) - :fill-pointer t) - :key #'1- :test #'equal) + :fill-pointer t) + :key #'1- :test #'equal) 5) (deftest count-filled-vector.7 (count 1 (make-array 12 :initial-contents '(2 1 1 2 3 1 4 1 7 6 1 8) - :fill-pointer t) - :from-end t) + :fill-pointer t) + :from-end t) 5) (deftest count-filled-vector.8 (let ((c 0)) (count 1 (make-array 10 :initial-contents '(1 2 3 1 4 1 7 6 1 8) - :fill-pointer t) - :key #'(lambda (x) - ;; (format t "~%~A ~A" x c) - (prog1 (- x c) (incf c))))) + :fill-pointer t) + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) 4) (deftest count-filled-vector.9 (let ((c 0)) (count 1 (make-array 10 :initial-contents '(1 2 3 7 4 5 7 6 2 8) - :fill-pointer t) - :from-end t - :key #'(lambda (x) - ;; (format t "~%~A ~A" x c) - (prog1 (- x c) (incf c))))) + :fill-pointer t) + :from-end t + :key #'(lambda (x) + ;; (format t "~%~A ~A" x c) + (prog1 (- x c) (incf c))))) 3) (deftest count-filled-vector.10 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) - :fill-pointer t) - :start 3) + :fill-pointer t) + :start 3) 4) (deftest count-filled-vector.11 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) - :fill-pointer t) - :end 6) + :fill-pointer t) + :end 6) 5) (deftest count-filled-vector.12 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) - :fill-pointer t) - :start 2 :end 7) + :fill-pointer t) + :start 2 :end 7) 4) (deftest count-filled-vector.13 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) - :fill-pointer t) - :start 3 :end nil) + :fill-pointer t) + :start 3 :end nil) 4) (deftest count-filled-vector.14 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) - :fill-pointer t) - :end nil) + :fill-pointer t) + :end nil) 7) (deftest count-filled-vector.15 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 2 1 1) - :fill-pointer t) - :test-not #'eql) + :fill-pointer t) + :test-not #'eql) 1) (deftest count-filled-vector.16 (count 1 (make-array 8 :initial-contents '(1 1 1 3 1 2 1 1) - :fill-pointer t) - :start 2 :end 7 - :test #'(lambda (x y) (declare (ignore x y)) t)) + :fill-pointer t) + :start 2 :end 7 + :test #'(lambda (x y) (declare (ignore x y)) t)) 5) (deftest count-filled-vector.17 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) - :fill-pointer 6)) + :fill-pointer 6)) 6) (deftest count-filled-vector.18 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) - :fill-pointer 6) - :start 2) + :fill-pointer 6) + :start 2) 4) (deftest count-filled-vector.19 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) - :fill-pointer 6) - :from-end 'foo) + :fill-pointer 6) + :from-end 'foo) 6) (deftest count-filled-vector.20 (count 1 (make-array 8 :initial-contents '(1 1 1 1 1 1 1 1) - :fill-pointer 6) - :start 2 :from-end 'yes) + :fill-pointer 6) + :start 2 :from-end 'yes) 4) ;;; Other specialized vectors @@ -337,23 +337,23 @@ (deftest count.special-vector.3 (loop for etype in '(short-float single-float double-float long-float) - for vals = (loop for e in '(0 1 2 1 3 1 4 5 6 0) - collect (coerce e etype)) - for vec = (make-array (length vals) :element-type etype :initial-contents vals) - for result = (count (coerce 1 etype) vec) - unless (= result 3) - collect (list etype vals vec result)) + for vals = (loop for e in '(0 1 2 1 3 1 4 5 6 0) + collect (coerce e etype)) + for vec = (make-array (length vals) :element-type etype :initial-contents vals) + for result = (count (coerce 1 etype) vec) + unless (= result 3) + collect (list etype vals vec result)) nil) (deftest count.special-vector.4 (loop for cetype in '(short-float single-float double-float long-float rational integer) - for etype = `(complex ,cetype) - for vals = (loop for e in '(4 1 2 1 3 1 4 5 6 6) - collect (complex 0 (coerce e cetype))) - for vec = (make-array (length vals) :element-type etype :initial-contents vals) - for result = (count (complex 0 (coerce 1 cetype)) vec) - unless (= result 3) - collect (list etype vals vec result)) + for etype = `(complex ,cetype) + for vals = (loop for e in '(4 1 2 1 3 1 4 5 6 6) + collect (complex 0 (coerce e cetype))) + for vec = (make-array (length vals) :element-type etype :initial-contents vals) + for result = (count (complex 0 (coerce 1 cetype)) vec) + unless (= result 3) + collect (list etype vals vec result)) nil) @@ -391,14 +391,14 @@ (deftest count-bit-vector.8 (let ((c 1)) (count 0 #*0000110101001 - :key #'(lambda (x) (setf c (- c)) (+ c x)))) + :key #'(lambda (x) (setf c (- c)) (+ c x)))) 2) (deftest count-bit-vector.9 (let ((c 1)) (count 0 #*0000011010101 - :from-end t - :key #'(lambda (x) (setf c (- c)) (+ c x)))) + :from-end t + :key #'(lambda (x) (setf c (- c)) (+ c x)))) 4) (deftest count-bit-vector.10 @@ -427,35 +427,35 @@ (deftest count-bit-vector.16 (count 1 #*11101101 :start 2 :end 7 - :test #'(lambda (x y) (declare (ignore x y)) t)) + :test #'(lambda (x y) (declare (ignore x y)) t)) 5) (deftest count-bit-vector.17 (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) - :element-type 'bit - :fill-pointer 5)) + :element-type 'bit + :fill-pointer 5)) 4) (deftest count-bit-vector.18 (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) - :element-type 'bit - :fill-pointer 5) - :start 1) + :element-type 'bit + :fill-pointer 5) + :start 1) 3) (deftest count-bit-vector.19 (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) - :element-type 'bit - :fill-pointer 5) - :end nil) + :element-type 'bit + :fill-pointer 5) + :end nil) 4) (deftest count-bit-vector.20 (count 1 (make-array 8 :initial-contents '(1 0 1 1 1 1 1 1) - :element-type 'bit - :fill-pointer 6) - :end 4) + :element-type 'bit + :fill-pointer 6) + :end 4) 3) (deftest count-bit-vector.21 @@ -505,16 +505,16 @@ (deftest count-string.8 (let ((c nil)) (count #\0 "0000110101001" - :key #'(lambda (x) (setf c (not c)) - (and c x)))) + :key #'(lambda (x) (setf c (not c)) + (and c x)))) 5) (deftest count-string.9 (let ((c nil)) (count #\0 "0000011010101" - :from-end t - :key #'(lambda (x) (setf c (not c)) - (and c x)))) + :from-end t + :key #'(lambda (x) (setf c (not c)) + (and c x)))) 3) (deftest count-string.10 @@ -543,34 +543,34 @@ (deftest count-string.16 (count #\1 "11101101" :start 2 :end 7 - :test #'(lambda (x y) (declare (ignore x y)) t)) + :test #'(lambda (x y) (declare (ignore x y)) t)) 5) (deftest count-string.17 (count #\a (make-array 10 :initial-contents "abaaacaaaa" - :fill-pointer 7 - :element-type 'character)) + :fill-pointer 7 + :element-type 'character)) 5) (deftest count-string.18 (count #\a (make-array 10 :initial-contents "abaaacaaaa" - :fill-pointer 7 - :element-type 'character) - :start 1) + :fill-pointer 7 + :element-type 'character) + :start 1) 4) (deftest count-string.19 (count #\a (make-array 10 :initial-contents "abaaacaaaa" - :fill-pointer 7 - :element-type 'character) - :end nil) + :fill-pointer 7 + :element-type 'character) + :end nil) 5) (deftest count-string.20 (count #\a (make-array 10 :initial-contents "abaaacaaaa" - :fill-pointer 7 - :element-type 'character) - :start 2 :end 5) + :fill-pointer 7 + :element-type 'character) + :start 2 :end 5) 3) (deftest count-string.21 @@ -599,13 +599,13 @@ (let ((i 0) c1 c2 c3 c4 c5 c6 c7) (values (count (progn (setf c1 (incf i)) nil) - (progn (setf c2 (incf i)) '(a nil b c nil d e)) - :start (progn (setf c3 (incf i)) 0) - :end (progn (setf c4 (incf i)) 3) - :key (progn (setf c5 (incf i)) #'identity) - :from-end (progn (setf c6 (incf i)) nil) - :test (progn (setf c7 (incf i)) #'eql) - ) + (progn (setf c2 (incf i)) '(a nil b c nil d e)) + :start (progn (setf c3 (incf i)) 0) + :end (progn (setf c4 (incf i)) 3) + :key (progn (setf c5 (incf i)) #'identity) + :from-end (progn (setf c6 (incf i)) nil) + :test (progn (setf c7 (incf i)) #'eql) + ) i c1 c2 c3 c4 c5 c6 c7)) 1 7 1 2 3 4 5 6 7) @@ -613,13 +613,13 @@ (let ((i 0) c1 c2 c3 c4 c5 c6 c7) (values (count (progn (setf c1 (incf i)) nil) - (progn (setf c2 (incf i)) '(a nil b c nil d e)) - :test (progn (setf c3 (incf i)) #'eql) - :from-end (progn (setf c4 (incf i)) nil) - :key (progn (setf c5 (incf i)) #'identity) - :end (progn (setf c6 (incf i)) 3) - :start (progn (setf c7 (incf i)) 0) - ) + (progn (setf c2 (incf i)) '(a nil b c nil d e)) + :test (progn (setf c3 (incf i)) #'eql) + :from-end (progn (setf c4 (incf i)) nil) + :key (progn (setf c5 (incf i)) #'identity) + :end (progn (setf c6 (incf i)) 3) + :start (progn (setf c7 (incf i)) 0) + ) i c1 c2 c3 c4 c5 c6 c7)) 1 7 1 2 3 4 5 6 7) @@ -637,9 +637,9 @@ ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest count.allow-other-keys.3 (count 'a '(b a d a c) - :allow-other-keys t - :allow-other-keys nil - :bad t) + :allow-other-keys t + :allow-other-keys nil + :bad t) 2) (deftest count.keywords.4 @@ -670,7 +670,7 @@ (deftest count.error.7 (signals-error (count nil nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest count.error.8 @@ -684,9 +684,9 @@ ;;; Only leftmost :allow-other-keys argument matters (deftest count.error.10 (signals-error (count 'a nil :bad t - :allow-other-keys nil - :allow-other-keys t) - program-error) + :allow-other-keys nil + :allow-other-keys t) + program-error) t) (deftest count.error.11 @@ -695,7 +695,7 @@ (deftest count.error.12 (signals-error (count 'b '(a b c) :test #'identity) - program-error) + program-error) t) (deftest count.error.13 @@ -704,10 +704,10 @@ (deftest count.error.14 (signals-error (count 'b '(a b c) :test-not #'identity) - program-error) + program-error) t) (deftest count.error.15 (signals-error (count 'b '(a b c) :key #'cons) - program-error) + program-error) t) diff --git a/ansi-tests/ctypecase.lsp b/ansi-tests/ctypecase.lsp index e432cbc0..0bdc5cad 100644 --- a/ansi-tests/ctypecase.lsp +++ b/ansi-tests/ctypecase.lsp @@ -67,9 +67,9 @@ (values (handler-bind ((type-error #'(lambda (c) - (assert (eql (type-error-datum c) 1)) - (assert (not (typep 1 (type-error-expected-type c)))) - (store-value 'a c)))) + (assert (eql (type-error-datum c) 1)) + (assert (not (typep 1 (type-error-expected-type c)))) + (store-value 'a c)))) (ctypecase x (symbol :good) (float :bad))) @@ -84,8 +84,8 @@ (deftest ctypecase.13 (let ((x 'a)) (ctypecase x - (number 'bad) - (#.(find-class 'symbol nil) 'good))) + (number 'bad) + (#.(find-class 'symbol nil) 'good))) good) (deftest ctypecase.14 @@ -93,8 +93,8 @@ (tagbody (let ((x 'a)) (ctypecase x (symbol (go 10) - 10 - (return-from done 'bad)))) + 10 + (return-from done 'bad)))) 10 (return-from done 'good))) good) @@ -123,18 +123,18 @@ (deftest ctypecase.error.1 (signals-error (funcall (macro-function 'ctypecase)) - program-error) + program-error) t) (deftest ctypecase.error.2 (signals-error (funcall (macro-function 'ctypecase) - '(ctypecase t)) - program-error) + '(ctypecase t)) + program-error) t) (deftest ctypecase.error.3 (signals-error (funcall (macro-function 'ctypecase) - '(ctypecase t) - nil nil) - program-error) + '(ctypecase t) + nil nil) + program-error) t) diff --git a/ansi-tests/cxr.lsp b/ansi-tests/cxr.lsp index 7fe6e9fa..ae892d19 100644 --- a/ansi-tests/cxr.lsp +++ b/ansi-tests/cxr.lsp @@ -66,13 +66,13 @@ (defvar *cons-test-4* (cons (cons (cons (cons 'a 'b) - (cons 'c 'd)) - (cons (cons 'e 'f) - (cons 'g 'h))) - (cons (cons (cons 'i 'j) - (cons 'k 'l)) - (cons (cons 'm 'n) - (cons 'o 'p))))) + (cons 'c 'd)) + (cons (cons 'e 'f) + (cons 'g 'h))) + (cons (cons (cons 'i 'j) + (cons 'k 'l)) + (cons (cons 'm 'n) + (cons 'o 'p))))) (deftest cons.38 (caaaar *cons-test-4*) @@ -577,45 +577,45 @@ (loop for fn in '(car cdr caar cadr cdar cddr - caaar caadr cadar caddr cdaar cdadr cddar cdddr - caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr - cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) + caaar caadr cadar caddr cdaar cdadr cddar cdddr + caaaar caaadr caadar caaddr cadaar cadadr caddar cadddr + cdaaar cdaadr cdadar cdaddr cddaar cddadr cdddar cddddr) do (let ((level (- (length (symbol-name fn)) 2))) - (eval `(deftest ,(intern - (concatenate 'string - (symbol-name fn) - "-SET-ALT") - :cl-test) - (let ((x (create-c*r-test ,level))) - (and - (setf (,fn x) 'a) - (eql (,fn x) 'a) - (setf (,fn x) 'none) - (equalt x (create-c*r-test ,level)) - )) - t)))) + (eval `(deftest ,(intern + (concatenate 'string + (symbol-name fn) + "-SET-ALT") + :cl-test) + (let ((x (create-c*r-test ,level))) + (and + (setf (,fn x) 'a) + (eql (,fn x) 'a) + (setf (,fn x) 'none) + (equalt x (create-c*r-test ,level)) + )) + t)))) (loop for (fn len) in '((first 1) (second 2) (third 3) (fourth 4) - (fifth 5) (sixth 6) (seventh 7) (eighth 8) - (ninth 9) (tenth 10)) + (fifth 5) (sixth 6) (seventh 7) (eighth 8) + (ninth 9) (tenth 10)) do (eval `(deftest ,(intern - (concatenate 'string - (symbol-name fn) - "-SET-ALT") - :cl-test) - (let ((x (make-list 20 :initial-element nil))) - (and - (setf (,fn x) 'a) - (loop - for i from 1 to 20 - do (when (and (not (eql i ,len)) - (nth (1- i) x)) - (return nil)) - finally (return t)) - (eql (,fn x) 'a) - (nth ,(1- len) x))) - a))) + (concatenate 'string + (symbol-name fn) + "-SET-ALT") + :cl-test) + (let ((x (make-list 20 :initial-element nil))) + (and + (setf (,fn x) 'a) + (loop + for i from 1 to 20 + do (when (and (not (eql i ,len)) + (nth (1- i) x)) + (return nil)) + finally (return t)) + (eql (,fn x) 'a) + (nth ,(1- len) x))) + a))) diff --git a/ansi-tests/data-and-control-flow.lsp b/ansi-tests/data-and-control-flow.lsp index 86437dc3..adcd4290 100644 --- a/ansi-tests/data-and-control-flow.lsp +++ b/ansi-tests/data-and-control-flow.lsp @@ -8,9 +8,9 @@ ;;; Functions from section 5 (defparameter *dcf-fns* '(apply fboundp fmakunbound funcall function-lambda-expression - functionp compiled-function-p not eq eql equal equalp identity - complement constantly every some notevery notany - values-list get-setf-expansion)) + functionp compiled-function-p not eq eql equal equalp identity + complement constantly every some notevery notany + values-list get-setf-expansion)) ;;; Macros from section 5 (defparameter *dcf-macros* @@ -30,5 +30,5 @@ - - \ No newline at end of file + + diff --git a/ansi-tests/decf.lsp b/ansi-tests/decf.lsp index f74caa69..8a6b7da8 100644 --- a/ansi-tests/decf.lsp +++ b/ansi-tests/decf.lsp @@ -44,23 +44,23 @@ (deftest decf.6 (loop for x from 1 to 5 - collect (let ((y x)) - (list (decf y) y))) + collect (let ((y x)) + (list (decf y) y))) ((0 0) (1 1) (2 2) (3 3) (4 4))) (deftest decf.7 (loop for x in '(3.0s0 3.0f0 3.0d0 3.0l0) - collect (let ((y x)) - (list (decf y) y))) + collect (let ((y x)) + (list (decf y) y))) ((2.0s0 2.0s0) (2.0f0 2.0f0) (2.0d0 2.0d0) (2.0l0 2.0l0))) (deftest decf.8 (loop for x in '(3.0s0 3.0f0 3.0d0 3.0f0) - for y = (complex x 0) - for z = (decf y) - for x1c = (complex (1- x) 0) - unless (and (eql y z) (eql x1c y)) - collect (list x y z x1c)) + for y = (complex x 0) + for z = (decf y) + for x1c = (complex (1- x) 0) + unless (and (eql y z) (eql x1c y)) + collect (list x y z x1c)) nil) (deftest decf.9 @@ -75,31 +75,31 @@ (deftest decf.11 (loop for x in *numbers* - unless (let* ((y x) - (z (decf y))) - (and (eql y (1- x)) - (eql y z))) - collect x) + unless (let* ((y x) + (z (decf y))) + (and (eql y (1- x)) + (eql y z))) + collect x) nil) ;;; Increment by other than 1 (deftest decf.12 (loop for x in *numbers* - unless (let* ((y x) (z (decf y 0))) - (and (eql x y) (eql y z))) - collect x) + unless (let* ((y x) (z (decf y 0))) + (and (eql x y) (eql y z))) + collect x) nil) (deftest decf.13 (loop for x in *numbers* - nconc - (loop for r = (random-from-interval 1000000) - repeat 100 - when (let* ((y x) (z (decf y r))) - (and (not (and (eql (- x r) y) (eql y z))) - (list x y r))) - collect it)) + nconc + (loop for r = (random-from-interval 1000000) + repeat 100 + when (let* ((y x) (z (decf y r))) + (and (not (and (eql (- x r) y) (eql y z))) + (list x y r))) + collect it)) nil) (deftest decf.14 @@ -165,20 +165,20 @@ (deftest decf.order.2 (let ((a (vector 1 2 3 4)) - (i 0) x y z) + (i 0) x y z) (values (decf (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 0)) - (progn (setf z (incf i)) 17)) + (progn (setf y (incf i)) 0)) + (progn (setf z (incf i)) 17)) i x y z a)) -16 3 1 2 3 #(-16 2 3 4)) (deftest decf.order.3 (let ((a (vector 10 2 3 4)) - (i 0) x y) + (i 0) x y) (values (decf (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 0))) + (progn (setf y (incf i)) 0))) i x y a)) 9 2 1 2 #(9 2 3 4)) diff --git a/ansi-tests/declaim.lsp b/ansi-tests/declaim.lsp index 909491d0..f6406631 100644 --- a/ansi-tests/declaim.lsp +++ b/ansi-tests/declaim.lsp @@ -52,5 +52,5 @@ (let ((sym (gensym))) (eval `(declaim (optimize) (special ,sym) (inline) (special))) (eval `(flet ((%f () ,sym)) - (let ((,sym :good)) (%f))))) + (let ((,sym :good)) (%f))))) :good) diff --git a/ansi-tests/declaration.lsp b/ansi-tests/declaration.lsp index 70848387..09ca953f 100644 --- a/ansi-tests/declaration.lsp +++ b/ansi-tests/declaration.lsp @@ -16,7 +16,7 @@ (deftest declaration.3 (let ((sym (gensym)) - (sym2 (gensym))) + (sym2 (gensym))) (proclaim `(declaration ,sym ,sym2)) nil) nil) @@ -30,8 +30,8 @@ ;;; Declare these only if bad declarations produce warnings. (when (block done - (handler-bind ((warning #'(lambda (c) (return-from done t)))) - (eval `(let () (declare (,(gensym))) nil)))) + (handler-bind ((warning #'(lambda (c) (return-from done t)))) + (eval `(let () (declare (,(gensym))) nil)))) (deftest declaration.4 (let ((sym (gensym))) @@ -55,35 +55,35 @@ (let ((sym (gensym))) (proclaim `(declaration ,sym)) (eval `(signals-error-always (define-condition ,sym (condition) (a b c)) - error))) + error))) t t) (deftest declaration.8 (let ((sym (gensym))) (eval `(deftype ,sym () 'error)) (eval `(signals-error-always (proclaim '(declaration ,sym)) - error))) + error))) t t) (deftest declaration.9 (let ((sym (gensym))) (eval `(defstruct ,sym a b c)) (eval `(signals-error-always (proclaim '(declaration ,sym)) - error))) + error))) t t) (deftest declaration.10 (let ((sym (gensym))) (eval `(defclass ,sym () (a b c))) (eval `(signals-error-always (proclaim '(declaration ,sym)) - error))) + error))) t t) (deftest declaration.11 (let ((sym (gensym))) (eval `(define-condition ,sym (condition) (a b c))) (eval `(signals-error-always (proclaim '(declaration ,sym)) - error))) + error))) t t) ) diff --git a/ansi-tests/decode-universal-time.lsp b/ansi-tests/decode-universal-time.lsp index b990ec1d..7884f4fa 100644 --- a/ansi-tests/decode-universal-time.lsp +++ b/ansi-tests/decode-universal-time.lsp @@ -16,55 +16,55 @@ (deftest decode-universal-time.3 (let ((count 0)) (loop for time = (random 10000000000) - for tz = (- (random 49) 24) - for (second minute hour date month year day daylight-p zone) - = (multiple-value-list (decode-universal-time time tz)) - for time2 = (encode-universal-time second minute hour date month year zone) - repeat 1000 - unless (and (eql tz zone) (eql time time2) (null daylight-p)) - collect (progn (incf count) - (list time tz (list second minute hour date month year day daylight-p zone) time2)) - until (>= count 100))) + for tz = (- (random 49) 24) + for (second minute hour date month year day daylight-p zone) + = (multiple-value-list (decode-universal-time time tz)) + for time2 = (encode-universal-time second minute hour date month year zone) + repeat 1000 + unless (and (eql tz zone) (eql time time2) (null daylight-p)) + collect (progn (incf count) + (list time tz (list second minute hour date month year day daylight-p zone) time2)) + until (>= count 100))) nil) (deftest decode-universal-time.4 (let ((count 0)) (loop for time = (random 10000000000) - for tz = (/ (- (random (1+ (* 48 3600))) (* 24 3600)) 3600) - for (second minute hour date month year day daylight-p zone) - = (multiple-value-list (decode-universal-time time tz)) - for time2 = (encode-universal-time second minute hour date month year zone) - repeat 1000 - unless (and (eql tz zone) (eql time time2) (null daylight-p)) - collect (progn (incf count) - (list time tz (list second minute hour date month year day daylight-p zone) time2)) - until (>= count 100))) + for tz = (/ (- (random (1+ (* 48 3600))) (* 24 3600)) 3600) + for (second minute hour date month year day daylight-p zone) + = (multiple-value-list (decode-universal-time time tz)) + for time2 = (encode-universal-time second minute hour date month year zone) + repeat 1000 + unless (and (eql tz zone) (eql time time2) (null daylight-p)) + collect (progn (incf count) + (list time tz (list second minute hour date month year day daylight-p zone) time2)) + until (>= count 100))) nil) (deftest decode-universal-time.5 (let ((count 0)) (loop for time = (random 10000000000) - for (second minute hour date month year day daylight-p zone) - = (handler-case - (multiple-value-list (decode-universal-time time)) - (error (c) (print time) (error c))) - for time2 = (encode-universal-time second minute hour date month year) - repeat 1000 - unless (let ((daylight-p-2 (nth-value 7 (decode-universal-time time2)))) - (or (eql time time2) - (and daylight-p (not daylight-p-2) ; (eql time (- time2 3600)) - ) - (and (not daylight-p) daylight-p-2 ; (eql time (+ time2 3600)) - ))) - collect (progn (incf count) - (list time (list second minute hour date month year day daylight-p zone) time2)) - until (>= count 100))) + for (second minute hour date month year day daylight-p zone) + = (handler-case + (multiple-value-list (decode-universal-time time)) + (error (c) (print time) (error c))) + for time2 = (encode-universal-time second minute hour date month year) + repeat 1000 + unless (let ((daylight-p-2 (nth-value 7 (decode-universal-time time2)))) + (or (eql time time2) + (and daylight-p (not daylight-p-2) ; (eql time (- time2 3600)) + ) + (and (not daylight-p) daylight-p-2 ; (eql time (+ time2 3600)) + ))) + collect (progn (incf count) + (list time (list second minute hour date month year day daylight-p zone) time2)) + until (>= count 100))) nil) (deftest decode-universal-time.6 (let ((vals0 (multiple-value-list (get-decoded-time))) - (vals1 (multiple-value-list (decode-universal-time (get-universal-time)))) - (vals2 (multiple-value-list (get-decoded-time)))) + (vals1 (multiple-value-list (decode-universal-time (get-universal-time)))) + (vals2 (multiple-value-list (get-decoded-time)))) (when (equal vals0 vals2) (assert (= (length vals1) 9)) (assert (= (length vals2) 9)) @@ -95,16 +95,16 @@ (deftest decode-universal-time.12 (loop for time = (random 100000000000) - for tz = (- (random 49) 24) - for interval = (1+ (random 10000)) - for time2 = (+ time (* interval 24 3600)) - ;; 'time2' is exactly interval days after 'time' - for day = (nth-value 6 (decode-universal-time time tz)) - for day2 = (nth-value 6 (decode-universal-time time2 tz)) - repeat 1000 - ;; Check that the days of the week are consistent - unless (= (mod day2 7) (mod (+ day interval) 7)) - collect (list time time2 tz interval day day2)) + for tz = (- (random 49) 24) + for interval = (1+ (random 10000)) + for time2 = (+ time (* interval 24 3600)) + ;; 'time2' is exactly interval days after 'time' + for day = (nth-value 6 (decode-universal-time time tz)) + for day2 = (nth-value 6 (decode-universal-time time2 tz)) + repeat 1000 + ;; Check that the days of the week are consistent + unless (= (mod day2 7) (mod (+ day interval) 7)) + collect (list time time2 tz interval day day2)) nil) ;;; Error tests diff --git a/ansi-tests/defclass-01.lsp b/ansi-tests/defclass-01.lsp index e7c9b335..85a600bc 100644 --- a/ansi-tests/defclass-01.lsp +++ b/ansi-tests/defclass-01.lsp @@ -33,7 +33,7 @@ ;;;; (defclass class-02 () ((s1) (s2) (s3))) - + (deftest class-02.1 (notnot-mv (typep (make-instance 'class-02) 'class-02)) t) @@ -55,7 +55,7 @@ ;;;; (defclass class-03 () ((s1 :type integer) (s2 :type t) (s3 :type fixnum))) - + (deftest class-03.1 (notnot-mv (typep (make-instance 'class-03) 'class-03)) t) @@ -115,10 +115,10 @@ ;;;; (defclass class-05 () (s1 (s2 :allocation :instance) (s3 :allocation :class))) - + (deftest class-05.1 (let ((c1 (make-instance 'class-05)) - (c2 (make-instance 'class-05))) + (c2 (make-instance 'class-05))) (values (not (eql c1 c2)) (list @@ -172,7 +172,7 @@ (deftest class-06.2 (let ((c1 (make-instance 'class-06)) - (c2 (make-instance 'class-06a))) + (c2 (make-instance 'class-06a))) (values (setf (slot-value c1 's1) 'x) (setf (slot-value c2 's1) 'y) @@ -182,7 +182,7 @@ ;;;; (defclass class-07 () ((s1 :initarg :s1a :initarg :s1b :reader s1) - (s2 :initarg :s2 :reader s2))) + (s2 :initarg :s2 :reader s2))) (deftest class-07.1 (let ((c (make-instance 'class-07))) @@ -265,14 +265,14 @@ (deftest class-07.11 (let ((c (make-instance 'class-07 :s1a 'a :s2 'b :garbage 'z - :allow-other-keys t))) + :allow-other-keys t))) (values (s1 c) (s2 c))) a b) (deftest class-07.12 (let ((c (make-instance 'class-07 :s1a 'd :s2 'c :garbage 'z - :allow-other-keys t - :allow-other-keys nil))) + :allow-other-keys t + :allow-other-keys nil))) (values (s1 c) (s2 c))) d c) @@ -286,7 +286,7 @@ (deftest class-08.1 (let* ((*class-08-s2-initvar* 'x) - (c (make-instance 'class-08))) + (c (make-instance 'class-08))) (values (slot-value c 's1) (slot-value c 's2))) @@ -302,7 +302,7 @@ (deftest class-09.1 (let* ((*class-09-s2-initvar* 'x) - (c (make-instance 'class-09))) + (c (make-instance 'class-09))) (values (slot-value c 's1) (slot-value c 's2))) @@ -310,7 +310,7 @@ (deftest class-09.2 (let* ((*class-09-s2-initvar* 'x) - (c (make-instance 'class-09 :s1 1))) + (c (make-instance 'class-09 :s1 1))) (values (slot-value c 's1) (slot-value c 's2))) @@ -339,7 +339,7 @@ (deftest class-10.1 (let* ((*class-10-s1-initvar* 0) - (c (make-instance 'class-10))) + (c (make-instance 'class-10))) (values *class-10-s1-initvar* (slot-value c 's1))) @@ -347,7 +347,7 @@ (deftest class-10.2 (let* ((*class-10-s1-initvar* 0) - (c (make-instance 'class-10 :s1 10))) + (c (make-instance 'class-10 :s1 10))) (values *class-10-s1-initvar* (slot-value c 's1))) @@ -388,7 +388,7 @@ (deftest class-13.1 (let ((c1 (make-instance 'class-13)) - (c2 (make-instance 'class-13 :s1 'foo))) + (c2 (make-instance 'class-13 :s1 'foo))) (values (slot-value c1 's1) (slot-value c2 's1))) @@ -431,26 +431,26 @@ (deftest class-15.4 (let ((c (make-instance 'class-15 :allow-other-keys t - :allow-other-keys nil))) + :allow-other-keys nil))) (s1 c)) t) (deftest class-15.5 (let ((c (make-instance 'class-15 :allow-other-keys nil - :allow-other-keys t))) + :allow-other-keys t))) (s1 c)) nil) (deftest class-15.6 (let ((c (make-instance 'class-15 :allow-other-keys t - :foo 'bar))) + :foo 'bar))) (s1 c)) t) (deftest class-15.7 (let ((c (make-instance 'class-15 :allow-other-keys t - :allow-other-keys nil - :foo 'bar))) + :allow-other-keys nil + :foo 'bar))) (s1 c)) t) @@ -537,7 +537,7 @@ (deftest class-19.1 (let* ((*class-19-s1-initvar* nil) - (c (make-instance 'class-19))) + (c (make-instance 'class-19))) (declare (special *class-19-s1-initvar*)) (values (slot-value c 's1) @@ -546,7 +546,7 @@ (deftest class-19.2 (let* ((*class-19-s1-initvar* nil) - (c (make-instance 'class-19 :s1 nil))) + (c (make-instance 'class-19 :s1 nil))) (declare (special *class-19-s1-initvar*)) (values (slot-value c 's1) @@ -555,7 +555,7 @@ (deftest class-19.3 (let* ((*class-19-s1-initvar* nil) - (c (make-instance 'class-19 :s1 'x))) + (c (make-instance 'class-19 :s1 'x))) (declare (special *class-19-s1-initvar*)) (values (slot-value c 's1) @@ -569,14 +569,14 @@ (defclass class-20 () ((s1 :initarg :s1 :initarg :s1b)) (:default-initargs :s1 (setf *class-20-s1-initvar-1* 'a) - :s1b (setf *class-20-s1-initvar-2* 'b))) + :s1b (setf *class-20-s1-initvar-2* 'b))) (deftest class-20.1 (let* (*class-20-s1-initvar-1* - *class-20-s1-initvar-2* - (c (make-instance 'class-20))) + *class-20-s1-initvar-2* + (c (make-instance 'class-20))) (declare (special *class-20-s1-initvar-1* - *class-20-s1-initvar-2*)) + *class-20-s1-initvar-2*)) (values (slot-value c 's1) *class-20-s1-initvar-1* @@ -585,10 +585,10 @@ (deftest class-20.2 (let* (*class-20-s1-initvar-1* - *class-20-s1-initvar-2* - (c (make-instance 'class-20 :s1 'x))) + *class-20-s1-initvar-2* + (c (make-instance 'class-20 :s1 'x))) (declare (special *class-20-s1-initvar-1* - *class-20-s1-initvar-2*)) + *class-20-s1-initvar-2*)) (values (slot-value c 's1) *class-20-s1-initvar-1* @@ -597,10 +597,10 @@ (deftest class-20.3 (let* (*class-20-s1-initvar-1* - *class-20-s1-initvar-2* - (c (make-instance 'class-20 :s1b 'y))) + *class-20-s1-initvar-2* + (c (make-instance 'class-20 :s1b 'y))) (declare (special *class-20-s1-initvar-1* - *class-20-s1-initvar-2*)) + *class-20-s1-initvar-2*)) (values (slot-value c 's1) *class-20-s1-initvar-1* @@ -617,14 +617,14 @@ ((s1 :initarg :s1 :initarg :s1b) (s2 :initarg :s1b :initarg :s2)) (:default-initargs :s1 (incf *class-21-s1-initvar-1*) - :s1b (incf *class-21-s1-initvar-2*)))) + :s1b (incf *class-21-s1-initvar-2*)))) (deftest class-21.1 (let* ((*class-21-s1-initvar-1* 10) - (*class-21-s1-initvar-2* 20) - (c (make-instance 'class-21))) + (*class-21-s1-initvar-2* 20) + (c (make-instance 'class-21))) (declare (special *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) + *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) @@ -634,10 +634,10 @@ (deftest class-21.2 (let* ((*class-21-s1-initvar-1* 10) - (*class-21-s1-initvar-2* 20) - (c (make-instance 'class-21 :s1 'x))) + (*class-21-s1-initvar-2* 20) + (c (make-instance 'class-21 :s1 'x))) (declare (special *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) + *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) @@ -647,10 +647,10 @@ (deftest class-21.3 (let* ((*class-21-s1-initvar-1* 10) - (*class-21-s1-initvar-2* 20) - (c (make-instance 'class-21 :s1 'x :s1b 'y))) + (*class-21-s1-initvar-2* 20) + (c (make-instance 'class-21 :s1 'x :s1b 'y))) (declare (special *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) + *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) @@ -660,10 +660,10 @@ (deftest class-21.4 (let* ((*class-21-s1-initvar-1* 10) - (*class-21-s1-initvar-2* 20) - (c (make-instance 'class-21 :s1b 'y))) + (*class-21-s1-initvar-2* 20) + (c (make-instance 'class-21 :s1b 'y))) (declare (special *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) + *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) @@ -673,10 +673,10 @@ (deftest class-21.5 (let* ((*class-21-s1-initvar-1* 10) - (*class-21-s1-initvar-2* 20) - (c (make-instance 'class-21 :s2 'y))) + (*class-21-s1-initvar-2* 20) + (c (make-instance 'class-21 :s2 'y))) (declare (special *class-21-s1-initvar-1* - *class-21-s1-initvar-2*)) + *class-21-s1-initvar-2*)) (values (slot-value c 's1) (slot-value c 's2) @@ -708,19 +708,19 @@ (deftest class-23.2 (let ((doc (documentation 'class-23 'type))) (or (null doc) - (equalt doc "This is class-23 in ansi-tests"))) + (equalt doc "This is class-23 in ansi-tests"))) t) (deftest class-23.3 (let ((doc (documentation (find-class 'class-23) 'type))) (or (null doc) - (equalt doc "This is class-23 in ansi-tests"))) + (equalt doc "This is class-23 in ansi-tests"))) t) (deftest class-23.4 (let ((doc (documentation (find-class 'class-23) t))) (or (null doc) - (equalt doc "This is class-23 in ansi-tests"))) + (equalt doc "This is class-23 in ansi-tests"))) t) ;;; @@ -769,7 +769,7 @@ (deftest class-25.5 (s1 (make-instance 'class-25 :allow-other-keys t :allow-other-keys nil - :foo t)) + :foo t)) t) (deftest class-25.6 @@ -831,15 +831,15 @@ ;;; (declaim (special *class-28-reset-fn* - *class-28-query-fn*)) + *class-28-query-fn*)) (declaim (type function *class-28-reset-fn* *class-28-query-fn*)) (let ((x 0) (y 0)) (flet ((%reset (a b) (setf x a y b)) - (%query () (list x y))) + (%query () (list x y))) (setf *class-28-reset-fn* #'%reset - *class-28-query-fn* #'%query) + *class-28-query-fn* #'%query) (defclass class-28 () ((s1 :initform (incf x) :initarg :s1) (s2 :initarg :s2)) @@ -852,11 +852,11 @@ (funcall *class-28-query-fn*) (let ((obj (make-instance 'class-28))) (list - (typep* obj 'class-28) - (typep* obj class) - (eqt (class-of obj) class) - (map-slot-value obj '(s1 s2)) - (funcall *class-28-query-fn*))))) + (typep* obj 'class-28) + (typep* obj class) + (eqt (class-of obj) class) + (map-slot-value obj '(s1 s2)) + (funcall *class-28-query-fn*))))) ((5 10) (t t t (6 11) (6 11)))) @@ -867,11 +867,11 @@ (funcall *class-28-query-fn*) (let ((obj (make-instance 'class-28 :s1 17))) (list - (typep* obj 'class-28) - (typep* obj class) - (eqt (class-of obj) class) - (map-slot-value obj '(s1 s2)) - (funcall *class-28-query-fn*))))) + (typep* obj 'class-28) + (typep* obj class) + (eqt (class-of obj) class) + (map-slot-value obj '(s1 s2)) + (funcall *class-28-query-fn*))))) ((5 10) (t t t (17 11) (5 11)))) @@ -883,14 +883,14 @@ (funcall *class-28-query-fn*) (let ((obj (make-instance 'class-28 :s2 17))) (list - (typep* obj 'class-28) - (typep* obj class) - (eqt (class-of obj) class) - (map-slot-value obj '(s1 s2)) - (funcall *class-28-query-fn*))))) + (typep* obj 'class-28) + (typep* obj class) + (eqt (class-of obj) class) + (map-slot-value obj '(s1 s2)) + (funcall *class-28-query-fn*))))) ((5 10) (t t t (6 17) (6 10)))) - - \ No newline at end of file + + diff --git a/ansi-tests/defclass-02.lsp b/ansi-tests/defclass-02.lsp index e4bfd905..eca1f66f 100644 --- a/ansi-tests/defclass-02.lsp +++ b/ansi-tests/defclass-02.lsp @@ -16,13 +16,13 @@ (deftest class-0201.1 (let ((c (make-instance 'class-0201))) (values (map-slot-boundp* c '(a b c)) - (map-slot-exists-p* c '(a b c)) - (slot-value c 'a) - (map-typep* c (list 'class-0201 'class-0202 - (find-class 'class-0201) - (find-class 'class-0202))) - (class-name (class-of c)) - )) + (map-slot-exists-p* c '(a b c)) + (slot-value c 'a) + (map-typep* c (list 'class-0201 'class-0202 + (find-class 'class-0201) + (find-class 'class-0202))) + (class-name (class-of c)) + )) (t nil nil) (t t t) x @@ -32,12 +32,12 @@ (deftest class-0202.1 (let ((c (make-instance 'class-0202))) (values (map-slot-boundp* c '(a b c d e f)) - (map-slot-value c '(a e)) - (map-typep* c (list 'class-0201 'class-0202 - (find-class 'class-0201) - (find-class 'class-0202))) - (class-name (class-of c)) - )) + (map-slot-value c '(a e)) + (map-typep* c (list 'class-0201 'class-0202 + (find-class 'class-0201) + (find-class 'class-0202))) + (class-name (class-of c)) + )) (t nil nil nil t nil) (x y) (t t t t) @@ -54,7 +54,7 @@ (deftest class-0203.1 (let ((c1 (make-instance 'class-0203)) - (c2 (make-instance 'class-0204))) + (c2 (make-instance 'class-0204))) (values (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)) @@ -76,10 +76,10 @@ (nil nil) (nil nil nil nil)) - + (deftest class-0203.2 (let ((c1 (make-instance 'class-0203)) - (c2 (make-instance 'class-0204))) + (c2 (make-instance 'class-0204))) (values (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b c d)) @@ -137,8 +137,8 @@ (b :allocation :instance))) (deftest class-0206.1 - (let ((c1 (make-instance 'class-0206a)) - (c2 (make-instance 'class-0206b))) + (let ((c1 (make-instance 'class-0206a)) + (c2 (make-instance 'class-0206b))) (values (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b)) @@ -148,15 +148,15 @@ (map-slot-boundp* c2 '(a b)) (map-slot-value c1 '(a b)) (progn (slot-makunbound c1 'a) - (slot-makunbound c1 'b) - (setf (slot-value c2 'a) 'x)) + (slot-makunbound c1 'b) + (setf (slot-value c2 'a) 'x)) (setf (slot-value c2 'b) 'y) (map-slot-boundp* c1 '(a b)) (map-slot-boundp* c2 '(a b)) (map-slot-value c2 '(a b)) (progn (slot-makunbound c2 'a) - (slot-makunbound c2 'b) - nil))) + (slot-makunbound c2 'b) + nil))) (nil nil) (nil nil) x y (t t) (nil nil) @@ -181,8 +181,8 @@ (deftest class-0207.1 (let ((c1 (make-instance 'class-0207a)) - (c2 (make-instance 'class-0207b)) - (c3 (make-instance 'class-0207c))) + (c2 (make-instance 'class-0207b)) + (c3 (make-instance 'class-0207c))) (slot-makunbound c1 'a) (slot-makunbound c2 'a) (slot-makunbound c3 'a) @@ -239,13 +239,13 @@ (deftest class-redefinition.1 (let* ((cobj1 (eval '(defclass class-0209a () - ((a :allocation :class :initform 'x))))) + ((a :allocation :class :initform 'x))))) (cobj2 (eval '(defclass class-0209b (class-0209a) - ((a :allocation :instance))))) + ((a :allocation :instance))))) (cobj3 (eval '(defclass class-0209a () - ((a :allocation :class :initform 'x))))) + ((a :allocation :class :initform 'x))))) (cobj4 (eval '(defclass class-0209b (class-0209a) - ((a :allocation :instance)))))) + ((a :allocation :instance)))))) (values (eqt cobj1 cobj3) (eqt cobj2 cobj4) @@ -262,22 +262,22 @@ (let* ( (cobj1 (eval '(defclass class-0210a () - ((a :allocation :class))))) + ((a :allocation :class))))) (cobj2 (eval '(defclass class-0210b (class-0210a) - ((a :allocation :instance))))) + ((a :allocation :instance))))) (cobj3 (eval '(defclass class-0210c (class-0210b) - ((a :allocation :class))))) + ((a :allocation :class))))) (dummy (progn - (setf (slot-value (make-instance 'class-0210a) 'a) :bad1) - (make-instance 'class-0210b) - (make-instance 'class-0210c) - nil)) + (setf (slot-value (make-instance 'class-0210a) 'a) :bad1) + (make-instance 'class-0210b) + (make-instance 'class-0210c) + nil)) (cobj4 (eval '(defclass class-0210a () - ((a :allocation :class))))) + ((a :allocation :class))))) (cobj5 (eval '(defclass class-0210b (class-0210a) - ((a :allocation :instance))))) + ((a :allocation :instance))))) (cobj6 (eval '(defclass class-0210c (class-0210b) - ((a :allocation :class)))))) + ((a :allocation :class)))))) (list (eqt cobj1 cobj4) (eqt cobj2 cobj5) @@ -286,25 +286,25 @@ (class-name cobj2) (class-name cobj3) (let ((c1 (make-instance 'class-0210a)) - (c2 (make-instance 'class-0210b)) - (c3 (make-instance 'class-0210c))) + (c2 (make-instance 'class-0210b)) + (c3 (make-instance 'class-0210c))) (slot-makunbound c1 'a) (slot-makunbound c2 'a) (slot-makunbound c3 'a) (list - (setf (slot-value c1 'a) 'x) - (and (slot-boundp* c1 'a) (slot-value c1 'a)) - (slot-boundp* c2 'a) - (slot-boundp* c3 'a) - (setf (slot-value c2 'a) 'y) - (and (slot-boundp* c1 'a) (slot-value c1 'a)) - (and (slot-boundp* c2 'a) (slot-value c2 'a)) - (slot-boundp* c3 'a) - (setf (slot-value c3 'a) 'z) - (and (slot-boundp* c1 'a) (slot-value c1 'a)) - (and (slot-boundp* c2 'a) (slot-value c2 'a)) - (and (slot-boundp* c3 'a) (slot-value c3 'a)))))) - (t t t + (setf (slot-value c1 'a) 'x) + (and (slot-boundp* c1 'a) (slot-value c1 'a)) + (slot-boundp* c2 'a) + (slot-boundp* c3 'a) + (setf (slot-value c2 'a) 'y) + (and (slot-boundp* c1 'a) (slot-value c1 'a)) + (and (slot-boundp* c2 'a) (slot-value c2 'a)) + (slot-boundp* c3 'a) + (setf (slot-value c3 'a) 'z) + (and (slot-boundp* c1 'a) (slot-value c1 'a)) + (and (slot-boundp* c2 'a) (slot-value c2 'a)) + (and (slot-boundp* c3 'a) (slot-value c3 'a)))))) + (t t t class-0210a class-0210b class-0210c @@ -320,13 +320,13 @@ (deftest class-redefinition.3 (let* ((cobj1 (eval '(defclass class-redef-03a () - ((a :allocation :class :initform 'x))))) + ((a :allocation :class :initform 'x))))) (cobj2 (eval '(defclass class-redef-03b (class-redef-03a) - ((a :allocation :instance))))) + ((a :allocation :instance))))) (cobj4 (eval '(defclass class-redef-03b (class-redef-03a) - ((a :allocation :instance))))) + ((a :allocation :instance))))) (cobj3 (eval '(defclass class-redef-03a () - ((a :allocation :class :initform 'x)))))) + ((a :allocation :class :initform 'x)))))) (values (eqt cobj1 cobj3) (eqt cobj2 cobj4) @@ -599,7 +599,7 @@ (deftest class-0219.2 (let ((*class-0219-a-1* nil) - (*class-0219-a-2* nil)) + (*class-0219-a-2* nil)) (values (slot-value (make-instance 'class-0219b) 'a) *class-0219-a-1* @@ -645,22 +645,22 @@ (deftest class-0221.1 (let* ((cl (find-class 'class-0221a)) - (doc (documentation cl t))) + (doc (documentation cl t))) (or (null doc) - (equalt doc "This is class class-0221a"))) + (equalt doc "This is class class-0221a"))) t) (deftest class-0221.2 (let* ((cl (find-class 'class-0221b)) - (doc (documentation cl t))) + (doc (documentation cl t))) doc) nil) (deftest class-0221.3 (let* ((cl (find-class 'class-0221c)) - (doc (documentation cl t))) + (doc (documentation cl t))) (or (null doc) - (equalt doc "This is class class-0221c"))) + (equalt doc "This is class class-0221c"))) t) ;;; diff --git a/ansi-tests/defclass-03.lsp b/ansi-tests/defclass-03.lsp index 21ffc8ca..8f22ea3a 100644 --- a/ansi-tests/defclass-03.lsp +++ b/ansi-tests/defclass-03.lsp @@ -70,37 +70,37 @@ (deftest class-0303.1 (let ((c1 (make-instance 'class-0303a)) - (c2 (make-instance 'class-0303b)) - (c3 (make-instance 'class-0303c))) + (c2 (make-instance 'class-0303b)) + (c3 (make-instance 'class-0303c))) (slot-makunbound c1 'a) (slot-makunbound c2 'b) (values (loop for c in (list c1 c2 c3) - collect (map-slot-boundp* c '(a b))) + collect (map-slot-boundp* c '(a b))) (list (setf (slot-value c1 'a) 'x1) - (slot-boundp* c2 'a) - (slot-value c3 'a)) + (slot-boundp* c2 'a) + (slot-value c3 'a)) (list (setf (slot-value c2 'a) 'x2) - (slot-value c1 'a) - (slot-value c2 'a) - (slot-value c3 'a)) + (slot-value c1 'a) + (slot-value c2 'a) + (slot-value c3 'a)) (list (setf (slot-value c3 'a) 'x3) - (slot-value c1 'a) - (slot-value c2 'a) - (slot-value c3 'a)) + (slot-value c1 'a) + (slot-value c2 'a) + (slot-value c3 'a)) ;;; (list (setf (slot-value c1 'b) 'y1) - (slot-value c1 'b) - (slot-boundp* c2 'b) - (slot-boundp* c3 'b)) + (slot-value c1 'b) + (slot-boundp* c2 'b) + (slot-boundp* c3 'b)) (list (setf (slot-value c2 'b) 'y2) - (slot-value c1 'b) - (slot-value c2 'b) - (slot-boundp c3 'b)) + (slot-value c1 'b) + (slot-value c2 'b) + (slot-boundp c3 'b)) (list (setf (slot-value c3 'b) 'y3) - (slot-value c1 'b) - (slot-value c2 'b) - (slot-value c3 'b)))) + (slot-value c1 'b) + (slot-value c2 'b) + (slot-value c3 'b)))) ((nil nil) (nil nil) (nil nil)) (x1 nil x1) (x2 x1 x2 x1) @@ -164,18 +164,18 @@ (deftest class-0306.1 (loop for obj in - (mapcar #'make-instance - '(class-0306a class-0306b class-0306c class-0306d - class-0306e class-0306f class-0306g class-0306h)) - collect (slot-value obj 'a)) + (mapcar #'make-instance + '(class-0306a class-0306b class-0306c class-0306d + class-0306e class-0306f class-0306g class-0306h)) + collect (slot-value obj 'a)) (nil x y x x x x y)) (deftest class-0306.2 (loop for obj in - (mapcar #'make-instance - '(class-0306a class-0306b class-0306c class-0306d - class-0306e class-0306f class-0306g class-0306h)) - collect (a-slot obj)) + (mapcar #'make-instance + '(class-0306a class-0306b class-0306c class-0306d + class-0306e class-0306f class-0306g class-0306h)) + collect (a-slot obj)) (nil x y x x x x y)) ;;; A class redefinition test that came up in cmucl @@ -183,7 +183,7 @@ (deftest class-0307.1 (progn (setf (find-class 'class-0307a) nil - (find-class 'class-0307b) nil) + (find-class 'class-0307b) nil) (eval '(defclass class-0307a () ())) (eval '(defclass class-0307b (class-0307a) (a))) (eval '(defclass class-0307a () ((a :initform nil)))) @@ -194,7 +194,7 @@ (deftest class-0308.1 (progn (setf (find-class 'class-0308a) nil - (find-class 'class-0308b) nil) + (find-class 'class-0308b) nil) (eval '(defclass class-0308a () ())) (eval '(defclass class-0308b (class-0308a) (a))) (eval '(defclass class-0308a () ((a :initarg :a)))) @@ -208,47 +208,47 @@ (progn (setf (find-class 'class-0309) nil) (let* ((class1 (eval '(defclass class-0309 () ((a) (b) (c))))) - (obj1 (make-instance 'class-0309))) + (obj1 (make-instance 'class-0309))) (setf (class-name class1) nil) (let ((class2 (eval '(defclass class-0309 () ((a) (b) (c)))))) - (values - (eqt (class-of obj1) class1) - (eqt class1 class2) - (typep* obj1 class1) - (typep* obj1 class2))))) + (values + (eqt (class-of obj1) class1) + (eqt class1 class2) + (typep* obj1 class1) + (typep* obj1 class2))))) t nil t nil) (deftest class-0310.1 (progn (setf (find-class 'class-0310a) nil - (find-class 'class-0310b) nil) + (find-class 'class-0310b) nil) (let* ((class1 (eval '(defclass class-0310a () ((a) (b) (c))))) - (obj1 (make-instance 'class-0310a))) + (obj1 (make-instance 'class-0310a))) (setf (class-name class1) 'class-0310b) (let ((class2 (eval '(defclass class-0310a () ((a) (b) (c)))))) - (values - (eqt (class-of obj1) class1) - (eqt class1 class2) - (typep* obj1 class1) - (typep* obj1 class2) - (class-name class1) - (class-name class2))))) + (values + (eqt (class-of obj1) class1) + (eqt class1 class2) + (typep* obj1 class1) + (typep* obj1 class2) + (class-name class1) + (class-name class2))))) t nil t nil class-0310b class-0310a) (deftest class-0311.1 (progn (setf (find-class 'class-0311) nil) (let* ((class1 (eval '(defclass class-0311 () ((a) (b) (c))))) - (obj1 (make-instance 'class-0311))) + (obj1 (make-instance 'class-0311))) (setf (find-class 'class-0311) nil) (let ((class2 (eval '(defclass class-0311 () ((a) (b) (c)))))) - (values - (eqt (class-of obj1) class1) - (eqt class1 class2) - (typep* obj1 class1) - (typep* obj1 class2) - (class-name class1) - (class-name class2) - (eqt (find-class 'class-0311) class1) - (eqt (find-class 'class-0311) class2))))) + (values + (eqt (class-of obj1) class1) + (eqt class1 class2) + (typep* obj1 class1) + (typep* obj1 class2) + (class-name class1) + (class-name class2) + (eqt (find-class 'class-0311) class1) + (eqt (find-class 'class-0311) class2))))) t nil t nil class-0311 class-0311 nil t) diff --git a/ansi-tests/defclass-aux.lsp b/ansi-tests/defclass-aux.lsp index 319113fc..cc17f6aa 100644 --- a/ansi-tests/defclass-aux.lsp +++ b/ansi-tests/defclass-aux.lsp @@ -7,7 +7,7 @@ (defun make-defclass-test-name (&rest args) (intern (apply #'concatenate 'string (mapcar #'string args)) - (find-package :cl-test))) + (find-package :cl-test))) (defparameter *defclass-slot-readers* nil) (defparameter *defclass-slot-writers* nil) @@ -54,73 +54,73 @@ (defmacro defclass-with-tests (&whole args - class-name superclasses slot-specifiers - &rest class-options) + class-name superclasses slot-specifiers + &rest class-options) (assert (typep class-name '(and (not null) symbol))) (assert (listp superclasses)) (assert (every #'(lambda (x) (typep x '(and (not null) symbol))) - superclasses)) + superclasses)) (assert (listp slot-specifiers)) (assert (every #'(lambda (s) - (or (symbolp s) (and (consp s) (symbolp (car s))))) - slot-specifiers)) + (or (symbolp s) (and (consp s) (symbolp (car s))))) + slot-specifiers)) (assert (every #'(lambda (x) - (and (consp x) - (member (car x) '(:default-initargs - :documentation - :metaclass)))) - class-options)) + (and (consp x) + (member (car x) '(:default-initargs + :documentation + :metaclass)))) + class-options)) (assert (eql (length class-options) - (length (remove-duplicates class-options)))) + (length (remove-duplicates class-options)))) (let* ((default-initargs (rest (assoc :default-initargs class-options))) - (metaclass (or (second (assoc :metaclass class-options)) - 'standard-class)) - (doc (second (assoc :documentation class-options))) - (slot-names - (loop for slot-spec in slot-specifiers - collect (cond - ((symbolp slot-spec) slot-spec) - (t (assert (consp slot-spec)) - (assert (symbolp (car slot-spec))) - (car slot-spec))))) - (slot-options - (loop for slot-spec in slot-specifiers - collect (if (consp slot-spec) - (cdr slot-spec) - nil))) - (readers - (loop for slot-option in slot-options - append (collect-properties slot-option :reader))) - (writers - (loop for slot-option in slot-options - append (collect-properties slot-option :writer))) - (accessors - (loop for slot-option in slot-options - append (collect-properties slot-option :accessor))) - (allocations - (loop for slot-option in slot-options - collect (or (get slot-option :allocation) - :instance))) - (initargs - (loop for slot-option in slot-options - collect (collect-properties slot-option :initarg))) - (types - (loop for slot-option in slot-options - collect (collect-properties slot-option :type))) - (initforms - (loop for slot-option in slot-options - collect (collect-properties slot-option :initform))) - (class-var-name - (intern (concatenate 'string "*CLASS-" (symbol-name class-name) - "-RETURNED-BY-DEFCLASS*") - (find-package :cl-test))) - ) + (metaclass (or (second (assoc :metaclass class-options)) + 'standard-class)) + (doc (second (assoc :documentation class-options))) + (slot-names + (loop for slot-spec in slot-specifiers + collect (cond + ((symbolp slot-spec) slot-spec) + (t (assert (consp slot-spec)) + (assert (symbolp (car slot-spec))) + (car slot-spec))))) + (slot-options + (loop for slot-spec in slot-specifiers + collect (if (consp slot-spec) + (cdr slot-spec) + nil))) + (readers + (loop for slot-option in slot-options + append (collect-properties slot-option :reader))) + (writers + (loop for slot-option in slot-options + append (collect-properties slot-option :writer))) + (accessors + (loop for slot-option in slot-options + append (collect-properties slot-option :accessor))) + (allocations + (loop for slot-option in slot-options + collect (or (get slot-option :allocation) + :instance))) + (initargs + (loop for slot-option in slot-options + collect (collect-properties slot-option :initarg))) + (types + (loop for slot-option in slot-options + collect (collect-properties slot-option :type))) + (initforms + (loop for slot-option in slot-options + collect (collect-properties slot-option :initform))) + (class-var-name + (intern (concatenate 'string "*CLASS-" (symbol-name class-name) + "-RETURNED-BY-DEFCLASS*") + (find-package :cl-test))) + ) (declare (ignorable readers writers accessors allocations - initargs types initforms default-initargs - doc)) + initargs types initforms default-initargs + doc)) (assert (loop for e in types always (< (length e) 2))) (assert (loop for e in initforms always (< (length e) 2))) @@ -128,138 +128,138 @@ (setf *defclass-slot-readers* (append readers *defclass-slot-readers*)) (setf *defclass-slot-writers* (append writers *defclass-slot-writers*)) (setf *defclass-slot-accessors* - (append accessors *defclass-slot-accessors*)) + (append accessors *defclass-slot-accessors*)) ;;; Store away information about the class and its slots ;;; in a my-class object and associated my-slot objects. - + (let* ((my-slots - (loop for name in slot-names - for slot-option in slot-options - for readers = (collect-properties slot-option :reader) - for writers = (collect-properties slot-option :writer) - for accessors = (collect-properties slot-option :accessor) - for documentation = (getf slot-option :documentation) - for initarg-list in initargs - for type-list in types - for initform-list in initforms - for allocation in allocations - collect - (make-my-slot - :name name - :has-initform (notnot initform-list) - :initform (first initform-list) - :documentation documentation - :readers readers - :writers writers - :accessors accessors - :type (if type-list (first type-list) t) - ))) - (my-class-obj - (make-my-class :name class-name - :direct-superclass-names superclasses - :default-initargs default-initargs - :documentation doc - :metaclass metaclass - :slots my-slots))) + (loop for name in slot-names + for slot-option in slot-options + for readers = (collect-properties slot-option :reader) + for writers = (collect-properties slot-option :writer) + for accessors = (collect-properties slot-option :accessor) + for documentation = (getf slot-option :documentation) + for initarg-list in initargs + for type-list in types + for initform-list in initforms + for allocation in allocations + collect + (make-my-slot + :name name + :has-initform (notnot initform-list) + :initform (first initform-list) + :documentation documentation + :readers readers + :writers writers + :accessors accessors + :type (if type-list (first type-list) t) + ))) + (my-class-obj + (make-my-class :name class-name + :direct-superclass-names superclasses + :default-initargs default-initargs + :documentation doc + :metaclass metaclass + :slots my-slots))) (setf (gethash class-name *my-classes*) my-class-obj)) `(progn (declaim (special ,class-var-name)) - + (report-and-ignore-errors (setq ,class-var-name - (defclass ,@(cdr args)))) + (defclass ,@(cdr args)))) (deftest ,(make-defclass-test-name class-name "-DEFCLASS-RETURNS-CLASS") - (eqt (find-class ',class-name) ,class-var-name) - t) + (eqt (find-class ',class-name) ,class-var-name) + t) (deftest ,(make-defclass-test-name class-name - "-IS-IN-ITS-METACLASS") - (notnot-mv (typep (find-class ',class-name) ',metaclass)) - t) + "-IS-IN-ITS-METACLASS") + (notnot-mv (typep (find-class ',class-name) ',metaclass)) + t) ,@(when (eq metaclass 'standard-class) - `((deftest ,(make-defclass-test-name class-name - "S-ARE-STANDARD-OBJECTS") - (subtypep* ',class-name 'standard-object) - t t))) + `((deftest ,(make-defclass-test-name class-name + "S-ARE-STANDARD-OBJECTS") + (subtypep* ',class-name 'standard-object) + t t))) ,@(loop for slot-name in slot-names - collect - `(deftest ,(make-defclass-test-name class-name - "-HAS-SLOT-NAMED-" - slot-name) - (notnot-mv (slot-exists-p (make-instance ',class-name) - ',slot-name)) - t)) + collect + `(deftest ,(make-defclass-test-name class-name + "-HAS-SLOT-NAMED-" + slot-name) + (notnot-mv (slot-exists-p (make-instance ',class-name) + ',slot-name)) + t)) (deftest ,(make-defclass-test-name class-name - "-ALLOCATE-INSTANCE") - (defclass-allocate-instance-test ',class-name ',slot-names) - nil) + "-ALLOCATE-INSTANCE") + (defclass-allocate-instance-test ',class-name ',slot-names) + nil) ))) (defun defclass-allocate-instance-test (class-name slot-names) (let* ((class (find-class class-name)) - (instance (allocate-instance class))) + (instance (allocate-instance class))) (append (unless (eql (class-of instance) class) (list (list 'not-instance-of class-name))) (loop for slot in slot-names - when (slot-boundp instance slot) - collect (list 'is-bound slot)) + when (slot-boundp instance slot) + collect (list 'is-bound slot)) (loop for slot in slot-names - unless (equal (multiple-value-list - (notnot-mv (slot-exists-p instance slot))) - '(t)) - collect (list 'does-not-exist slot)) + unless (equal (multiple-value-list + (notnot-mv (slot-exists-p instance slot))) + '(t)) + collect (list 'does-not-exist slot)) (let ((bad-slot '#:foo)) (when (slot-exists-p instance bad-slot) - (list (list 'should-not-exist bad-slot)))) + (list (list 'should-not-exist bad-slot)))) ))) - + (defmacro generate-slot-tests () "Generate generic tests from the read/writer/accessor functions for slots from defclass-with-tests." (let ((funs (remove-duplicates - (append *defclass-slot-readers* - *defclass-slot-writers* - *defclass-slot-accessors*)))) + (append *defclass-slot-readers* + *defclass-slot-writers* + *defclass-slot-accessors*)))) `(progn (deftest class-readers/writers/accessors-are-generic-functions - (loop for sym in ',funs - unless (typep (symbol-function sym) 'generic-function) - collect sym) - nil) - + (loop for sym in ',funs + unless (typep (symbol-function sym) 'generic-function) + collect sym) + nil) + (deftest class-accessors-have-generic-setf-functions - (append - ,@(loop for sym in *defclass-slot-accessors* - collect - `(and (not (typep (function (setf ,sym)) - 'generic-function)) - '(,sym)))) - nil)))) + (append + ,@(loop for sym in *defclass-slot-accessors* + collect + `(and (not (typep (function (setf ,sym)) + 'generic-function)) + '(,sym)))) + nil)))) (defun my-compute-class-precedence-list (class-name) "Compute the class precdence list for classes defined using DEFCLASS-WITH-TESTS." (let ((class-names nil) - (class-names-to-consider (list class-name)) - classes) + (class-names-to-consider (list class-name)) + classes) ;; Find all classes (loop while class-names-to-consider do (let ((name (pop class-names-to-consider))) - (unless (member name class-names) - (push name class-names) - (let ((my-class (find-my-class name))) - (assert my-class) - (setq class-names-to-consider - (append (my-class-direct-superclass-names my-class) - class-names-to-consider)))))) + (unless (member name class-names) + (push name class-names) + (let ((my-class (find-my-class name))) + (assert my-class) + (setq class-names-to-consider + (append (my-class-direct-superclass-names my-class) + class-names-to-consider)))))) (setq class-names (reverse class-names)) (assert (eq class-name (first class-names))) ;; class-names now contains class-name (which occurs first) and @@ -268,47 +268,47 @@ ;; Walk the classes and set the predecessor links in the ;; class precedence DAG (loop for c in classes - for dsns = (my-class-direct-superclass-names c) - do (let ((pred c)) - (loop for superclass-name in dsns - for superclass = (find-my-class superclass-name) - do (push pred (my-class-preds superclass)) - do (pushnew superclass (my-class-succs pred)) - do (incf (my-class-count superclass)) - do (setq pred superclass)))) + for dsns = (my-class-direct-superclass-names c) + do (let ((pred c)) + (loop for superclass-name in dsns + for superclass = (find-my-class superclass-name) + do (push pred (my-class-preds superclass)) + do (pushnew superclass (my-class-succs pred)) + do (incf (my-class-count superclass)) + do (setq pred superclass)))) ;; The list candidates will contain all the classes ;; for which the count is zero. These are the candidates ;; for selection as the next class in the class precedence list (let ((candidates (loop for c in classes - when (zerop (my-class-count c)) - collect c)) - (n 0) - (result nil)) + when (zerop (my-class-count c)) + collect c)) + (n 0) + (result nil)) (assert (equal candidates (list (first classes)))) (loop while candidates do (let* ((next (first candidates)) - (min-pred-index (my-class-min-pred-index next))) - (loop - for c in (rest candidates) - for c-min-pred-index = (my-class-min-pred-index c) - do - (cond - ((< c-min-pred-index min-pred-index) - (setq next c - min-pred-index c-min-pred-index)) - (t (assert (not (= c-min-pred-index min-pred-index)))))) - (setq candidates (remove next candidates)) - (setf (my-class-index next) (incf n)) - (push next result) - (loop - for succ in (my-class-succs next) - do (decf (my-class-count succ)) - do (setf (my-class-min-pred-index succ) - (min (my-class-min-pred-index succ) - n)) - do (when (zerop (my-class-count succ)) - (push succ candidates))))) + (min-pred-index (my-class-min-pred-index next))) + (loop + for c in (rest candidates) + for c-min-pred-index = (my-class-min-pred-index c) + do + (cond + ((< c-min-pred-index min-pred-index) + (setq next c + min-pred-index c-min-pred-index)) + (t (assert (not (= c-min-pred-index min-pred-index)))))) + (setq candidates (remove next candidates)) + (setf (my-class-index next) (incf n)) + (push next result) + (loop + for succ in (my-class-succs next) + do (decf (my-class-count succ)) + do (setf (my-class-min-pred-index succ) + (min (my-class-min-pred-index succ) + n)) + do (when (zerop (my-class-count succ)) + (push succ candidates))))) (assert (eql (length result) (length classes))) (setq result (reverse result)) (mapcar #'my-class-name result)))) diff --git a/ansi-tests/defclass-errors.lsp b/ansi-tests/defclass-errors.lsp index 4fffe46b..24de5646 100644 --- a/ansi-tests/defclass-errors.lsp +++ b/ansi-tests/defclass-errors.lsp @@ -148,7 +148,7 @@ (signals-error (defclass defclass-error-20 nil ((foo :initarg f1 :documentation "x" :reader defclass-error-7/foo - :documentation "x"))) + :documentation "x"))) program-error) t) @@ -164,28 +164,28 @@ (eval `(signals-error (defclass defclass-error-22 () - (foo bar) - (,option nil)) + (foo bar) + (,option nil)) program-error))) t) (deftest defclass.error.23 (loop for cl in *built-in-classes* - for name = (class-name cl) - unless (or (not name) - (handler-case - (progn (eval `(defclass ,(gensym) (,name))) nil) - (error (c) c))) - collect (list cl name)) + for name = (class-name cl) + unless (or (not name) + (handler-case + (progn (eval `(defclass ,(gensym) (,name))) nil) + (error (c) c))) + collect (list cl name)) nil) (deftest defclass.error.24 (loop for cl in *built-in-classes* - for name = (class-name cl) - unless (or (not name) - (handler-case - (progn (eval `(defclass ,name ())) nil) - (error (c) c))) - collect (list cl name)) + for name = (class-name cl) + unless (or (not name) + (handler-case + (progn (eval `(defclass ,name ())) nil) + (error (c) c))) + collect (list cl name)) nil) diff --git a/ansi-tests/defclass-forward-reference.lsp b/ansi-tests/defclass-forward-reference.lsp index 026a6728..1013bb4d 100644 --- a/ansi-tests/defclass-forward-reference.lsp +++ b/ansi-tests/defclass-forward-reference.lsp @@ -7,121 +7,121 @@ (deftest defclass.forward-ref.1 (let ((c1 (gensym)) - (c2 (gensym))) + (c2 (gensym))) (let ((class1 (eval `(defclass ,c1 (,c2) nil)))) (if (not (typep class1 'class)) - 1 - (let ((class2 (eval `(defclass ,c2 nil nil)))) - (if (not (typep class2 'class)) - 2 - (let ((i1 (make-instance c1)) - (i2 (make-instance c2))) - (cond - ((not (typep i1 c1)) 3) - ((not (typep i1 class1)) 4) - ((not (typep i1 c2)) 5) - ((not (typep i1 class2)) 6) - ((typep i2 c1) 7) - ((typep i2 class1) 8) - ((not (typep i2 c2)) 9) - ((not (typep i2 class2)) 10) - (t 'good)))))))) + 1 + (let ((class2 (eval `(defclass ,c2 nil nil)))) + (if (not (typep class2 'class)) + 2 + (let ((i1 (make-instance c1)) + (i2 (make-instance c2))) + (cond + ((not (typep i1 c1)) 3) + ((not (typep i1 class1)) 4) + ((not (typep i1 c2)) 5) + ((not (typep i1 class2)) 6) + ((typep i2 c1) 7) + ((typep i2 class1) 8) + ((not (typep i2 c2)) 9) + ((not (typep i2 class2)) 10) + (t 'good)))))))) good) (deftest defclass.forward-ref.2 (let ((c1 (gensym)) - (c2 (gensym)) - (c3 (gensym))) + (c2 (gensym)) + (c3 (gensym))) (let ((class1 (eval `(defclass ,c1 (,c2 ,c3) nil)))) (if (not (typep class1 'class)) - 1 - (let ((class2 (eval `(defclass ,c2 nil nil)))) - (if (not (typep class2 'class)) - 2 - (let ((class3 (eval `(defclass ,c3 nil nil)))) - (if (not (typep class3 'class)) - 3 - (let ((i1 (make-instance c1)) - (i2 (make-instance c2)) - (i3 (make-instance c3))) - (cond - ((not (typep i1 c1)) 4) - ((not (typep i1 class1)) 5) - ((not (typep i1 c2)) 6) - ((not (typep i1 class2)) 7) - ((not (typep i1 c3)) 8) - ((not (typep i1 class3)) 9) - ((typep i2 c1) 10) - ((typep i2 class1) 11) - ((typep i3 c1) 12) - ((typep i3 class1) 13) - ((not (typep i2 c2)) 14) - ((not (typep i2 class2)) 15) - ((not (typep i3 c3)) 16) - ((not (typep i3 class3)) 17) - ((typep i2 c3) 18) - ((typep i2 class3) 19) - ((typep i3 c2) 20) - ((typep i3 class2) 21) - (t 'good)))))))))) + 1 + (let ((class2 (eval `(defclass ,c2 nil nil)))) + (if (not (typep class2 'class)) + 2 + (let ((class3 (eval `(defclass ,c3 nil nil)))) + (if (not (typep class3 'class)) + 3 + (let ((i1 (make-instance c1)) + (i2 (make-instance c2)) + (i3 (make-instance c3))) + (cond + ((not (typep i1 c1)) 4) + ((not (typep i1 class1)) 5) + ((not (typep i1 c2)) 6) + ((not (typep i1 class2)) 7) + ((not (typep i1 c3)) 8) + ((not (typep i1 class3)) 9) + ((typep i2 c1) 10) + ((typep i2 class1) 11) + ((typep i3 c1) 12) + ((typep i3 class1) 13) + ((not (typep i2 c2)) 14) + ((not (typep i2 class2)) 15) + ((not (typep i3 c3)) 16) + ((not (typep i3 class3)) 17) + ((typep i2 c3) 18) + ((typep i2 class3) 19) + ((typep i3 c2) 20) + ((typep i3 class2) 21) + (t 'good)))))))))) good) (deftest defclass.forward-ref.3 (let ((c1 (gensym)) - (c2 (gensym)) - (c3 (gensym))) + (c2 (gensym)) + (c3 (gensym))) (let ((class1 (eval `(defclass ,c1 (,c2) nil)))) (if (not (typep class1 'class)) - 1 - (let ((class2 (eval `(defclass ,c2 (,c3) nil)))) - (if (not (typep class2 'class)) - 2 - (let ((class3 (eval `(defclass ,c3 nil nil)))) - (if (not (typep class3 'class)) - 3 - (let ((i1 (make-instance c1)) - (i2 (make-instance c2)) - (i3 (make-instance c3))) - (cond - ((not (typep i1 c1)) 4) - ((not (typep i1 class1)) 5) - ((not (typep i1 c2)) 6) - ((not (typep i1 class2)) 7) - ((not (typep i1 c3)) 8) - ((not (typep i1 class3)) 9) - ((typep i2 c1) 10) - ((typep i2 class1) 11) - ((typep i3 c1) 12) - ((typep i3 class1) 13) - ((not (typep i2 c2)) 14) - ((not (typep i2 class2)) 15) - ((not (typep i3 c3)) 16) - ((not (typep i3 class3)) 17) - ((not (typep i2 c3)) 18) - ((not (typep i2 class3)) 19) - ((typep i3 c2) 20) - ((typep i3 class2) 21) - (t 'good)))))))))) + 1 + (let ((class2 (eval `(defclass ,c2 (,c3) nil)))) + (if (not (typep class2 'class)) + 2 + (let ((class3 (eval `(defclass ,c3 nil nil)))) + (if (not (typep class3 'class)) + 3 + (let ((i1 (make-instance c1)) + (i2 (make-instance c2)) + (i3 (make-instance c3))) + (cond + ((not (typep i1 c1)) 4) + ((not (typep i1 class1)) 5) + ((not (typep i1 c2)) 6) + ((not (typep i1 class2)) 7) + ((not (typep i1 c3)) 8) + ((not (typep i1 class3)) 9) + ((typep i2 c1) 10) + ((typep i2 class1) 11) + ((typep i3 c1) 12) + ((typep i3 class1) 13) + ((not (typep i2 c2)) 14) + ((not (typep i2 class2)) 15) + ((not (typep i3 c3)) 16) + ((not (typep i3 class3)) 17) + ((not (typep i2 c3)) 18) + ((not (typep i2 class3)) 19) + ((typep i3 c2) 20) + ((typep i3 class2) 21) + (t 'good)))))))))) good) (deftest defclass.forward-ref.4 (block nil (let ((c1 (gensym)) - (c2 (gensym)) - (c3 (gensym)) - (c4 (gensym)) - (c5 (gensym))) + (c2 (gensym)) + (c3 (gensym)) + (c4 (gensym)) + (c5 (gensym))) (unless (typep (eval `(defclass ,c4 nil nil)) 'class) - (return 1)) + (return 1)) (unless (typep (eval `(defclass ,c5 nil nil)) 'class) - (return 2)) + (return 2)) (unless (typep (eval `(defclass ,c1 (,c2 ,c3) nil)) 'class) - (return 3)) + (return 3)) (unless (typep (eval `(defclass ,c2 (,c4 ,c5) nil)) 'class) - (return 4)) + (return 4)) (handler-case (eval `(progn - (defclass ,c3 (,c5 ,c4) nil) - (make-instance ',c1))) + (defclass ,c3 (,c5 ,c4) nil) + (make-instance ',c1))) (error () :good)))) :good) diff --git a/ansi-tests/defconstant.lsp b/ansi-tests/defconstant.lsp index a5aad4d7..9e3a08ac 100644 --- a/ansi-tests/defconstant.lsp +++ b/ansi-tests/defconstant.lsp @@ -33,32 +33,32 @@ ;;; (deftest defconstant.error.1 ;;; (signals-error (defconstant) program-error) ;;; t) -;;; +;;; ;;; (deftest defconstant.error.2 ;;; (signals-error (defconstant +ignorable-constant-name+) program-error) ;;; t) -;;; +;;; ;;; (deftest defconstant.error.3 ;;; (signals-error (defconstant +ignorable-constant-name2+ nil -;;; "This is a docstring" -;;; "This is an unnecessary extra argument.") +;;; "This is a docstring" +;;; "This is an unnecessary extra argument.") ;;; program-error) ;;; t) (deftest defconstant.error.1 (signals-error (funcall (macro-function 'defconstant)) - program-error) + program-error) t) (deftest defconstant.error.2 (signals-error (funcall (macro-function 'defconstant) - '(defconstant +nonexistent-constant+ 0)) - program-error) + '(defconstant +nonexistent-constant+ 0)) + program-error) t) (deftest defconstant.error.3 (signals-error (funcall (macro-function 'defconstant) - '(defconstant +nonexistent-constant+ 0) - nil nil) - program-error) + '(defconstant +nonexistent-constant+ 0) + nil nil) + program-error) t) diff --git a/ansi-tests/defgeneric-method-combination-and.lsp b/ansi-tests/defgeneric-method-combination-and.lsp index f1dafff9..af5396ca 100644 --- a/ansi-tests/defgeneric-method-combination-and.lsp +++ b/ansi-tests/defgeneric-method-combination-and.lsp @@ -11,17 +11,17 @@ (deftest defgeneric-method-combination.and.1 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.and.1 (x) - (:method-combination and) - (:method and ((x integer)) (push 4 *x*) t) - (:method and ((x rational)) (push 3 *x*) nil) - (:method and ((x number)) (push 2 *x*) t) - (:method and ((x t)) (push 1 *x*) 'a))))) + (fn + (eval '(defgeneric dg-mc.fun.and.1 (x) + (:method-combination and) + (:method and ((x integer)) (push 4 *x*) t) + (:method and ((x rational)) (push 3 *x*) nil) + (:method and ((x number)) (push 2 *x*) t) + (:method and ((x t)) (push 1 *x*) 'a))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (nil (3 4)) (nil (3)) @@ -30,17 +30,17 @@ (deftest defgeneric-method-combination.and.2 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.and.2 (x) - (:method-combination and :most-specific-first) - (:method and ((x integer)) (push 4 *x*) t) - (:method and ((x rational)) (push 3 *x*) nil) - (:method and ((x number)) (push 2 *x*) t) - (:method and ((x t)) (push 1 *x*) 'a))))) + (fn + (eval '(defgeneric dg-mc.fun.and.2 (x) + (:method-combination and :most-specific-first) + (:method and ((x integer)) (push 4 *x*) t) + (:method and ((x rational)) (push 3 *x*) nil) + (:method and ((x number)) (push 2 *x*) t) + (:method and ((x t)) (push 1 *x*) 'a))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (nil (3 4)) (nil (3)) @@ -49,17 +49,17 @@ (deftest defgeneric-method-combination.and.3 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.and.3 (x) - (:method-combination and :most-specific-last) - (:method and ((x integer)) (push 4 *x*) t) - (:method and ((x rational)) (push 3 *x*) nil) - (:method and ((x number)) (push 2 *x*) 'a) - (:method and ((x t)) (push 1 *x*) t))))) + (fn + (eval '(defgeneric dg-mc.fun.and.3 (x) + (:method-combination and :most-specific-last) + (:method and ((x integer)) (push 4 *x*) t) + (:method and ((x rational)) (push 3 *x*) nil) + (:method and ((x number)) (push 2 *x*) 'a) + (:method and ((x t)) (push 1 *x*) t))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (nil (3 2 1)) (nil (3 2 1)) @@ -68,13 +68,13 @@ (deftest defgeneric-method-combination.and.4 (let ((fn - (eval '(defgeneric dg-mc.and.4 (x) - (:method-combination and) - (:method and ((x integer)) t) - (:method :around ((x rational)) 'foo) - (:method and ((x number)) nil) - (:method and ((x symbol)) t) - (:method and ((x t)) 'a))))) + (eval '(defgeneric dg-mc.and.4 (x) + (:method-combination and) + (:method and ((x integer)) t) + (:method :around ((x rational)) 'foo) + (:method and ((x number)) nil) + (:method and ((x symbol)) t) + (:method and ((x t)) 'a))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -86,14 +86,14 @@ (deftest defgeneric-method-combination.and.5 (let ((fn - (eval '(defgeneric dg-mc.and.5 (x) - (:method-combination and) - (:method and ((x integer)) nil) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method and ((x number)) 'a) - (:method and ((x symbol)) 'b) - (:method and ((x t)) 'c))))) + (eval '(defgeneric dg-mc.and.5 (x) + (:method-combination and) + (:method and ((x integer)) nil) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method and ((x number)) 'a) + (:method and ((x symbol)) 'b) + (:method and ((x t)) 'c))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -105,16 +105,16 @@ (deftest defgeneric-method-combination.and.6 (let ((fn - (eval '(defgeneric dg-mc.and.6 (x) - (:method-combination and) - (:method and ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method and ((x number)) nil) - (:method and ((x symbol)) 'c) - (:method and ((x t)) 'd))))) + (eval '(defgeneric dg-mc.and.6 (x) + (:method-combination and) + (:method and ((x integer)) 'a) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method :around ((x real)) + (list 'bar (call-next-method))) + (:method and ((x number)) nil) + (:method and ((x symbol)) 'c) + (:method and ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -127,12 +127,12 @@ (deftest defgeneric-method-combination.and.7 (let ((fn - (eval '(defgeneric dg-mc.and.7 (x) - (:method-combination and) - (:method and ((x dgmc-class-04)) 'c) - (:method and ((x dgmc-class-03)) 'b) - (:method and ((x dgmc-class-02)) nil) - (:method and ((x dgmc-class-01)) 'a))))) + (eval '(defgeneric dg-mc.and.7 (x) + (:method-combination and) + (:method and ((x dgmc-class-04)) 'c) + (:method and ((x dgmc-class-03)) 'b) + (:method and ((x dgmc-class-02)) nil) + (:method and ((x dgmc-class-01)) 'a))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) @@ -140,17 +140,17 @@ (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) a nil a nil) - + (deftest defgeneric-method-combination.and.8 (let ((fn - (eval '(defgeneric dg-mc.and.8 (x) - (:method-combination and) - (:method and ((x (eql 1000))) 'a) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method and ((x t)) 'b))))) + (eval '(defgeneric dg-mc.and.8 (x) + (:method-combination and) + (:method and ((x (eql 1000))) 'a) + (:method :around ((x symbol)) (values)) + (:method :around ((x integer)) (values 'a 'b 'c)) + (:method :around ((x complex)) (call-next-method)) + (:method :around ((x number)) (values 1 2 3 4 5 6)) + (:method and ((x t)) 'b))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) @@ -162,7 +162,7 @@ (deftest defgeneric-method-combination.and.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.and.9 (x) - (:method-combination and))))) + (:method-combination and))))) (declare (type generic-function fn)) (funcall fn 'x)) (error () :error)) @@ -171,8 +171,8 @@ (deftest defgeneric-method-combination.and.10 (progn (eval '(defgeneric dg-mc.and.10 (x) - (:method-combination and) - (:method ((x t)) t))) + (:method-combination and) + (:method ((x t)) t))) (handler-case (dg-mc.and.10 'a) (error () :error))) @@ -181,8 +181,8 @@ (deftest defgeneric-method-combination.and.11 (progn (eval '(defgeneric dg-mc.and.11 (x) - (:method-combination and) - (:method nonsense ((x t)) t))) + (:method-combination and) + (:method nonsense ((x t)) t))) (handler-case (dg-mc.and.11 0) (error () :error))) @@ -190,10 +190,10 @@ (deftest defgeneric-method-combination.and.12 (let ((fn (eval '(defgeneric dg-mc.and.12 (x) - (:method-combination and) - (:method :around ((x t)) t) - (:method and ((x integer)) x))))) + (:method-combination and) + (:method :around ((x t)) t) + (:method and ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'x) - (error () :error))) + (error () :error))) :error) diff --git a/ansi-tests/defgeneric-method-combination-append.lsp b/ansi-tests/defgeneric-method-combination-append.lsp index 5cbeb3d7..38987d7b 100644 --- a/ansi-tests/defgeneric-method-combination-append.lsp +++ b/ansi-tests/defgeneric-method-combination-append.lsp @@ -11,17 +11,17 @@ (deftest defgeneric-method-combination.append.1 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.append.1 (x) - (:method-combination append) - (:method append ((x integer)) (car (push '(d) *x*))) - (:method append ((x rational)) (car (push '(c) *x*))) - (:method append ((x number)) (car (push '(b) *x*))) - (:method append ((x t)) (car (push '(a) *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.append.1 (x) + (:method-combination append) + (:method append ((x integer)) (car (push '(d) *x*))) + (:method append ((x rational)) (car (push '(c) *x*))) + (:method append ((x number)) (car (push '(b) *x*))) + (:method append ((x t)) (car (push '(a) *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) ((a) (b) (c) (d))) ((c b a) ((a) (b) (c))) @@ -30,17 +30,17 @@ (deftest defgeneric-method-combination.append.2 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.append.2 (x) - (:method-combination append :most-specific-first) - (:method append ((x integer)) (car (push '(d) *x*))) - (:method append ((x rational)) (car (push '(c) *x*))) - (:method append ((x number)) (car (push '(b) *x*))) - (:method append ((x t)) (car (push '(a) *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.append.2 (x) + (:method-combination append :most-specific-first) + (:method append ((x integer)) (car (push '(d) *x*))) + (:method append ((x rational)) (car (push '(c) *x*))) + (:method append ((x number)) (car (push '(b) *x*))) + (:method append ((x t)) (car (push '(a) *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) ((a) (b) (c) (d))) ((c b a) ((a) (b) (c))) @@ -49,17 +49,17 @@ (deftest defgeneric-method-combination.append.3 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.append.3 (x) - (:method-combination append :most-specific-last) - (:method append ((x integer)) (car (push '(d) *x*))) - (:method append ((x rational)) (car (push '(c) *x*))) - (:method append ((x number)) (car (push '(b) *x*))) - (:method append ((x t)) (car (push '(a) *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.append.3 (x) + (:method-combination append :most-specific-last) + (:method append ((x integer)) (car (push '(d) *x*))) + (:method append ((x rational)) (car (push '(c) *x*))) + (:method append ((x number)) (car (push '(b) *x*))) + (:method append ((x t)) (car (push '(a) *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((a b c d) ((d) (c) (b) (a))) ((a b c) ((c) (b) (a))) @@ -68,13 +68,13 @@ (deftest defgeneric-method-combination.append.4 (let ((fn - (eval '(defgeneric dg-mc.fun.append.4 (x) - (:method-combination append) - (:method append ((x integer)) '(a b)) - (:method :around ((x rational)) 'foo) - (:method append ((x number)) '(c d)) - (:method append ((x symbol)) '(e f)) - (:method append ((x t)) '(g h)))))) + (eval '(defgeneric dg-mc.fun.append.4 (x) + (:method-combination append) + (:method append ((x integer)) '(a b)) + (:method :around ((x rational)) 'foo) + (:method append ((x number)) '(c d)) + (:method append ((x symbol)) '(e f)) + (:method append ((x t)) '(g h)))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -86,14 +86,14 @@ (deftest defgeneric-method-combination.append.5 (let ((fn - (eval '(defgeneric dg-mc.fun.append.5 (x) - (:method-combination append) - (:method append ((x integer)) '(a)) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method append ((x number)) '(b)) - (:method append ((x symbol)) '(c)) - (:method append ((x t)) 'd))))) + (eval '(defgeneric dg-mc.fun.append.5 (x) + (:method-combination append) + (:method append ((x integer)) '(a)) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method append ((x number)) '(b)) + (:method append ((x symbol)) '(c)) + (:method append ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -105,16 +105,16 @@ (deftest defgeneric-method-combination.append.6 (let ((fn - (eval '(defgeneric dg-mc.fun.append.6 (x) - (:method-combination append) - (:method append ((x integer)) '(a)) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method append ((x number)) '(b)) - (:method append ((x symbol)) '(c)) - (:method append ((x t)) '(d)))))) + (eval '(defgeneric dg-mc.fun.append.6 (x) + (:method-combination append) + (:method append ((x integer)) '(a)) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method :around ((x real)) + (list 'bar (call-next-method))) + (:method append ((x number)) '(b)) + (:method append ((x symbol)) '(c)) + (:method append ((x t)) '(d)))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -127,12 +127,12 @@ (deftest defgeneric-method-combination.append.7 (let ((fn - (eval '(defgeneric dg-mc.fun.append.7 (x) - (:method-combination append) - (:method append ((x dgmc-class-04)) '(a)) - (:method append ((x dgmc-class-03)) '(b)) - (:method append ((x dgmc-class-02)) '(c)) - (:method append ((x dgmc-class-01)) '(d)))))) + (eval '(defgeneric dg-mc.fun.append.7 (x) + (:method-combination append) + (:method append ((x dgmc-class-04)) '(a)) + (:method append ((x dgmc-class-03)) '(b)) + (:method append ((x dgmc-class-02)) '(c)) + (:method append ((x dgmc-class-01)) '(d)))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) @@ -146,14 +146,14 @@ (deftest defgeneric-method-combination.append.8 (let ((fn - (eval '(defgeneric dg-mc.append.8 (x) - (:method-combination append) - (:method append ((x (eql 1000))) '(a)) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method append ((x t)) '(b)))))) + (eval '(defgeneric dg-mc.append.8 (x) + (:method-combination append) + (:method append ((x (eql 1000))) '(a)) + (:method :around ((x symbol)) (values)) + (:method :around ((x integer)) (values 'a 'b 'c)) + (:method :around ((x complex)) (call-next-method)) + (:method :around ((x number)) (values 1 2 3 4 5 6)) + (:method append ((x t)) '(b)))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) @@ -165,7 +165,7 @@ (deftest defgeneric-method-combination.append.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.append.9 (x) - (:method-combination append))))) + (:method-combination append))))) (declare (type generic-function fn)) (funcall fn '(a))) (error () :error)) @@ -174,8 +174,8 @@ (deftest defgeneric-method-combination.append.10 (progn (eval '(defgeneric dg-mc.append.10 (x) - (:method-combination append) - (:method ((x t)) '(a)))) + (:method-combination append) + (:method ((x t)) '(a)))) (handler-case (dg-mc.append.10 'x) (error () :error))) @@ -184,8 +184,8 @@ (deftest defgeneric-method-combination.append.11 (progn (eval '(defgeneric dg-mc.append.11 (x) - (:method-combination append) - (:method nonsense ((x t)) '(a)))) + (:method-combination append) + (:method nonsense ((x t)) '(a)))) (handler-case (dg-mc.append.11 0) (error () :error))) @@ -193,21 +193,21 @@ (deftest defgeneric-method-combination.append.12 (let ((fn (eval '(defgeneric dg-mc.append.12 (x) - (:method-combination append) - (:method :around ((x t)) '(a)) - (:method append ((x integer)) x))))) + (:method-combination append) + (:method :around ((x t)) '(a)) + (:method append ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn '(b)) - (error () :error))) + (error () :error))) :error) (deftest defgeneric-method-combination.append.13 (progn (eval '(defgeneric dg-mc.append.13 (x) - (:method-combination append) - (:method append ((x dgmc-class-01)) (list 'foo)) - (:method append ((x dgmc-class-02)) (list 'bar)) - (:method nonsense ((x dgmc-class-03)) (list 'bad)))) + (:method-combination append) + (:method append ((x dgmc-class-01)) (list 'foo)) + (:method append ((x dgmc-class-02)) (list 'bar)) + (:method nonsense ((x dgmc-class-03)) (list 'bad)))) (values (dg-mc.append.13 (make-instance 'dgmc-class-01)) (dg-mc.append.13 (make-instance 'dgmc-class-02)) diff --git a/ansi-tests/defgeneric-method-combination-list.lsp b/ansi-tests/defgeneric-method-combination-list.lsp index 370ae32d..860285a3 100644 --- a/ansi-tests/defgeneric-method-combination-list.lsp +++ b/ansi-tests/defgeneric-method-combination-list.lsp @@ -11,17 +11,17 @@ (deftest defgeneric-method-combination.list.1 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.list.1 (x) - (:method-combination list) - (:method list ((x integer)) (car (push 'd *x*))) - (:method list ((x rational)) (car (push 'c *x*))) - (:method list ((x number)) (car (push 'b *x*))) - (:method list ((x t)) (car (push 'a *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.list.1 (x) + (:method-combination list) + (:method list ((x integer)) (car (push 'd *x*))) + (:method list ((x rational)) (car (push 'c *x*))) + (:method list ((x number)) (car (push 'b *x*))) + (:method list ((x t)) (car (push 'a *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) (a b c d)) ((c b a) (a b c)) @@ -30,17 +30,17 @@ (deftest defgeneric-method-combination.list.2 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.list.2 (x) - (:method-combination list :most-specific-first) - (:method list ((x integer)) (car (push 'd *x*))) - (:method list ((x rational)) (car (push 'c *x*))) - (:method list ((x number)) (car (push 'b *x*))) - (:method list ((x t)) (car (push 'a *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.list.2 (x) + (:method-combination list :most-specific-first) + (:method list ((x integer)) (car (push 'd *x*))) + (:method list ((x rational)) (car (push 'c *x*))) + (:method list ((x number)) (car (push 'b *x*))) + (:method list ((x t)) (car (push 'a *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) (a b c d)) ((c b a) (a b c)) @@ -49,17 +49,17 @@ (deftest defgeneric-method-combination.list.3 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.list.3 (x) - (:method-combination list :most-specific-last) - (:method list ((x integer)) (car (push 'd *x*))) - (:method list ((x rational)) (car (push 'c *x*))) - (:method list ((x number)) (car (push 'b *x*))) - (:method list ((x t)) (car (push 'a *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.list.3 (x) + (:method-combination list :most-specific-last) + (:method list ((x integer)) (car (push 'd *x*))) + (:method list ((x rational)) (car (push 'c *x*))) + (:method list ((x number)) (car (push 'b *x*))) + (:method list ((x t)) (car (push 'a *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((a b c d) (d c b a)) ((a b c) (c b a)) @@ -68,13 +68,13 @@ (deftest defgeneric-method-combination.list.4 (let ((fn - (eval '(defgeneric dg-mc.fun.list.4 (x) - (:method-combination list) - (:method list ((x integer)) '(a b)) - (:method :around ((x rational)) 'foo) - (:method list ((x number)) '(c d)) - (:method list ((x symbol)) '(e f)) - (:method list ((x t)) '(g h)))))) + (eval '(defgeneric dg-mc.fun.list.4 (x) + (:method-combination list) + (:method list ((x integer)) '(a b)) + (:method :around ((x rational)) 'foo) + (:method list ((x number)) '(c d)) + (:method list ((x symbol)) '(e f)) + (:method list ((x t)) '(g h)))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -86,14 +86,14 @@ (deftest defgeneric-method-combination.list.5 (let ((fn - (eval '(defgeneric dg-mc.fun.list.5 (x) - (:method-combination list) - (:method list ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method list ((x number)) 'b) - (:method list ((x symbol)) 'c) - (:method list ((x t)) 'd))))) + (eval '(defgeneric dg-mc.fun.list.5 (x) + (:method-combination list) + (:method list ((x integer)) 'a) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method list ((x number)) 'b) + (:method list ((x symbol)) 'c) + (:method list ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -105,16 +105,16 @@ (deftest defgeneric-method-combination.list.6 (let ((fn - (eval '(defgeneric dg-mc.fun.list.6 (x) - (:method-combination list) - (:method list ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method list ((x number)) 'b) - (:method list ((x symbol)) 'c) - (:method list ((x t)) 'd))))) + (eval '(defgeneric dg-mc.fun.list.6 (x) + (:method-combination list) + (:method list ((x integer)) 'a) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method :around ((x real)) + (list 'bar (call-next-method))) + (:method list ((x number)) 'b) + (:method list ((x symbol)) 'c) + (:method list ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -127,12 +127,12 @@ (deftest defgeneric-method-combination.list.7 (let ((fn - (eval '(defgeneric dg-mc.fun.list.7 (x) - (:method-combination list) - (:method list ((x dgmc-class-04)) 'a) - (:method list ((x dgmc-class-03)) 'b) - (:method list ((x dgmc-class-02)) 'c) - (:method list ((x dgmc-class-01)) 'd))))) + (eval '(defgeneric dg-mc.fun.list.7 (x) + (:method-combination list) + (:method list ((x dgmc-class-04)) 'a) + (:method list ((x dgmc-class-03)) 'b) + (:method list ((x dgmc-class-02)) 'c) + (:method list ((x dgmc-class-01)) 'd))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) @@ -146,14 +146,14 @@ (deftest defgeneric-method-combination.list.8 (let ((fn - (eval '(defgeneric dg-mc.list.8 (x) - (:method-combination list) - (:method list ((x (eql 1000))) 'a) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method list ((x t)) 'b))))) + (eval '(defgeneric dg-mc.list.8 (x) + (:method-combination list) + (:method list ((x (eql 1000))) 'a) + (:method :around ((x symbol)) (values)) + (:method :around ((x integer)) (values 'a 'b 'c)) + (:method :around ((x complex)) (call-next-method)) + (:method :around ((x number)) (values 1 2 3 4 5 6)) + (:method list ((x t)) 'b))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) @@ -165,7 +165,7 @@ (deftest defgeneric-method-combination.list.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.list.9 (x) - (:method-combination list))))) + (:method-combination list))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) @@ -174,8 +174,8 @@ (deftest defgeneric-method-combination.list.10 (progn (eval '(defgeneric dg-mc.list.10 (x) - (:method-combination list) - (:method ((x t)) (list 'a)))) + (:method-combination list) + (:method ((x t)) (list 'a)))) (handler-case (dg-mc.list.10 'a) (error () :error))) @@ -184,8 +184,8 @@ (deftest defgeneric-method-combination.list.11 (progn (eval '(defgeneric dg-mc.list.11 (x) - (:method-combination list) - (:method nonsense ((x t)) (list 'a)))) + (:method-combination list) + (:method nonsense ((x t)) (list 'a)))) (handler-case (dg-mc.list.11 0) (error () :error))) @@ -193,10 +193,10 @@ (deftest defgeneric-method-combination.list.12 (let ((fn (eval '(defgeneric dg-mc.list.12 (x) - (:method-combination list) - (:method :around ((x t)) (list 'a)) - (:method list ((x integer)) x))))) + (:method-combination list) + (:method :around ((x t)) (list 'a)) + (:method list ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn (list 'b)) - (error () :error))) + (error () :error))) :error) diff --git a/ansi-tests/defgeneric-method-combination-max.lsp b/ansi-tests/defgeneric-method-combination-max.lsp index 9c5e76c9..b966d0b4 100644 --- a/ansi-tests/defgeneric-method-combination-max.lsp +++ b/ansi-tests/defgeneric-method-combination-max.lsp @@ -11,61 +11,61 @@ (deftest defgeneric-method-combination.max.1 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.max.1 (x) - (:method-combination max) - (:method max ((x integer)) (car (push 8 *x*))) - (:method max ((x rational)) (car (push 4 *x*))) - (:method max ((x number)) (car (push 2 *x*))) - (:method max ((x t)) (car (push 1 *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.max.1 (x) + (:method-combination max) + (:method max ((x integer)) (car (push 8 *x*))) + (:method max ((x rational)) (car (push 4 *x*))) + (:method max ((x number)) (car (push 2 *x*))) + (:method max ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (8 (1 2 4 8)) (4 (1 2 4)) (2 (1 2)) (1 (1))) (deftest defgeneric-method-combination.max.2 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.max.2 (x) - (:method-combination max :most-specific-first) - (:method max ((x integer)) (car (push 8 *x*))) - (:method max ((x rational)) (car (push 4 *x*))) - (:method max ((x number)) (car (push 2 *x*))) - (:method max ((x t)) (car (push 1 *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.max.2 (x) + (:method-combination max :most-specific-first) + (:method max ((x integer)) (car (push 8 *x*))) + (:method max ((x rational)) (car (push 4 *x*))) + (:method max ((x number)) (car (push 2 *x*))) + (:method max ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (8 (1 2 4 8)) (4 (1 2 4)) (2 (1 2)) (1 (1))) (deftest defgeneric-method-combination.max.3 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.max.3 (x) - (:method-combination max :most-specific-last) - (:method max ((x integer)) (car (push 8 *x*))) - (:method max ((x rational)) (car (push 4 *x*))) - (:method max ((x number)) (car (push 2 *x*))) - (:method max ((x t)) (car (push 1 *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.max.3 (x) + (:method-combination max :most-specific-last) + (:method max ((x integer)) (car (push 8 *x*))) + (:method max ((x rational)) (car (push 4 *x*))) + (:method max ((x number)) (car (push 2 *x*))) + (:method max ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (8 (8 4 2 1)) (4 (4 2 1)) (2 (2 1)) (1 (1))) (deftest defgeneric-method-combination.max.4 (let ((fn - (eval '(defgeneric dg-mc.max.4 (x) - (:method-combination max) - (:method max ((x integer)) 4) - (:method :around ((x rational)) 'foo) - (:method max ((x number)) 3) - (:method max ((x symbol)) 5) - (:method max ((x t)) 1))))) + (eval '(defgeneric dg-mc.max.4 (x) + (:method-combination max) + (:method max ((x integer)) 4) + (:method :around ((x rational)) 'foo) + (:method max ((x number)) 3) + (:method max ((x symbol)) 5) + (:method max ((x t)) 1))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -77,14 +77,14 @@ (deftest defgeneric-method-combination.max.5 (let ((fn - (eval '(defgeneric dg-mc.max.5 (x) - (:method-combination max) - (:method max ((x integer)) 5) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method max ((x number)) 5/2) - (:method max ((x symbol)) 4) - (:method max ((x t)) 1.0))))) + (eval '(defgeneric dg-mc.max.5 (x) + (:method-combination max) + (:method max ((x integer)) 5) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method max ((x number)) 5/2) + (:method max ((x symbol)) 4) + (:method max ((x t)) 1.0))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -96,16 +96,16 @@ (deftest defgeneric-method-combination.max.6 (let ((fn - (eval '(defgeneric dg-mc.max.6 (x) - (:method-combination max) - (:method max ((x integer)) 9) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method max ((x number)) 4) - (:method max ((x symbol)) 6) - (:method max ((x t)) 1))))) + (eval '(defgeneric dg-mc.max.6 (x) + (:method-combination max) + (:method max ((x integer)) 9) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method :around ((x real)) + (list 'bar (call-next-method))) + (:method max ((x number)) 4) + (:method max ((x symbol)) 6) + (:method max ((x t)) 1))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -118,12 +118,12 @@ (deftest defgeneric-method-combination.max.7 (let ((fn - (eval '(defgeneric dg-mc.max.7 (x) - (:method-combination max) - (:method max ((x dgmc-class-04)) 4) - (:method max ((x dgmc-class-03)) 3) - (:method max ((x dgmc-class-02)) 5) - (:method max ((x dgmc-class-01)) 1))))) + (eval '(defgeneric dg-mc.max.7 (x) + (:method-combination max) + (:method max ((x dgmc-class-04)) 4) + (:method max ((x dgmc-class-03)) 3) + (:method max ((x dgmc-class-02)) 5) + (:method max ((x dgmc-class-01)) 1))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) @@ -134,14 +134,14 @@ (deftest defgeneric-method-combination.max.8 (let ((fn - (eval '(defgeneric dg-mc.max.8 (x) - (:method-combination max) - (:method max ((x (eql 1000))) 4) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method max ((x t)) 1))))) + (eval '(defgeneric dg-mc.max.8 (x) + (:method-combination max) + (:method max ((x (eql 1000))) 4) + (:method :around ((x symbol)) (values)) + (:method :around ((x integer)) (values 'a 'b 'c)) + (:method :around ((x complex)) (call-next-method)) + (:method :around ((x number)) (values 1 2 3 4 5 6)) + (:method max ((x t)) 1))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) @@ -153,7 +153,7 @@ (deftest defgeneric-method-combination.max.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.max.9 (x) - (:method-combination max))))) + (:method-combination max))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) @@ -162,8 +162,8 @@ (deftest defgeneric-method-combination.max.10 (progn (eval '(defgeneric dg-mc.max.10 (x) - (:method-combination max) - (:method ((x t)) 0))) + (:method-combination max) + (:method ((x t)) 0))) (handler-case (dg-mc.max.10 'a) (error () :error))) @@ -172,8 +172,8 @@ (deftest defgeneric-method-combination.max.11 (progn (eval '(defgeneric dg-mc.max.11 (x) - (:method-combination max) - (:method nonsense ((x t)) 0))) + (:method-combination max) + (:method nonsense ((x t)) 0))) (handler-case (dg-mc.max.11 0) (error () :error))) @@ -181,10 +181,10 @@ (deftest defgeneric-method-combination.max.12 (let ((fn (eval '(defgeneric dg-mc.max.12 (x) - (:method-combination max) - (:method :around ((x t)) 1) - (:method max ((x integer)) x))))) + (:method-combination max) + (:method :around ((x t)) 1) + (:method max ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'a) - (error () :error))) + (error () :error))) :error) diff --git a/ansi-tests/defgeneric-method-combination-min.lsp b/ansi-tests/defgeneric-method-combination-min.lsp index 5b313b00..2aca3715 100644 --- a/ansi-tests/defgeneric-method-combination-min.lsp +++ b/ansi-tests/defgeneric-method-combination-min.lsp @@ -11,61 +11,61 @@ (deftest defgeneric-method-combination.min.1 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.min.1 (x) - (:method-combination min) - (:method min ((x integer)) (car (push 1 *x*))) - (:method min ((x rational)) (car (push 2 *x*))) - (:method min ((x number)) (car (push 3 *x*))) - (:method min ((x t)) (car (push 4 *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.min.1 (x) + (:method-combination min) + (:method min ((x integer)) (car (push 1 *x*))) + (:method min ((x rational)) (car (push 2 *x*))) + (:method min ((x number)) (car (push 3 *x*))) + (:method min ((x t)) (car (push 4 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (1 (4 3 2 1)) (2 (4 3 2)) (3 (4 3)) (4 (4))) (deftest defgeneric-method-combination.min.2 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.min.2 (x) - (:method-combination min :most-specific-first) - (:method min ((x integer)) (car (push 1 *x*))) - (:method min ((x rational)) (car (push 2 *x*))) - (:method min ((x number)) (car (push 3 *x*))) - (:method min ((x t)) (car (push 4 *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.min.2 (x) + (:method-combination min :most-specific-first) + (:method min ((x integer)) (car (push 1 *x*))) + (:method min ((x rational)) (car (push 2 *x*))) + (:method min ((x number)) (car (push 3 *x*))) + (:method min ((x t)) (car (push 4 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (1 (4 3 2 1)) (2 (4 3 2)) (3 (4 3)) (4 (4))) (deftest defgeneric-method-combination.min.3 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.min.3 (x) - (:method-combination min :most-specific-last) - (:method min ((x integer)) (car (push 1 *x*))) - (:method min ((x rational)) (car (push 2 *x*))) - (:method min ((x number)) (car (push 3 *x*))) - (:method min ((x t)) (car (push 4 *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.min.3 (x) + (:method-combination min :most-specific-last) + (:method min ((x integer)) (car (push 1 *x*))) + (:method min ((x rational)) (car (push 2 *x*))) + (:method min ((x number)) (car (push 3 *x*))) + (:method min ((x t)) (car (push 4 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (1 (1 2 3 4)) (2 (2 3 4)) (3 (3 4)) (4 (4))) (deftest defgeneric-method-combination.min.4 (let ((fn - (eval '(defgeneric dg-mc.min.4 (x) - (:method-combination min) - (:method min ((x integer)) 1) - (:method :around ((x rational)) 'foo) - (:method min ((x number)) 2) - (:method min ((x symbol)) 3) - (:method min ((x t)) 4))))) + (eval '(defgeneric dg-mc.min.4 (x) + (:method-combination min) + (:method min ((x integer)) 1) + (:method :around ((x rational)) 'foo) + (:method min ((x number)) 2) + (:method min ((x symbol)) 3) + (:method min ((x t)) 4))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -77,14 +77,14 @@ (deftest defgeneric-method-combination.min.5 (let ((fn - (eval '(defgeneric dg-mc.min.5 (x) - (:method-combination min) - (:method min ((x integer)) 1) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method min ((x number)) 2) - (:method min ((x symbol)) 4) - (:method min ((x t)) 8))))) + (eval '(defgeneric dg-mc.min.5 (x) + (:method-combination min) + (:method min ((x integer)) 1) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method min ((x number)) 2) + (:method min ((x symbol)) 4) + (:method min ((x t)) 8))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -96,16 +96,16 @@ (deftest defgeneric-method-combination.min.6 (let ((fn - (eval '(defgeneric dg-mc.min.6 (x) - (:method-combination min) - (:method min ((x integer)) 1) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method min ((x number)) 2) - (:method min ((x symbol)) 4) - (:method min ((x t)) 8))))) + (eval '(defgeneric dg-mc.min.6 (x) + (:method-combination min) + (:method min ((x integer)) 1) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method :around ((x real)) + (list 'bar (call-next-method))) + (:method min ((x number)) 2) + (:method min ((x symbol)) 4) + (:method min ((x t)) 8))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -118,12 +118,12 @@ (deftest defgeneric-method-combination.min.7 (let ((fn - (eval '(defgeneric dg-mc.min.7 (x) - (:method-combination min) - (:method min ((x dgmc-class-04)) 1) - (:method min ((x dgmc-class-03)) 2) - (:method min ((x dgmc-class-02)) 4) - (:method min ((x dgmc-class-01)) 8))))) + (eval '(defgeneric dg-mc.min.7 (x) + (:method-combination min) + (:method min ((x dgmc-class-04)) 1) + (:method min ((x dgmc-class-03)) 2) + (:method min ((x dgmc-class-02)) 4) + (:method min ((x dgmc-class-01)) 8))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) @@ -134,14 +134,14 @@ (deftest defgeneric-method-combination.min.8 (let ((fn - (eval '(defgeneric dg-mc.min.8 (x) - (:method-combination min) - (:method min ((x (eql 1000))) 0) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method min ((x t)) 1))))) + (eval '(defgeneric dg-mc.min.8 (x) + (:method-combination min) + (:method min ((x (eql 1000))) 0) + (:method :around ((x symbol)) (values)) + (:method :around ((x integer)) (values 'a 'b 'c)) + (:method :around ((x complex)) (call-next-method)) + (:method :around ((x number)) (values 1 2 3 4 5 6)) + (:method min ((x t)) 1))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) @@ -153,7 +153,7 @@ (deftest defgeneric-method-combination.min.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.min.9 (x) - (:method-combination min))))) + (:method-combination min))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) @@ -162,8 +162,8 @@ (deftest defgeneric-method-combination.min.10 (progn (eval '(defgeneric dg-mc.min.10 (x) - (:method-combination min) - (:method ((x t)) 0))) + (:method-combination min) + (:method ((x t)) 0))) (handler-case (dg-mc.min.10 'a) (error () :error))) @@ -172,8 +172,8 @@ (deftest defgeneric-method-combination.min.11 (progn (eval '(defgeneric dg-mc.min.11 (x) - (:method-combination min) - (:method nonsense ((x t)) 0))) + (:method-combination min) + (:method nonsense ((x t)) 0))) (handler-case (dg-mc.min.11 0) (error () :error))) @@ -181,11 +181,11 @@ (deftest defgeneric-method-combination.min.12 (let ((fn (eval '(defgeneric dg-mc.min.12 (x) - (:method-combination min) - (:method :around ((x t)) 1) - (:method min ((x integer)) x))))) + (:method-combination min) + (:method :around ((x t)) 1) + (:method min ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'a) - (error () :error))) + (error () :error))) :error) diff --git a/ansi-tests/defgeneric-method-combination-nconc.lsp b/ansi-tests/defgeneric-method-combination-nconc.lsp index 44cb1f85..3d39aee6 100644 --- a/ansi-tests/defgeneric-method-combination-nconc.lsp +++ b/ansi-tests/defgeneric-method-combination-nconc.lsp @@ -11,21 +11,21 @@ (deftest defgeneric-method-combination.nconc.1 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.nconc.1 (x) - (:method-combination nconc) - (:method nconc ((x integer)) - (copy-list (car (push '(d) *x*)))) - (:method nconc ((x rational)) - (copy-list (car (push '(c) *x*)))) - (:method nconc ((x number)) - (copy-list (car (push '(b) *x*)))) - (:method nconc ((x t)) - (copy-list (car (push '(a) *x*)))))))) + (fn + (eval '(defgeneric dg-mc.fun.nconc.1 (x) + (:method-combination nconc) + (:method nconc ((x integer)) + (copy-list (car (push '(d) *x*)))) + (:method nconc ((x rational)) + (copy-list (car (push '(c) *x*)))) + (:method nconc ((x number)) + (copy-list (car (push '(b) *x*)))) + (:method nconc ((x t)) + (copy-list (car (push '(a) *x*)))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) ((a) (b) (c) (d))) ((c b a) ((a) (b) (c))) @@ -34,21 +34,21 @@ (deftest defgeneric-method-combination.nconc.2 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.nconc.2 (x) - (:method-combination nconc :most-specific-first) - (:method nconc ((x integer)) - (copy-list (car (push '(d) *x*)))) - (:method nconc ((x rational)) - (copy-list (car (push '(c) *x*)))) - (:method nconc ((x number)) - (copy-list (car (push '(b) *x*)))) - (:method nconc ((x t)) - (copy-list (car (push '(a) *x*)))))))) + (fn + (eval '(defgeneric dg-mc.fun.nconc.2 (x) + (:method-combination nconc :most-specific-first) + (:method nconc ((x integer)) + (copy-list (car (push '(d) *x*)))) + (:method nconc ((x rational)) + (copy-list (car (push '(c) *x*)))) + (:method nconc ((x number)) + (copy-list (car (push '(b) *x*)))) + (:method nconc ((x t)) + (copy-list (car (push '(a) *x*)))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((d c b a) ((a) (b) (c) (d))) ((c b a) ((a) (b) (c))) @@ -57,21 +57,21 @@ (deftest defgeneric-method-combination.nconc.3 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.nconc.3 (x) - (:method-combination nconc :most-specific-last) - (:method nconc ((x integer)) - (copy-list (car (push '(d) *x*)))) - (:method nconc ((x rational)) - (copy-list (car (push '(c) *x*)))) - (:method nconc ((x number)) - (copy-list (car (push '(b) *x*)))) - (:method nconc ((x t)) - (copy-list (car (push '(a) *x*)))))))) + (fn + (eval '(defgeneric dg-mc.fun.nconc.3 (x) + (:method-combination nconc :most-specific-last) + (:method nconc ((x integer)) + (copy-list (car (push '(d) *x*)))) + (:method nconc ((x rational)) + (copy-list (car (push '(c) *x*)))) + (:method nconc ((x number)) + (copy-list (car (push '(b) *x*)))) + (:method nconc ((x t)) + (copy-list (car (push '(a) *x*)))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) ((a b c d) ((d) (c) (b) (a))) ((a b c) ((c) (b) (a))) @@ -80,13 +80,13 @@ (deftest defgeneric-method-combination.nconc.4 (let ((fn - (eval '(defgeneric dg-mc.fun.nconc.4 (x) - (:method-combination nconc) - (:method nconc ((x integer)) (list 'a 'b)) - (:method :around ((x rational)) 'foo) - (:method nconc ((x number)) (list 'c 'd)) - (:method nconc ((x symbol)) (list 'e 'f)) - (:method nconc ((x t)) (list 'g 'h)))))) + (eval '(defgeneric dg-mc.fun.nconc.4 (x) + (:method-combination nconc) + (:method nconc ((x integer)) (list 'a 'b)) + (:method :around ((x rational)) 'foo) + (:method nconc ((x number)) (list 'c 'd)) + (:method nconc ((x symbol)) (list 'e 'f)) + (:method nconc ((x t)) (list 'g 'h)))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -98,14 +98,14 @@ (deftest defgeneric-method-combination.nconc.5 (let ((fn - (eval '(defgeneric dg-mc.fun.nconc.5 (x) - (:method-combination nconc) - (:method nconc ((x integer)) (list 'a)) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method nconc ((x number)) (list 'b)) - (:method nconc ((x symbol)) (list 'c)) - (:method nconc ((x t)) (cons 'd 'e)))))) + (eval '(defgeneric dg-mc.fun.nconc.5 (x) + (:method-combination nconc) + (:method nconc ((x integer)) (list 'a)) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method nconc ((x number)) (list 'b)) + (:method nconc ((x symbol)) (list 'c)) + (:method nconc ((x t)) (cons 'd 'e)))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -117,16 +117,16 @@ (deftest defgeneric-method-combination.nconc.6 (let ((fn - (eval '(defgeneric dg-mc.fun.nconc.6 (x) - (:method-combination nconc) - (:method nconc ((x integer)) (list 'a)) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method nconc ((x number)) (list 'b)) - (:method nconc ((x symbol)) (list 'c)) - (:method nconc ((x t)) (list 'd)))))) + (eval '(defgeneric dg-mc.fun.nconc.6 (x) + (:method-combination nconc) + (:method nconc ((x integer)) (list 'a)) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method :around ((x real)) + (list 'bar (call-next-method))) + (:method nconc ((x number)) (list 'b)) + (:method nconc ((x symbol)) (list 'c)) + (:method nconc ((x t)) (list 'd)))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -139,12 +139,12 @@ (deftest defgeneric-method-combination.nconc.7 (let ((fn - (eval '(defgeneric dg-mc.fun.nconc.7 (x) - (:method-combination nconc) - (:method nconc ((x dgmc-class-04)) (list 'a)) - (:method nconc ((x dgmc-class-03)) (list 'b)) - (:method nconc ((x dgmc-class-02)) (list 'c)) - (:method nconc ((x dgmc-class-01)) (list 'd)))))) + (eval '(defgeneric dg-mc.fun.nconc.7 (x) + (:method-combination nconc) + (:method nconc ((x dgmc-class-04)) (list 'a)) + (:method nconc ((x dgmc-class-03)) (list 'b)) + (:method nconc ((x dgmc-class-02)) (list 'c)) + (:method nconc ((x dgmc-class-01)) (list 'd)))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) @@ -158,14 +158,14 @@ (deftest defgeneric-method-combination.nconc.8 (let ((fn - (eval '(defgeneric dg-mc.nconc.8 (x) - (:method-combination nconc) - (:method nconc ((x (eql 1000))) (list 'a)) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method nconc ((x t)) (list 'b)))))) + (eval '(defgeneric dg-mc.nconc.8 (x) + (:method-combination nconc) + (:method nconc ((x (eql 1000))) (list 'a)) + (:method :around ((x symbol)) (values)) + (:method :around ((x integer)) (values 'a 'b 'c)) + (:method :around ((x complex)) (call-next-method)) + (:method :around ((x number)) (values 1 2 3 4 5 6)) + (:method nconc ((x t)) (list 'b)))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) @@ -177,7 +177,7 @@ (deftest defgeneric-method-combination.nconc.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.nconc.9 (x) - (:method-combination nconc))))) + (:method-combination nconc))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) @@ -186,8 +186,8 @@ (deftest defgeneric-method-combination.nconc.10 (progn (eval '(defgeneric dg-mc.nconc.10 (x) - (:method-combination nconc) - (:method ((x t)) (list 'a)))) + (:method-combination nconc) + (:method ((x t)) (list 'a)))) (handler-case (dg-mc.nconc.10 'a) (error () :error))) @@ -196,8 +196,8 @@ (deftest defgeneric-method-combination.nconc.11 (progn (eval '(defgeneric dg-mc.nconc.11 (x) - (:method-combination nconc) - (:method nonsense ((x t)) (list 'a)))) + (:method-combination nconc) + (:method nonsense ((x t)) (list 'a)))) (handler-case (dg-mc.nconc.11 0) (error () :error))) @@ -205,10 +205,10 @@ (deftest defgeneric-method-combination.nconc.12 (let ((fn (eval '(defgeneric dg-mc.nconc.12 (x) - (:method-combination nconc) - (:method :around ((x t)) (list 'a)) - (:method nconc ((x integer)) x))))) + (:method-combination nconc) + (:method :around ((x t)) (list 'a)) + (:method nconc ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn (list 'b)) - (error () :error))) + (error () :error))) :error) diff --git a/ansi-tests/defgeneric-method-combination-or.lsp b/ansi-tests/defgeneric-method-combination-or.lsp index 67627a1e..9b00e3ec 100644 --- a/ansi-tests/defgeneric-method-combination-or.lsp +++ b/ansi-tests/defgeneric-method-combination-or.lsp @@ -11,17 +11,17 @@ (deftest defgeneric-method-combination.or.1 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.or.1 (x) - (:method-combination or) - (:method or ((x integer)) (push 4 *x*) nil) - (:method or ((x rational)) (push 3 *x*) nil) - (:method or ((x number)) (push 2 *x*) nil) - (:method or ((x t)) (push 1 *x*) 'a))))) + (fn + (eval '(defgeneric dg-mc.fun.or.1 (x) + (:method-combination or) + (:method or ((x integer)) (push 4 *x*) nil) + (:method or ((x rational)) (push 3 *x*) nil) + (:method or ((x number)) (push 2 *x*) nil) + (:method or ((x t)) (push 1 *x*) 'a))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (1 2 3 4)) (a (1 2 3)) @@ -30,45 +30,45 @@ (deftest defgeneric-method-combination.or.2 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.or.2 (x) - (:method-combination or :most-specific-first) - (:method or ((x integer)) (push 4 *x*) nil) - (:method or ((x rational)) (push 3 *x*) 'a) - (:method or ((x number)) (push 2 *x*) nil) - (:method or ((x t)) (push 1 *x*) 'b))))) + (fn + (eval '(defgeneric dg-mc.fun.or.2 (x) + (:method-combination or :most-specific-first) + (:method or ((x integer)) (push 4 *x*) nil) + (:method or ((x rational)) (push 3 *x*) 'a) + (:method or ((x number)) (push 2 *x*) nil) + (:method or ((x t)) (push 1 *x*) 'b))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (3 4)) (a (3)) (b (1 2)) (b (1))) (deftest defgeneric-method-combination.or.3 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.or.3 (x) - (:method-combination or :most-specific-last) - (:method or ((x integer)) (push 4 *x*) 'a) - (:method or ((x rational)) (push 3 *x*) nil) - (:method or ((x number)) (push 2 *x*) nil) - (:method or ((x t)) (push 1 *x*) nil))))) + (fn + (eval '(defgeneric dg-mc.fun.or.3 (x) + (:method-combination or :most-specific-last) + (:method or ((x integer)) (push 4 *x*) 'a) + (:method or ((x rational)) (push 3 *x*) nil) + (:method or ((x number)) (push 2 *x*) nil) + (:method or ((x t)) (push 1 *x*) nil))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (4 3 2 1)) (nil (3 2 1)) (nil (2 1)) (nil (1))) (deftest defgeneric-method-combination.or.4 (let ((fn - (eval '(defgeneric dg-mc.or.4 (x) - (:method-combination or) - (:method or ((x integer)) nil) - (:method :around ((x rational)) 'foo) - (:method or ((x number)) 'b) - (:method or ((x symbol)) nil) - (:method or ((x t)) 'a))))) + (eval '(defgeneric dg-mc.or.4 (x) + (:method-combination or) + (:method or ((x integer)) nil) + (:method :around ((x rational)) 'foo) + (:method or ((x number)) 'b) + (:method or ((x symbol)) nil) + (:method or ((x t)) 'a))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -80,14 +80,14 @@ (deftest defgeneric-method-combination.or.5 (let ((fn - (eval '(defgeneric dg-mc.or.5 (x) - (:method-combination or) - (:method or ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method or ((x number)) nil) - (:method or ((x symbol)) 'b) - (:method or ((x t)) 'c))))) + (eval '(defgeneric dg-mc.or.5 (x) + (:method-combination or) + (:method or ((x integer)) 'a) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method or ((x number)) nil) + (:method or ((x symbol)) 'b) + (:method or ((x t)) 'c))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -99,16 +99,16 @@ (deftest defgeneric-method-combination.or.6 (let ((fn - (eval '(defgeneric dg-mc.or.6 (x) - (:method-combination or) - (:method or ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method or ((x number)) 'b) - (:method or ((x symbol)) 'c) - (:method or ((x t)) 'd))))) + (eval '(defgeneric dg-mc.or.6 (x) + (:method-combination or) + (:method or ((x integer)) 'a) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method :around ((x real)) + (list 'bar (call-next-method))) + (:method or ((x number)) 'b) + (:method or ((x symbol)) 'c) + (:method or ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -121,12 +121,12 @@ (deftest defgeneric-method-combination.or.7 (let ((fn - (eval '(defgeneric dg-mc.or.7 (x) - (:method-combination or) - (:method or ((x dgmc-class-04)) nil) - (:method or ((x dgmc-class-03)) nil) - (:method or ((x dgmc-class-02)) 'b) - (:method or ((x dgmc-class-01)) 'c))))) + (eval '(defgeneric dg-mc.or.7 (x) + (:method-combination or) + (:method or ((x dgmc-class-04)) nil) + (:method or ((x dgmc-class-03)) nil) + (:method or ((x dgmc-class-02)) 'b) + (:method or ((x dgmc-class-01)) 'c))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) @@ -134,17 +134,17 @@ (funcall fn (make-instance 'dgmc-class-03)) (funcall fn (make-instance 'dgmc-class-04)))) c b c b) - + (deftest defgeneric-method-combination.or.8 (let ((fn - (eval '(defgeneric dg-mc.or.8 (x) - (:method-combination or) - (:method or ((x (eql 1000))) 'a) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method or ((x t)) 'b))))) + (eval '(defgeneric dg-mc.or.8 (x) + (:method-combination or) + (:method or ((x (eql 1000))) 'a) + (:method :around ((x symbol)) (values)) + (:method :around ((x integer)) (values 'a 'b 'c)) + (:method :around ((x complex)) (call-next-method)) + (:method :around ((x number)) (values 1 2 3 4 5 6)) + (:method or ((x t)) 'b))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) @@ -156,7 +156,7 @@ (deftest defgeneric-method-combination.or.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.or.9 (x) - (:method-combination or))))) + (:method-combination or))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) @@ -165,8 +165,8 @@ (deftest defgeneric-method-combination.or.10 (progn (eval '(defgeneric dg-mc.or.10 (x) - (:method-combination or) - (:method ((x t)) 0))) + (:method-combination or) + (:method ((x t)) 0))) (handler-case (dg-mc.or.10 'a) (error () :error))) @@ -175,8 +175,8 @@ (deftest defgeneric-method-combination.or.11 (progn (eval '(defgeneric dg-mc.or.11 (x) - (:method-combination or) - (:method nonsense ((x t)) 0))) + (:method-combination or) + (:method nonsense ((x t)) 0))) (handler-case (dg-mc.or.11 0) (error () :error))) @@ -184,10 +184,10 @@ (deftest defgeneric-method-combination.or.12 (let ((fn (eval '(defgeneric dg-mc.or.12 (x) - (:method-combination or) - (:method :around ((x t)) t) - (:method or ((x integer)) x))))) + (:method-combination or) + (:method :around ((x t)) t) + (:method or ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'a) - (error () :error))) + (error () :error))) :error) diff --git a/ansi-tests/defgeneric-method-combination-plus.lsp b/ansi-tests/defgeneric-method-combination-plus.lsp index f51d6550..4959d6ac 100644 --- a/ansi-tests/defgeneric-method-combination-plus.lsp +++ b/ansi-tests/defgeneric-method-combination-plus.lsp @@ -11,61 +11,61 @@ (deftest defgeneric-method-combination.+.1 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.plus.1 (x) - (:method-combination +) - (:method + ((x integer)) (car (push 8 *x*))) - (:method + ((x rational)) (car (push 4 *x*))) - (:method + ((x number)) (car (push 2 *x*))) - (:method + ((x t)) (car (push 1 *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.plus.1 (x) + (:method-combination +) + (:method + ((x integer)) (car (push 8 *x*))) + (:method + ((x rational)) (car (push 4 *x*))) + (:method + ((x number)) (car (push 2 *x*))) + (:method + ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (15 (1 2 4 8)) (7 (1 2 4)) (3 (1 2)) (1 (1))) (deftest defgeneric-method-combination.+.2 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.plus.2 (x) - (:method-combination + :most-specific-first) - (:method + ((x integer)) (car (push 8 *x*))) - (:method + ((x rational)) (car (push 4 *x*))) - (:method + ((x number)) (car (push 2 *x*))) - (:method + ((x t)) (car (push 1 *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.plus.2 (x) + (:method-combination + :most-specific-first) + (:method + ((x integer)) (car (push 8 *x*))) + (:method + ((x rational)) (car (push 4 *x*))) + (:method + ((x number)) (car (push 2 *x*))) + (:method + ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (15 (1 2 4 8)) (7 (1 2 4)) (3 (1 2)) (1 (1))) (deftest defgeneric-method-combination.+.3 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.plus.3 (x) - (:method-combination + :most-specific-last) - (:method + ((x integer)) (car (push 8 *x*))) - (:method + ((x rational)) (car (push 4 *x*))) - (:method + ((x number)) (car (push 2 *x*))) - (:method + ((x t)) (car (push 1 *x*))))))) + (fn + (eval '(defgeneric dg-mc.fun.plus.3 (x) + (:method-combination + :most-specific-last) + (:method + ((x integer)) (car (push 8 *x*))) + (:method + ((x rational)) (car (push 4 *x*))) + (:method + ((x number)) (car (push 2 *x*))) + (:method + ((x t)) (car (push 1 *x*))))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (15 (8 4 2 1)) (7 (4 2 1)) (3 (2 1)) (1 (1))) (deftest defgeneric-method-combination.+.4 (let ((fn - (eval '(defgeneric dg-mc.plus.4 (x) - (:method-combination +) - (:method + ((x integer)) 1) - (:method :around ((x rational)) 'foo) - (:method + ((x number)) 1) - (:method + ((x symbol)) 2) - (:method + ((x t)) 4))))) + (eval '(defgeneric dg-mc.plus.4 (x) + (:method-combination +) + (:method + ((x integer)) 1) + (:method :around ((x rational)) 'foo) + (:method + ((x number)) 1) + (:method + ((x symbol)) 2) + (:method + ((x t)) 4))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -77,14 +77,14 @@ (deftest defgeneric-method-combination.+.5 (let ((fn - (eval '(defgeneric dg-mc.plus.5 (x) - (:method-combination +) - (:method + ((x integer)) 1) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method + ((x number)) 2) - (:method + ((x symbol)) 4) - (:method + ((x t)) 8))))) + (eval '(defgeneric dg-mc.plus.5 (x) + (:method-combination +) + (:method + ((x integer)) 1) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method + ((x number)) 2) + (:method + ((x symbol)) 4) + (:method + ((x t)) 8))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -96,16 +96,16 @@ (deftest defgeneric-method-combination.+.6 (let ((fn - (eval '(defgeneric dg-mc.plus.6 (x) - (:method-combination +) - (:method + ((x integer)) 1) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method + ((x number)) 2) - (:method + ((x symbol)) 4) - (:method + ((x t)) 8))))) + (eval '(defgeneric dg-mc.plus.6 (x) + (:method-combination +) + (:method + ((x integer)) 1) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method :around ((x real)) + (list 'bar (call-next-method))) + (:method + ((x number)) 2) + (:method + ((x symbol)) 4) + (:method + ((x t)) 8))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -118,12 +118,12 @@ (deftest defgeneric-method-combination.+.7 (let ((fn - (eval '(defgeneric dg-mc.plus.7 (x) - (:method-combination +) - (:method + ((x dgmc-class-04)) 1) - (:method + ((x dgmc-class-03)) 2) - (:method + ((x dgmc-class-02)) 4) - (:method + ((x dgmc-class-01)) 8))))) + (eval '(defgeneric dg-mc.plus.7 (x) + (:method-combination +) + (:method + ((x dgmc-class-04)) 1) + (:method + ((x dgmc-class-03)) 2) + (:method + ((x dgmc-class-02)) 4) + (:method + ((x dgmc-class-01)) 8))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) @@ -134,14 +134,14 @@ (deftest defgeneric-method-combination.+.8 (let ((fn - (eval '(defgeneric dg-mc.plus.8 (x) - (:method-combination +) - (:method + ((x (eql 1000))) 1) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method + ((x t)) 1))))) + (eval '(defgeneric dg-mc.plus.8 (x) + (:method-combination +) + (:method + ((x (eql 1000))) 1) + (:method :around ((x symbol)) (values)) + (:method :around ((x integer)) (values 'a 'b 'c)) + (:method :around ((x complex)) (call-next-method)) + (:method :around ((x number)) (values 1 2 3 4 5 6)) + (:method + ((x t)) 1))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) @@ -153,7 +153,7 @@ (deftest defgeneric-method-combination.+.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.+.9 (x) - (:method-combination +))))) + (:method-combination +))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) @@ -162,8 +162,8 @@ (deftest defgeneric-method-combination.+.10 (progn (eval '(defgeneric dg-mc.+.10 (x) - (:method-combination +) - (:method ((x t)) 0))) + (:method-combination +) + (:method ((x t)) 0))) (handler-case (dg-mc.+.10 'a) (error () :error))) @@ -172,8 +172,8 @@ (deftest defgeneric-method-combination.+.11 (progn (eval '(defgeneric dg-mc.+.11 (x) - (:method-combination +) - (:method nonsense ((x t)) 0))) + (:method-combination +) + (:method nonsense ((x t)) 0))) (handler-case (dg-mc.+.11 0) (error () :error))) @@ -181,11 +181,11 @@ (deftest defgeneric-method-combination.+.12 (let ((fn (eval '(defgeneric dg-mc.+.12 (x) - (:method-combination +) - (:method :around ((x t)) 1) - (:method + ((x integer)) x))))) + (:method-combination +) + (:method :around ((x t)) 1) + (:method + ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'a) - (error () :error))) + (error () :error))) :error) diff --git a/ansi-tests/defgeneric-method-combination-progn.lsp b/ansi-tests/defgeneric-method-combination-progn.lsp index 0b4b5ca5..c90af10e 100644 --- a/ansi-tests/defgeneric-method-combination-progn.lsp +++ b/ansi-tests/defgeneric-method-combination-progn.lsp @@ -11,17 +11,17 @@ (deftest defgeneric-method-combination.progn.1 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.progn.1 (x) - (:method-combination progn) - (:method progn ((x integer)) (push 4 *x*) nil) - (:method progn ((x rational)) (push 3 *x*) nil) - (:method progn ((x number)) (push 2 *x*) nil) - (:method progn ((x t)) (push 1 *x*) 'a))))) + (fn + (eval '(defgeneric dg-mc.fun.progn.1 (x) + (:method-combination progn) + (:method progn ((x integer)) (push 4 *x*) nil) + (:method progn ((x rational)) (push 3 *x*) nil) + (:method progn ((x number)) (push 2 *x*) nil) + (:method progn ((x t)) (push 1 *x*) 'a))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (1 2 3 4)) (a (1 2 3)) @@ -30,17 +30,17 @@ (deftest defgeneric-method-combination.progn.2 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.progn.2 (x) - (:method-combination progn :most-specific-first) - (:method progn ((x integer)) (push 4 *x*) 'a) - (:method progn ((x rational)) (push 3 *x*) 'b) - (:method progn ((x number)) (push 2 *x*) 'c) - (:method progn ((x t)) (push 1 *x*) 'd))))) + (fn + (eval '(defgeneric dg-mc.fun.progn.2 (x) + (:method-combination progn :most-specific-first) + (:method progn ((x integer)) (push 4 *x*) 'a) + (:method progn ((x rational)) (push 3 *x*) 'b) + (:method progn ((x number)) (push 2 *x*) 'c) + (:method progn ((x t)) (push 1 *x*) 'd))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (d (1 2 3 4)) (d (1 2 3)) @@ -49,17 +49,17 @@ (deftest defgeneric-method-combination.progn.3 (let ((*x* nil) - (fn - (eval '(defgeneric dg-mc.fun.progn.3 (x) - (:method-combination progn :most-specific-last) - (:method progn ((x integer)) (push 4 *x*) 'a) - (:method progn ((x rational)) (push 3 *x*) 'b) - (:method progn ((x number)) (push 2 *x*) 'c) - (:method progn ((x t)) (push 1 *x*) 'd))))) + (fn + (eval '(defgeneric dg-mc.fun.progn.3 (x) + (:method-combination progn :most-specific-last) + (:method progn ((x integer)) (push 4 *x*) 'a) + (:method progn ((x rational)) (push 3 *x*) 'b) + (:method progn ((x number)) (push 2 *x*) 'c) + (:method progn ((x t)) (push 1 *x*) 'd))))) (declare (type generic-function fn)) (flet ((%f (y) - (let ((*x* nil)) - (list (funcall fn y) *x*)))) + (let ((*x* nil)) + (list (funcall fn y) *x*)))) (values (%f 1) (%f 2/3) (%f 1.54) (%f 'a)))) (a (4 3 2 1)) (b (3 2 1)) @@ -68,13 +68,13 @@ (deftest defgeneric-method-combination.progn.4 (let ((fn - (eval '(defgeneric dg-mc.progn.4 (x) - (:method-combination progn) - (:method progn ((x integer)) 'd) - (:method :around ((x rational)) 'foo) - (:method progn ((x number)) 'b) - (:method progn ((x symbol)) 'c) - (:method progn ((x t)) 'a))))) + (eval '(defgeneric dg-mc.progn.4 (x) + (:method-combination progn) + (:method progn ((x integer)) 'd) + (:method :around ((x rational)) 'foo) + (:method progn ((x number)) 'b) + (:method progn ((x symbol)) 'c) + (:method progn ((x t)) 'a))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -86,13 +86,13 @@ (deftest defgeneric-method-combination.progn.4a (let ((fn - (eval '(defgeneric dg-mc.progn.4a (x) - (:method-combination progn :most-specific-last) - (:method progn ((x integer)) 'd) - (:method :around ((x rational)) 'foo) - (:method progn ((x number)) 'b) - (:method progn ((x symbol)) 'c) - (:method progn ((x t)) 'a))))) + (eval '(defgeneric dg-mc.progn.4a (x) + (:method-combination progn :most-specific-last) + (:method progn ((x integer)) 'd) + (:method :around ((x rational)) 'foo) + (:method progn ((x number)) 'b) + (:method progn ((x symbol)) 'c) + (:method progn ((x t)) 'a))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -104,14 +104,14 @@ (deftest defgeneric-method-combination.progn.5 (let ((fn - (eval '(defgeneric dg-mc.progn.5 (x) - (:method-combination progn) - (:method progn ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method progn ((x number)) nil) - (:method progn ((x symbol)) 'b) - (:method progn ((x t)) 'c))))) + (eval '(defgeneric dg-mc.progn.5 (x) + (:method-combination progn) + (:method progn ((x integer)) 'a) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method progn ((x number)) nil) + (:method progn ((x symbol)) 'b) + (:method progn ((x t)) 'c))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -123,14 +123,14 @@ (deftest defgeneric-method-combination.progn.5a (let ((fn - (eval '(defgeneric dg-mc.progn.5a (x) - (:method-combination progn :most-specific-last) - (:method progn ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method progn ((x number)) 'e) - (:method progn ((x symbol)) 'b) - (:method progn ((x t)) 'c))))) + (eval '(defgeneric dg-mc.progn.5a (x) + (:method-combination progn :most-specific-last) + (:method progn ((x integer)) 'a) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method progn ((x number)) 'e) + (:method progn ((x symbol)) 'b) + (:method progn ((x t)) 'c))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -143,16 +143,16 @@ (deftest defgeneric-method-combination.progn.6 (let ((fn - (eval '(defgeneric dg-mc.progn.6 (x) - (:method-combination progn) - (:method progn ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method progn ((x number)) 'b) - (:method progn ((x symbol)) 'c) - (:method progn ((x t)) 'd))))) + (eval '(defgeneric dg-mc.progn.6 (x) + (:method-combination progn) + (:method progn ((x integer)) 'a) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method :around ((x real)) + (list 'bar (call-next-method))) + (:method progn ((x number)) 'b) + (:method progn ((x symbol)) 'c) + (:method progn ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -165,16 +165,16 @@ (deftest defgeneric-method-combination.progn.6a (let ((fn - (eval '(defgeneric dg-mc.progn.6a (x) - (:method-combination progn :most-specific-last) - (:method progn ((x integer)) 'a) - (:method :around ((x rational)) - (list 'foo (call-next-method))) - (:method :around ((x real)) - (list 'bar (call-next-method))) - (:method progn ((x number)) 'b) - (:method progn ((x symbol)) 'c) - (:method progn ((x t)) 'd))))) + (eval '(defgeneric dg-mc.progn.6a (x) + (:method-combination progn :most-specific-last) + (:method progn ((x integer)) 'a) + (:method :around ((x rational)) + (list 'foo (call-next-method))) + (:method :around ((x real)) + (list 'bar (call-next-method))) + (:method progn ((x number)) 'b) + (:method progn ((x symbol)) 'c) + (:method progn ((x t)) 'd))))) (declare (type generic-function fn)) (values (funcall fn 0) @@ -188,12 +188,12 @@ (deftest defgeneric-method-combination.progn.7 (let ((fn - (eval '(defgeneric dg-mc.progn.7 (x) - (:method-combination progn) - (:method progn ((x dgmc-class-04)) 'a) - (:method progn ((x dgmc-class-03)) 'b) - (:method progn ((x dgmc-class-02)) 'c) - (:method progn ((x dgmc-class-01)) 'd))))) + (eval '(defgeneric dg-mc.progn.7 (x) + (:method-combination progn) + (:method progn ((x dgmc-class-04)) 'a) + (:method progn ((x dgmc-class-03)) 'b) + (:method progn ((x dgmc-class-02)) 'c) + (:method progn ((x dgmc-class-01)) 'd))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) @@ -204,12 +204,12 @@ (deftest defgeneric-method-combination.progn.7a (let ((fn - (eval '(defgeneric dg-mc.progn.7a (x) - (:method-combination progn :most-specific-last) - (:method progn ((x dgmc-class-04)) 'a) - (:method progn ((x dgmc-class-03)) 'b) - (:method progn ((x dgmc-class-02)) 'c) - (:method progn ((x dgmc-class-01)) 'd))))) + (eval '(defgeneric dg-mc.progn.7a (x) + (:method-combination progn :most-specific-last) + (:method progn ((x dgmc-class-04)) 'a) + (:method progn ((x dgmc-class-03)) 'b) + (:method progn ((x dgmc-class-02)) 'c) + (:method progn ((x dgmc-class-01)) 'd))))) (declare (type generic-function fn)) (values (funcall fn (make-instance 'dgmc-class-01)) @@ -220,14 +220,14 @@ (deftest defgeneric-method-combination.progn.8 (let ((fn - (eval '(defgeneric dg-mc.progn.8 (x) - (:method-combination progn) - (:method progn ((x (eql 1000))) 'a) - (:method :around ((x symbol)) (values)) - (:method :around ((x integer)) (values 'a 'b 'c)) - (:method :around ((x complex)) (call-next-method)) - (:method :around ((x number)) (values 1 2 3 4 5 6)) - (:method progn ((x t)) 'b))))) + (eval '(defgeneric dg-mc.progn.8 (x) + (:method-combination progn) + (:method progn ((x (eql 1000))) 'a) + (:method :around ((x symbol)) (values)) + (:method :around ((x integer)) (values 'a 'b 'c)) + (:method :around ((x complex)) (call-next-method)) + (:method :around ((x number)) (values 1 2 3 4 5 6)) + (:method progn ((x t)) 'b))))) (declare (type generic-function fn)) (values (multiple-value-list (funcall fn 'a)) @@ -239,7 +239,7 @@ (deftest defgeneric-method-combination.progn.9 (handler-case (let ((fn (eval '(defgeneric dg-mc.progn.9 (x) - (:method-combination progn))))) + (:method-combination progn))))) (declare (type generic-function fn)) (funcall fn (list 'a))) (error () :error)) @@ -248,8 +248,8 @@ (deftest defgeneric-method-combination.progn.10 (progn (eval '(defgeneric dg-mc.progn.10 (x) - (:method-combination progn) - (:method ((x t)) 0))) + (:method-combination progn) + (:method ((x t)) 0))) (handler-case (dg-mc.progn.10 'a) (error () :error))) @@ -258,8 +258,8 @@ (deftest defgeneric-method-combination.progn.11 (progn (eval '(defgeneric dg-mc.progn.11 (x) - (:method-combination progn) - (:method nonsense ((x t)) 0))) + (:method-combination progn) + (:method nonsense ((x t)) 0))) (handler-case (dg-mc.progn.11 0) (error () :error))) @@ -267,10 +267,10 @@ (deftest defgeneric-method-combination.progn.12 (let ((fn (eval '(defgeneric dg-mc.progn.12 (x) - (:method-combination progn) - (:method :around ((x t)) 'a) - (:method progn ((x integer)) x))))) + (:method-combination progn) + (:method :around ((x t)) 'a) + (:method progn ((x integer)) x))))) (declare (type generic-function fn)) (handler-case (funcall fn 'b) - (error () :error))) + (error () :error))) :error) diff --git a/ansi-tests/defgeneric.lsp b/ansi-tests/defgeneric.lsp index a210d51e..327e0532 100644 --- a/ansi-tests/defgeneric.lsp +++ b/ansi-tests/defgeneric.lsp @@ -12,11 +12,11 @@ (deftest defgeneric.error.1 ;; Cannot make ordinary functions generic (let* ((name 'defgeneric-testfn-01) - (fn (symbol-function name))) + (fn (symbol-function name))) (if (not (typep fn 'generic-function)) - (handler-case - (progn (eval `(defgeneric ,name ())) :bad) - (program-error () :good)) + (handler-case + (progn (eval `(defgeneric ,name ())) :bad) + (program-error () :good)) :good)) :good) @@ -33,45 +33,45 @@ (deftest defgeneric.error.3 ;; Cannot make special operators generic (loop for name in *cl-special-operator-symbols* - for result = - (handler-case - (progn (eval `(defgeneric ,name ())) t) - (program-error () nil)) - when result collect name) + for result = + (handler-case + (progn (eval `(defgeneric ,name ())) t) + (program-error () nil)) + when result collect name) nil) (deftest defgeneric.error.4 (signals-error (defgeneric defgeneric-error-fn.4 (x y) - (:argument-precedence-order x y x)) - program-error) + (:argument-precedence-order x y x)) + program-error) t) (deftest defgeneric.error.5 (signals-error (defgeneric defgeneric-error-fn.5 (x) - (:documentation "some documentation") - (:documentation "illegally repeated documentation")) - program-error) + (:documentation "some documentation") + (:documentation "illegally repeated documentation")) + program-error) t) (deftest defgeneric.error.6 (signals-error (defgeneric defgeneric-error-fn.6 (x) - (unknown-option nil)) - program-error) + (unknown-option nil)) + program-error) t) (deftest defgeneric.error.7 (handler-case (progn (eval '(defgeneric defgeneric-error-fn.7 (x y) - (:method ((x t)) x))) + (:method ((x t)) x))) :bad) (error () :good)) :good) (deftest defgeneric.error.8 (signals-error (defgeneric defgeneric-error-fn.8 (x y) - (:argument-precedence-order x)) - program-error) + (:argument-precedence-order x)) + program-error) t) @@ -81,7 +81,7 @@ (handler-case (progn (eval '(defgeneric defgeneric-error-fn.9 (x) - (:method ((x t)(y t)) t))) + (:method ((x t)(y t)) t))) :bad) (error () :good)) :good) @@ -91,7 +91,7 @@ (handler-case (progn (eval '(defgeneric defgeneric-error-fn.10 (x &optional y) - (:method ((x t)) t))) + (:method ((x t)) t))) :bad) (error () :good)) :good) @@ -100,7 +100,7 @@ (handler-case (progn (eval '(defgeneric defgeneric-error-fn.11 (x &optional y) - (:method (x &optional y z) t))) + (:method (x &optional y z) t))) :bad) (error () :good)) :good) @@ -109,7 +109,7 @@ (handler-case (progn (eval '(defgeneric defgeneric-error-fn.12 (x &rest y) - (:method (x) t))) + (:method (x) t))) :bad) (error () :good)) :good) @@ -118,7 +118,7 @@ (handler-case (progn (eval '(defgeneric defgeneric-error-fn.13 (x) - (:method (x &rest y) t))) + (:method (x &rest y) t))) :bad) (error () :good)) :good) @@ -127,7 +127,7 @@ (handler-case (progn (eval '(defgeneric defgeneric-error-fn.14 (x &key) - (:method (x) t))) + (:method (x) t))) :bad) (error () :good)) :good) @@ -136,7 +136,7 @@ (handler-case (progn (eval '(defgeneric defgeneric-error-fn.15 (x &key y) - (:method (x) t))) + (:method (x) t))) :bad) (error () :good)) :good) @@ -145,7 +145,7 @@ (handler-case (progn (eval '(defgeneric defgeneric-error-fn.16 (x) - (:method (x &key) t))) + (:method (x &key) t))) :bad) (error () :good)) :good) @@ -154,7 +154,7 @@ (handler-case (progn (eval '(defgeneric defgeneric-error-fn.17 (x) - (:method (x &key foo) t))) + (:method (x &key foo) t))) :bad) (error () :good)) :good) @@ -163,7 +163,7 @@ (handler-case (progn (eval '(defgeneric defgeneric-error-fn.18 (x &key foo) - (:method (x &key) t))) + (:method (x &key) t))) :bad) (error () :good)) :good) @@ -172,7 +172,7 @@ (handler-case (progn (eval '(defgeneric defgeneric-error-fn.19 (x &key foo) - (:method (x &key bar) t))) + (:method (x &key bar) t))) :bad) (error () :good)) :good) @@ -184,8 +184,8 @@ (deftest defgeneric.error.20 (signals-error (let ((fn (defgeneric defgeneric-error-fn.20 (x &key) - (:method ((x number) &key foo) (list x foo)) - (:method ((x symbol) &key bar) (list x bar))))) + (:method ((x number) &key foo) (list x foo)) + (:method ((x symbol) &key bar) (list x bar))))) (funcall fn 1 :bar 'a)) program-error) t) @@ -193,8 +193,8 @@ (deftest defgeneric.error.21 (signals-error (let ((fn (defgeneric defgeneric-error-fn.21 (x &key) - (:method ((x number) &key foo &allow-other-keys) (list x foo)) - (:method ((x symbol) &key bar) (list x bar))))) + (:method ((x number) &key foo &allow-other-keys) (list x foo)) + (:method ((x symbol) &key bar) (list x bar))))) (funcall fn 'x :foo 'a)) program-error) t) @@ -215,7 +215,7 @@ (deftest defgeneric.1 (let ((fn (eval '(defgeneric defgeneric.fun.1 (x y z) - (:method ((x t) (y t) (z t)) (list x y z)))))) + (:method ((x t) (y t) (z t)) (list x y z)))))) (declare (type function fn)) (values (typep* fn 'generic-function) @@ -229,8 +229,8 @@ (deftest defgeneric.2 (let ((fn (eval '(defgeneric defgeneric.fun.2 (x y z) - (:documentation "boo!") - (:method ((x t) (y t) (z t)) (vector x y z)))))) + (:documentation "boo!") + (:method ((x t) (y t) (z t)) (vector x y z)))))) (declare (type function fn)) (values (typep* fn 'generic-function) @@ -239,25 +239,25 @@ (defgeneric.fun.2 'd 'e 'f) (let ((doc (documentation fn t))) (or (not doc) - (and (stringp doc) (string=t doc "boo!")))) + (and (stringp doc) (string=t doc "boo!")))) (let ((doc (documentation fn 'function))) (or (not doc) - (and (stringp doc) (string=t doc "boo!")))) + (and (stringp doc) (string=t doc "boo!")))) (setf (documentation fn t) "foo") (let ((doc (documentation fn t))) (or (not doc) - (and (stringp doc) (string=t doc "foo")))) + (and (stringp doc) (string=t doc "foo")))) (setf (documentation fn 'function) "bar") (let ((doc (documentation fn t))) (or (not doc) - (and (stringp doc) (string=t doc "bar")))))) - + (and (stringp doc) (string=t doc "bar")))))) + t t #(a b c) #(d e f) t t "foo" t "bar" t) (deftest defgeneric.3 (let ((fn (eval '(defgeneric defgeneric.fun.3 (x y) - (:method ((x t) (y symbol)) (list x y)) - (:method ((x symbol) (y t)) (list y x)))))) + (:method ((x t) (y symbol)) (list x y)) + (:method ((x symbol) (y t)) (list y x)))))) (declare (type function fn)) (values (typep* fn 'generic-function) @@ -272,9 +272,9 @@ (deftest defgeneric.4 (let ((fn (eval '(defgeneric defgeneric.fun.4 (x y) - (:argument-precedence-order y x) - (:method ((x t) (y symbol)) (list x y)) - (:method ((x symbol) (y t)) (list y x)))))) + (:argument-precedence-order y x) + (:method ((x t) (y symbol)) (list x y)) + (:method ((x symbol) (y t)) (list y x)))))) (declare (type function fn)) (values (typep* fn 'generic-function) @@ -289,7 +289,7 @@ (deftest defgeneric.5 (let ((fn (eval '(defgeneric defgeneric.fun.5 () - (:method () (values)))))) + (:method () (values)))))) (declare (type function fn)) (values (typep* fn 'generic-function) @@ -301,7 +301,7 @@ (deftest defgeneric.6 (let ((fn (eval '(defgeneric defgeneric.fun.6 () - (:method () (values 'a 'b 'c)))))) + (:method () (values 'a 'b 'c)))))) (declare (type function fn)) (values (typep* fn 'generic-function) @@ -313,7 +313,7 @@ (deftest defgeneric.7 (let ((fn (eval '(defgeneric defgeneric.fun.7 () - (:method () (return-from defgeneric.fun.7 'a) 'b))))) + (:method () (return-from defgeneric.fun.7 'a) 'b))))) (declare (type function fn)) (values (typep* fn 'generic-function) @@ -325,10 +325,10 @@ (deftest defgeneric.8 (let ((fn (eval '(defgeneric defgeneric.fun.8 (x &optional y z) - (:method ((x number) &optional y z) - (list x y z)) - (:method ((p symbol) &optional q r) - (list r q p)))))) + (:method ((x number) &optional y z) + (list x y z)) + (:method ((p symbol) &optional q r) + (list r q p)))))) (declare (type function fn)) (values (typep* fn 'generic-function) @@ -351,10 +351,10 @@ (deftest defgeneric.9 (let ((fn (eval '(defgeneric defgeneric.fun.9 (x &optional y z) - (:method ((x number) &optional (y 10) (z 20)) - (list x y z)) - (:method ((p symbol) &optional (q 's) (r 't)) - (list r q p)))))) + (:method ((x number) &optional (y 10) (z 20)) + (list x y z)) + (:method ((p symbol) &optional (q 's) (r 't)) + (list r q p)))))) (declare (type function fn)) (values (funcall fn 1) @@ -372,7 +372,7 @@ (deftest defgeneric.10 (let ((fn (eval '(defgeneric defgeneric.fun.10 (x &rest y) - (:method ((x number) &key foo) (list x foo)))))) + (:method ((x number) &key foo) (list x foo)))))) (declare (type function fn)) (values (funcall fn 1) @@ -388,7 +388,7 @@ (deftest defgeneric.11 (let ((fn (eval '(defgeneric defgeneric.fun.11 (x &key) - (:method ((x number) &key foo) (list x foo)))))) + (:method ((x number) &key foo) (list x foo)))))) (declare (type function fn)) (values (funcall fn 1) @@ -404,7 +404,7 @@ (deftest defgeneric.12 (let ((fn (eval '(defgeneric defgeneric.fun.12 (x &key foo bar baz) - (:method ((x number) &rest y) (list x y)))))) + (:method ((x number) &rest y) (list x y)))))) (declare (type function fn)) (values (funcall fn 1) @@ -420,8 +420,8 @@ (deftest defgeneric.13 (let ((fn (eval '(defgeneric defgeneric.fun.13 (x &key) - (:method ((x number) &key foo) (list x foo)) - (:method ((x symbol) &key bar) (list x bar)))))) + (:method ((x number) &key foo) (list x foo)) + (:method ((x symbol) &key bar) (list x bar)))))) (declare (type function fn)) (values (funcall fn 1) @@ -445,8 +445,8 @@ (deftest defgeneric.14 (let ((fn (eval '(defgeneric defgeneric.fun.14 (x &key &allow-other-keys) - (:method ((x number) &key foo) (list x foo)) - (:method ((x symbol) &key bar) (list x bar)))))) + (:method ((x number) &key foo) (list x foo)) + (:method ((x symbol) &key bar) (list x bar)))))) (declare (type function fn)) (values (funcall fn 1) @@ -477,9 +477,9 @@ (deftest defgeneric.15 (let ((fn (eval '(defgeneric defgeneric.fun.15 (x &key) - (:method ((x number) &key foo &allow-other-keys) - (list x foo)) - (:method ((x symbol) &key bar) (list x bar)))))) + (:method ((x number) &key foo &allow-other-keys) + (list x foo)) + (:method ((x symbol) &key bar) (list x bar)))))) (declare (type function fn)) (values (funcall fn 1) @@ -511,10 +511,10 @@ (deftest defgeneric.16 (let ((fn (eval '(defgeneric defgeneric.fun.16 (x &key) - (:method ((x number) &key (foo 'a)) - (list x foo)) - (:method ((x symbol) &key foo) - (list x foo)))))) + (:method ((x number) &key (foo 'a)) + (list x foo)) + (:method ((x symbol) &key foo) + (list x foo)))))) (declare (type function fn)) (values (funcall fn 1) @@ -532,10 +532,10 @@ (deftest defgeneric.17 (let ((fn (eval '(defgeneric defgeneric.fun.17 (x &key) - (:method ((x number) &key (foo 'a foo-p)) - (list x foo (notnot foo-p))) - (:method ((x symbol) &key foo) - (list x foo)))))) + (:method ((x number) &key (foo 'a foo-p)) + (list x foo (notnot foo-p))) + (:method ((x symbol) &key foo) + (list x foo)))))) (declare (type function fn)) (values (funcall fn 1) @@ -553,10 +553,10 @@ (deftest defgeneric.18 (let ((fn (eval '(defgeneric defgeneric.fun.18 (x &optional y) - (:method ((x number) &optional (y 'a)) - (list x y)) - (:method ((x symbol) &optional (z nil z-p)) - (list x z (notnot z-p))))))) + (:method ((x number) &optional (y 'a)) + (list x y)) + (:method ((x symbol) &optional (z nil z-p)) + (list x z (notnot z-p))))))) (declare (type function fn)) (values (funcall fn 1) @@ -574,8 +574,8 @@ (deftest defgeneric.19 (let ((fn (eval '(defgeneric defgeneric.fun.19 (x &key) - (:method ((x number) &key ((:bar foo) 'a foo-p)) - (list x foo (notnot foo-p))))))) + (:method ((x number) &key ((:bar foo) 'a foo-p)) + (list x foo (notnot foo-p))))))) (declare (type function fn)) (values (funcall fn 1) @@ -587,11 +587,11 @@ (deftest defgeneric.20 (let ((fn (eval '(defgeneric defgeneric.fun.20 (x &optional y z) - (:method ((x number) - &optional (y (1+ x) y-p) - (z (if y-p (1+ y) (+ x 10)) - z-p)) - (list x y (notnot y-p) z (notnot z-p))))))) + (:method ((x number) + &optional (y (1+ x) y-p) + (z (if y-p (1+ y) (+ x 10)) + z-p)) + (list x y (notnot y-p) z (notnot z-p))))))) (declare (type function fn)) (values (funcall fn 1) @@ -603,11 +603,11 @@ (deftest defgeneric.21 (let ((fn (eval '(defgeneric defgeneric.fun.21 (x &key) - (:method ((x number) - &key (y (1+ x) y-p) - (z (if y-p (1+ y) (+ x 10)) - z-p)) - (list x y (notnot y-p) z (notnot z-p))))))) + (:method ((x number) + &key (y (1+ x) y-p) + (z (if y-p (1+ y) (+ x 10)) + z-p)) + (list x y (notnot y-p) z (notnot z-p))))))) (declare (type function fn)) (values (funcall fn 1) @@ -623,8 +623,8 @@ (deftest defgeneric.22 (let ((fn (eval '(defgeneric defgeneric.fun.22 (x &key) - (:method ((x number) &key ((:allow-other-keys y))) - (list x y)))))) + (:method ((x number) &key ((:allow-other-keys y))) + (list x y)))))) (declare (type function fn)) (values (funcall fn 1) @@ -648,8 +648,8 @@ (deftest defgeneric.23 (let ((fn (eval '(defgeneric defgeneric.fun.23 (x) - (:method ((x number) &aux (y (1+ x))) (list x y)) - (:method ((x symbol) &aux (z (list x))) (list x z)))))) + (:method ((x number) &aux (y (1+ x))) (list x y)) + (:method ((x symbol) &aux (z (list x))) (list x z)))))) (declare (type function fn)) (values (funcall fn 1) @@ -659,10 +659,10 @@ (deftest defgeneric.24 (let ((fn (eval '(defgeneric defgeneric.fun.24 (x) - (:method ((x number) &aux (y (1+ x)) (z (1+ y))) - (list x y z)) - (:method ((x symbol) &aux (y (list x)) (z (list x y))) - (list x y z)))))) + (:method ((x number) &aux (y (1+ x)) (z (1+ y))) + (list x y z)) + (:method ((x symbol) &aux (y (list x)) (z (list x y))) + (list x y z)))))) (values (funcall fn 1) (funcall fn 'a))) @@ -671,11 +671,11 @@ (deftest defgeneric.25 (let ((fn (eval '(defgeneric defgeneric.fun.25 (x &optional y &key) - (:method ((x symbol) &optional (y 'd y-p) - &key ((:foo bar) (list x y) bar-p) - &aux (z (list x y (notnot y-p) - bar (notnot bar-p)))) - z))))) + (:method ((x symbol) &optional (y 'd y-p) + &key ((:foo bar) (list x y) bar-p) + &aux (z (list x y (notnot y-p) + bar (notnot bar-p)))) + z))))) (declare (type function fn)) (values (funcall fn 'a) @@ -687,23 +687,23 @@ (deftest defgeneric.26 (let ((fn (eval '(defgeneric defgeneric.fun.26 (x) - (declare (optimize (safety 3))) - (:method ((x symbol)) x) - (declare (optimize (debug 3))))))) + (declare (optimize (safety 3))) + (:method ((x symbol)) x) + (declare (optimize (debug 3))))))) (declare (type function fn)) (funcall fn 'a)) a) #| (when (subtypep (class-of (find-class 'standard-method)) - 'standard-class) + 'standard-class) (defclass substandard-method (standard-method) ()) (deftest defgeneric.27 (let ((fn (eval '(defgeneric defgeneric.fun.27 (x y) - (:method-class substandard-method) - (:method ((x number) (y number)) (+ x y)) - (:method ((x string) (y string)) - (concatenate 'string x y)))))) + (:method-class substandard-method) + (:method ((x number) (y number)) (+ x y)) + (:method ((x string) (y string)) + (concatenate 'string x y)))))) (declare (type function fn)) (values (funcall fn 1 2) @@ -713,12 +713,12 @@ (deftest defgeneric.28 (let ((fn (eval '(defgeneric defgeneric.fun.28 (x &key) - (:method ((x integer) &key foo) (list x foo)) - (:method ((x number) &key bar) (list x bar)) - (:method ((x t) &key baz) (list x baz)))))) + (:method ((x integer) &key foo) (list x foo)) + (:method ((x number) &key bar) (list x bar)) + (:method ((x t) &key baz) (list x baz)))))) (declare (type function fn)) (values - + (funcall fn 1) (funcall fn 1 :foo 'a) (funcall fn 1 :bar 'b) @@ -727,15 +727,15 @@ (funcall fn 1 :foo 'a :bar 'b) (funcall fn 1 :foo 'a :baz 'c) (funcall fn 1 :foo 'a :bar 'b :baz 'c) - + (funcall fn 5/3) (funcall fn 5/3 :bar 'b) (funcall fn 5/3 :baz 'c) (funcall fn 5/3 :bar 'b :baz 'c) - + (funcall fn 'x) (funcall fn 'x :baz 'c) - + )) (1 nil) (1 a) (1 nil) (1 nil) @@ -753,9 +753,9 @@ (deftest defgeneric.29 (let ((fn - (eval '(defgeneric defgeneric.fun.29 (x &key) - (:method ((x defgeneric.29.class.1) &key foo) foo) - (:method ((x defgeneric.29.class.2) &key bar) bar))))) + (eval '(defgeneric defgeneric.fun.29 (x &key) + (:method ((x defgeneric.29.class.1) &key foo) foo) + (:method ((x defgeneric.29.class.2) &key bar) bar))))) (declare (type function fn)) (let ((x (make-instance 'defgeneric.29.class.3))) (values @@ -769,16 +769,16 @@ ;;; I'm not sure this one is proper ;;; Added :metaclass at prompting of Martin Simmons (when (subtypep (class-of (find-class 'standard-generic-function)) - 'standard-class) + 'standard-class) (defclass substandard-generic-function (standard-generic-function) () (:metaclass #.(class-name (class-of - (find-class 'standard-generic-function))))) + (find-class 'standard-generic-function))))) (deftest defgeneric.30 (let ((fn - (eval '(defgeneric defgeneric.fun.29 (x) - (:generic-function-class substandard-generic-function) - (:method ((x symbol)) 1) - (:method ((x integer)) 2))))) + (eval '(defgeneric defgeneric.fun.29 (x) + (:generic-function-class substandard-generic-function) + (:method ((x symbol)) 1) + (:method ((x integer)) 2))))) (declare (type function fn)) (values (typep* fn 'substandard-generic-function) @@ -807,48 +807,48 @@ (deftest defgeneric.33 (let ((fn - (eval - '(defgeneric (setf defgeneric.fun.33) (x y &rest args) - (:method (x (y cons) &rest args) - (assert (null args)) (setf (car y) x)) - (:method (x (y array) &rest args) - (setf (apply #'aref y args) x)))))) + (eval + '(defgeneric (setf defgeneric.fun.33) (x y &rest args) + (:method (x (y cons) &rest args) + (assert (null args)) (setf (car y) x)) + (:method (x (y array) &rest args) + (setf (apply #'aref y args) x)))))) (declare (type function fn)) (values (let ((z (list 'a 'b))) (list - (setf (defgeneric.fun.33 z) 'c) - z)) + (setf (defgeneric.fun.33 z) 'c) + z)) (let ((a (make-array '(10) :initial-element nil))) (list - (setf (defgeneric.fun.33 a 5) 'd) - a)))) + (setf (defgeneric.fun.33 a 5) 'd) + a)))) (c (c b)) (d #(nil nil nil nil nil d nil nil nil nil))) (deftest defgeneric.34 (let ((fn (eval '(defgeneric #:defgeneric.fun.34 (x) - (:method ((x t)) (list x :good)))))) + (:method ((x t)) (list x :good)))))) (funcall fn 10)) (10 :good)) (deftest defgeneric.35 (let ((fn (eval '(defgeneric defgeneric.fun.35 (x) - (:method ((x (eql 'a))) - (declare (optimize (speed 0))) - "FOO" - (declare (optimize (safety 3))) - x))))) + (:method ((x (eql 'a))) + (declare (optimize (speed 0))) + "FOO" + (declare (optimize (safety 3))) + x))))) (declare (type function fn)) (values (funcall fn 'a) (let ((method (first (compute-applicable-methods fn '(a))))) (and method - (let ((doc (documentation method t))) - (list - (or (null doc) (equalt doc "FOO")) - (setf (documentation method t) "BAR") - (let ((doc (documentation method t))) - (or (null doc) (equalt doc "BAR"))) - )))))) + (let ((doc (documentation method t))) + (list + (or (null doc) (equalt doc "FOO")) + (setf (documentation method t) "BAR") + (let ((doc (documentation method t))) + (or (null doc) (equalt doc "BAR"))) + )))))) a (t "BAR" t)) diff --git a/ansi-tests/define-compiler-macro.lsp b/ansi-tests/define-compiler-macro.lsp index e7f83ccd..a8b290da 100644 --- a/ansi-tests/define-compiler-macro.lsp +++ b/ansi-tests/define-compiler-macro.lsp @@ -9,33 +9,33 @@ (deftest define-compiler-macro.error.1 (signals-error (funcall (macro-function 'define-compiler-macro)) - program-error) + program-error) t) (deftest define-compiler-macro.error.2 (signals-error (funcall (macro-function 'define-compiler-macro) - '(definee-compiler-macro nonexistent-function ())) - program-error) + '(definee-compiler-macro nonexistent-function ())) + program-error) t) (deftest define-compiler-macro.error.3 (signals-error (funcall (macro-function 'define-compiler-macro) - '(definee-compiler-macro nonexistent-function ()) - nil nil) - program-error) + '(definee-compiler-macro nonexistent-function ()) + nil nil) + program-error) t) ;;; Non-error tests (deftest define-compiler-macro.1 (let* ((sym (gensym)) - (macro-def-form - `(define-compiler-macro ,sym (x y) - (declare (special *x*)) - (setf *x* t) - `(+ ,x ,y 1))) - (fun-def-form - `(defun ,sym (x y) (+ x y 1)))) + (macro-def-form + `(define-compiler-macro ,sym (x y) + (declare (special *x*)) + (setf *x* t) + `(+ ,x ,y 1))) + (fun-def-form + `(defun ,sym (x y) (+ x y 1)))) (values (equalt (list sym) (multiple-value-list (eval fun-def-form))) (equalt (list sym) (multiple-value-list (eval macro-def-form))) @@ -43,19 +43,19 @@ (eval `(,sym 6 19)) (let ((fn (compile nil `(lambda (a b) (,sym a b))))) (let ((*x* nil)) - (declare (special *x*)) - (list (funcall fn 12 123) *x*))))) + (declare (special *x*)) + (list (funcall fn 12 123) *x*))))) t t t 26 (136 nil)) (deftest define-compiler-macro.2 (let* ((sym (gensym)) - (macro-def-form - `(define-compiler-macro ,sym (&whole form &rest args) - (declare (special *x*) (ignore args)) - (setf *x* t) - (return-from ,sym form))) - (fun-def-form - `(defun ,sym (x) x))) + (macro-def-form + `(define-compiler-macro ,sym (&whole form &rest args) + (declare (special *x*) (ignore args)) + (setf *x* t) + (return-from ,sym form))) + (fun-def-form + `(defun ,sym (x) x))) (values (equalt (list sym) (multiple-value-list (eval fun-def-form))) (equalt (list sym) (multiple-value-list (eval macro-def-form))) @@ -63,19 +63,19 @@ (eval `(,sym 'a)) (let ((fn (compile nil `(lambda (a) (,sym a))))) (let ((*x* nil)) - (declare (special *x*)) - (list (funcall fn 'b) *x*))))) + (declare (special *x*)) + (list (funcall fn 'b) *x*))))) t t t a (b nil)) (deftest define-compiler-macro.3 (let* ((sym (gensym)) - (macro-def-form - `(define-compiler-macro ,sym (&whole form &rest args) - (declare (special *x*) (ignore args)) - (setf *x* t) - (return-from ,sym form))) - (ordinary-macro-def-form - `(defmacro ,sym (x) x))) + (macro-def-form + `(define-compiler-macro ,sym (&whole form &rest args) + (declare (special *x*) (ignore args)) + (setf *x* t) + (return-from ,sym form))) + (ordinary-macro-def-form + `(defmacro ,sym (x) x))) (values (equalt (list sym) (multiple-value-list (eval ordinary-macro-def-form))) (equalt (list sym) (multiple-value-list (eval macro-def-form))) @@ -83,21 +83,21 @@ (eval `(,sym 'a)) (let ((fn (compile nil `(lambda (a) (,sym a))))) (let ((*x* nil)) - (declare (special *x*)) - (list (funcall fn 'b) *x*))))) + (declare (special *x*)) + (list (funcall fn 'b) *x*))))) t t t a (b nil)) ;;; Compiler macros on setf functions (deftest define-compiler-macro.4 (let* ((sym (gensym)) - (fun-def-form `(defun ,sym (x) (car x))) - (setf-fun-def-form `(defun (setf ,sym) (newval x) (setf (car x) newval))) - (setf-compiler-macro-def-form - `(define-compiler-macro (setf ,sym) (newval x) - (declare (special *x*)) - (setf *x* t) - (return-from ,sym `(setf (car ,x) ,newval))))) + (fun-def-form `(defun ,sym (x) (car x))) + (setf-fun-def-form `(defun (setf ,sym) (newval x) (setf (car x) newval))) + (setf-compiler-macro-def-form + `(define-compiler-macro (setf ,sym) (newval x) + (declare (special *x*)) + (setf *x* t) + (return-from ,sym `(setf (car ,x) ,newval))))) (values (equalt (list sym) (multiple-value-list (eval fun-def-form))) (equalt `((setf ,sym)) (multiple-value-list (eval setf-fun-def-form))) @@ -105,20 +105,20 @@ (notnot (typep (compiler-macro-function `(setf ,sym)) 'function)) (eval `(,sym (list 'a 'b))) (eval `(let ((arg (list 1 2))) - (list (setf (,sym arg) 'z) arg))) + (list (setf (,sym arg) 'z) arg))) (let ((fn (compile nil `(lambda (u v) (setf (,sym u) v))))) (let ((*x* nil) - (arg (list 1 2))) - (declare (special *x*)) - (list (funcall fn arg 'y) arg))))) + (arg (list 1 2))) + (declare (special *x*)) + (list (funcall fn arg 'y) arg))))) t t t t a (z (z 2)) (y (y 2))) ;;; Test of documentation (deftest define-compiler-macro.5 (let* ((sym (gensym)) - (form `(define-compiler-macro ,sym (x) "DCM.5" x)) - (form2 `(defun ,sym (x) "DCM.5-WRONG" x))) + (form `(define-compiler-macro ,sym (x) "DCM.5" x)) + (form2 `(defun ,sym (x) "DCM.5-WRONG" x))) (eval form) (eval form2) (or (documentation sym 'compiler-macro) "DCM.5")) @@ -126,8 +126,8 @@ (deftest define-compiler-macro.6 (let* ((sym (gensym)) - (form `(define-compiler-macro ,sym (x) "DCM.6" x)) - (form2 `(defun ,sym (x) "DCM.6-WRONG" x))) + (form `(define-compiler-macro ,sym (x) "DCM.6" x)) + (form2 `(defun ,sym (x) "DCM.6-WRONG" x))) (eval form2) (eval form) (or (documentation sym 'compiler-macro) "DCM.6")) @@ -137,11 +137,11 @@ (deftest define-compiler-macro.7 (let* ((sym (gensym)) - (form `(define-compiler-macro ,sym (x y) - (declare (special *x*)) - (setf *x* :bad) - `(list ,x ,y))) - (form2 `(defun ,sym (x y) (list x y)))) + (form `(define-compiler-macro ,sym (x y) + (declare (special *x*)) + (setf *x* :bad) + `(list ,x ,y))) + (form2 `(defun ,sym (x y) (list x y)))) (eval form) (eval form2) (compile sym) @@ -149,27 +149,27 @@ (declare (special *x*)) (values (funcall (compile nil `(lambda (a b) - (declare (notinline ,sym)) - (,sym a b))) - 5 11) + (declare (notinline ,sym)) + (,sym a b))) + 5 11) *x*))) (5 11) :good) (deftest define-compiler-macro.8 (let* ((sym (gensym)) - (form `(define-compiler-macro ,sym (x y) - (declare (special *x*)) - (setf *x* :bad) - `(list ,x ,y))) - (form2 `(defmacro ,sym (x y) `(list ,x ,y)))) + (form `(define-compiler-macro ,sym (x y) + (declare (special *x*)) + (setf *x* :bad) + `(list ,x ,y))) + (form2 `(defmacro ,sym (x y) `(list ,x ,y)))) (eval form) (eval form2) (let ((*x* :good)) (declare (special *x*)) (values (funcall (compile nil `(lambda (a b) - (declare (notinline ,sym)) - (,sym a b))) - 7 23) + (declare (notinline ,sym)) + (,sym a b))) + 7 23) *x*))) (7 23) :good) diff --git a/ansi-tests/define-condition-aux.lsp b/ansi-tests/define-condition-aux.lsp index 798575fd..bc179677 100644 --- a/ansi-tests/define-condition-aux.lsp +++ b/ansi-tests/define-condition-aux.lsp @@ -7,78 +7,78 @@ (defun make-def-cond-name (name &rest suffixes) (intern (apply #'concatenate 'string (string name) "/" - (mapcar #'string suffixes)) - :cl-test)) + (mapcar #'string suffixes)) + :cl-test)) (defmacro define-condition-with-tests (name-symbol - parents slot-specs &rest options) + parents slot-specs &rest options) "Create a condition and some associated tests." (assert (symbolp name-symbol)) (dolist (parent parents) (assert (symbolp parent))) - + (let ((name (symbol-name name-symbol))) `(eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (eval '(define-condition ,name-symbol ,parents - ,slot-specs ,@options))) + ,slot-specs ,@options))) ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent) - (subtypep* ',name-symbol ',parent) - t t)) + collect + `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF/" parent) + (subtypep* ',name-symbol ',parent) + t t)) ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF-2/" parent) - (check-all-subtypep ',name-symbol ',parent) - nil)) + collect + `(deftest ,(make-def-cond-name name "IS-SUBTYPE-OF-2/" parent) + (check-all-subtypep ',name-symbol ',parent) + nil)) ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name - "IS-NOT-SUPERTYPE-OF/" parent) - (subtypep* ',parent ',name-symbol) - nil t)) + collect + `(deftest ,(make-def-cond-name name + "IS-NOT-SUPERTYPE-OF/" parent) + (subtypep* ',parent ',name-symbol) + nil t)) ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name "IS-A/" parent) - (let ((c (make-condition ',name-symbol))) - (notnot-mv (typep c ',parent))) - t)) + collect + `(deftest ,(make-def-cond-name name "IS-A/" parent) + (let ((c (make-condition ',name-symbol))) + (notnot-mv (typep c ',parent))) + t)) ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name "IS-SUBCLASS-OF/" parent) - (subtypep* (find-class ',name-symbol) - (find-class ',parent)) - t t)) + collect + `(deftest ,(make-def-cond-name name "IS-SUBCLASS-OF/" parent) + (subtypep* (find-class ',name-symbol) + (find-class ',parent)) + t t)) ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name - "IS-NOT-SUPERCLASS-OF/" parent) - (subtypep* (find-class ',parent) - (find-class ',name-symbol)) - nil t)) + collect + `(deftest ,(make-def-cond-name name + "IS-NOT-SUPERCLASS-OF/" parent) + (subtypep* (find-class ',parent) + (find-class ',name-symbol)) + nil t)) ,@(loop for parent in (adjoin 'condition parents) - collect - `(deftest ,(make-def-cond-name name "IS-A-MEMBER-OF-CLASS/" - parent) - (let ((c (make-condition ',name-symbol))) - (notnot-mv (typep c (find-class ',parent)))) - t)) + collect + `(deftest ,(make-def-cond-name name "IS-A-MEMBER-OF-CLASS/" + parent) + (let ((c (make-condition ',name-symbol))) + (notnot-mv (typep c (find-class ',parent)))) + t)) (deftest ,(make-def-cond-name name "HANDLER-CASE-1") (let ((c (make-condition ',name-symbol))) - (handler-case (normally (signal c)) - (,name-symbol (c1) (eqt c c1)))) + (handler-case (normally (signal c)) + (,name-symbol (c1) (eqt c c1)))) t) (deftest ,(make-def-cond-name name "HANDLER-CASE-2") (let ((c (make-condition ',name-symbol))) - (handler-case (normally (signal c)) - (condition (c1) (eqt c c1)))) + (handler-case (normally (signal c)) + (condition (c1) (eqt c c1)))) t) ,@(unless (some #'(lambda (ct) (subtypep ct 'error)) parents) - `((deftest ,(make-def-cond-name name "HANDLER-CASE-3") - (let ((c (make-condition ',name-symbol))) - (handler-case (normally (signal c)) - (error () nil) - (,name-symbol (c2) (eqt c c2)))) - t))) + `((deftest ,(make-def-cond-name name "HANDLER-CASE-3") + (let ((c (make-condition ',name-symbol))) + (handler-case (normally (signal c)) + (error () nil) + (,name-symbol (c2) (eqt c c2)))) + t))) ))) diff --git a/ansi-tests/define-condition.lsp b/ansi-tests/define-condition.lsp index 110d029b..cba8fd5f 100644 --- a/ansi-tests/define-condition.lsp +++ b/ansi-tests/define-condition.lsp @@ -20,8 +20,8 @@ (deftest condition-4-slots.1 (let ((c (make-condition 'condition-4 :slot1 'a :slot2 'b))) (and (typep c 'condition-4) - (eqlt (condition-4/slot-1 c) 'a) - (eqlt (condition-4/slot-2 c) 'b))) + (eqlt (condition-4/slot-1 c) 'a) + (eqlt (condition-4/slot-2 c) 'b))) t) (define-condition-with-tests condition-5 nil @@ -31,70 +31,70 @@ (deftest condition-5-slots.1 (let ((c (make-condition 'condition-5 :slot1 'a :slot2 'b))) (and (typep c 'condition-5) - (eqlt (condition-5/slot-1 c) 'a) - (eqlt (condition-5/slot-2 c) 'b))) + (eqlt (condition-5/slot-1 c) 'a) + (eqlt (condition-5/slot-2 c) 'b))) t) (deftest condition-5-slots.2 (let ((c (make-condition 'condition-5 :slot1 'a))) (and (typep c 'condition-5) - (eqlt (condition-5/slot-1 c) 'a) - (eqlt (condition-5/slot-2 c) 'y))) + (eqlt (condition-5/slot-1 c) 'a) + (eqlt (condition-5/slot-2 c) 'y))) t) (deftest condition-5-slots.3 (let ((c (make-condition 'condition-5 :slot2 'b))) (and (typep c 'condition-5) - (eqlt (condition-5/slot-1 c) 'x) - (eqlt (condition-5/slot-2 c) 'b))) + (eqlt (condition-5/slot-1 c) 'x) + (eqlt (condition-5/slot-2 c) 'b))) t) (deftest condition-5-slots.4 (let ((c (make-condition 'condition-5))) (and (typep c 'condition-5) - (eqlt (condition-5/slot-1 c) 'x) - (eqlt (condition-5/slot-2 c) 'y))) + (eqlt (condition-5/slot-1 c) 'x) + (eqlt (condition-5/slot-2 c) 'y))) t) (define-condition-with-tests condition-6 nil ((slot1 :initarg :slot1 :initarg :both-slots - :initform 'x :reader condition-6/slot-1) + :initform 'x :reader condition-6/slot-1) (slot2 :initarg :slot2 :initarg :both-slots - :initform 'y :reader condition-6/slot-2))) + :initform 'y :reader condition-6/slot-2))) (deftest condition-6-slots.1 (let ((c (make-condition 'condition-6 :both-slots 'a))) (and (typep c 'condition-6) - (eqlt (condition-6/slot-1 c) 'a) - (eqlt (condition-6/slot-2 c) 'a))) + (eqlt (condition-6/slot-1 c) 'a) + (eqlt (condition-6/slot-2 c) 'a))) t) (deftest condition-6-slots.2 (let ((c (make-condition 'condition-6))) (and (typep c 'condition-6) - (eqlt (condition-6/slot-1 c) 'x) - (eqlt (condition-6/slot-2 c) 'y))) + (eqlt (condition-6/slot-1 c) 'x) + (eqlt (condition-6/slot-2 c) 'y))) t) (deftest condition-6-slots.3 (let ((c (make-condition 'condition-6 :slot1 'a :both-slots 'b))) (and (typep c 'condition-6) - (eqlt (condition-6/slot-1 c) 'a) - (eqlt (condition-6/slot-2 c) 'b))) + (eqlt (condition-6/slot-1 c) 'a) + (eqlt (condition-6/slot-2 c) 'b))) t) (deftest condition-6-slots.4 (let ((c (make-condition 'condition-6 :slot2 'b :both-slots 'a))) (and (typep c 'condition-6) - (eqlt (condition-6/slot-1 c) 'a) - (eqlt (condition-6/slot-2 c) 'b))) + (eqlt (condition-6/slot-1 c) 'a) + (eqlt (condition-6/slot-2 c) 'b))) t) (deftest condition-6-slots.5 (let ((c (make-condition 'condition-6 :both-slots 'a :slot1 'c :slot2 'd))) (and (typep c 'condition-6) - (eqlt (condition-6/slot-1 c) 'a) - (eqlt (condition-6/slot-2 c) 'a))) + (eqlt (condition-6/slot-1 c) 'a) + (eqlt (condition-6/slot-2 c) 'a))) t) (define-condition-with-tests condition-7 nil @@ -103,25 +103,25 @@ (deftest condition-7-slots.1 (let ((c (make-condition 'condition-7 :i1 'a))) (and (typep c 'condition-7) - (eqlt (condition-7/s c) 'a))) + (eqlt (condition-7/s c) 'a))) t) (deftest condition-7-slots.2 (let ((c (make-condition 'condition-7 :i2 'a))) (and (typep c 'condition-7) - (eqlt (condition-7/s c) 'a))) + (eqlt (condition-7/s c) 'a))) t) (deftest condition-7-slots.3 (let ((c (make-condition 'condition-7 :i1 'a :i2 'b))) (and (typep c 'condition-7) - (eqlt (condition-7/s c) 'a))) + (eqlt (condition-7/s c) 'a))) t) (deftest condition-7-slots.4 (let ((c (make-condition 'condition-7 :i2 'a :i1 'b))) (and (typep c 'condition-7) - (eqlt (condition-7/s c) 'a))) + (eqlt (condition-7/s c) 'a))) t) (defparameter *condition-8-counter* 0) @@ -144,83 +144,83 @@ (deftest condition-9-slots.1 (let ((c (make-condition 'condition-9))) (values (notnot (typep c 'condition-9)) - (condition-9/s1 c) - (condition-9/s2 c))) + (condition-9/s1 c) + (condition-9/s2 c))) t 15 37) (deftest condition-9-slots.2 (let ((c (make-condition 'condition-9 :i1 3))) (values (notnot (typep c 'condition-9)) - (condition-9/s1 c) - (condition-9/s2 c))) + (condition-9/s1 c) + (condition-9/s2 c))) t 3 37) (deftest condition-9-slots.3 (let ((c (make-condition 'condition-9 :i2 3))) (values (notnot (typep c 'condition-9)) - (condition-9/s1 c) - (condition-9/s2 c))) + (condition-9/s1 c) + (condition-9/s2 c))) t 15 3) (deftest condition-9-slots.4 (let ((c (make-condition 'condition-9 :i2 3 :i2 8))) (values (notnot (typep c 'condition-9)) - (condition-9/s1 c) - (condition-9/s2 c))) + (condition-9/s1 c) + (condition-9/s2 c))) t 15 3) (deftest condition-9-slots.5 (let ((c (make-condition 'condition-9 :i1 3 :i2 8))) (values (notnot (typep c 'condition-9)) - (condition-9/s1 c) - (condition-9/s2 c))) + (condition-9/s1 c) + (condition-9/s2 c))) t 3 8) (deftest condition-9-slots.6 (let ((c (make-condition 'condition-9 :i1 3 :i2 8 :i1 100 :i2 500))) (values (notnot (typep c 'condition-9)) - (condition-9/s1 c) - (condition-9/s2 c))) + (condition-9/s1 c) + (condition-9/s2 c))) t 3 8) ;;; (define-condition-with-tests condition-10 nil ;;; ((s1 :initarg :i1 :writer condition-10/s1-w :reader condition-10/s1-r))) -;;; +;;; ;;; (deftest condition-10-slots.1 ;;; (let ((c (make-condition 'condition-10 :i1 11))) ;;; (condition-10/s1-r c)) ;;; 11) -;;; +;;; ;;; (deftest condition-10-slots.2 ;;; (let ((c (make-condition 'condition-10 :i1 11))) ;;; (condition-10/s1-w 17 c)) ;;; 17) -;;; +;;; ;;; (deftest condition-10-slots.3 ;;; (let ((c (make-condition 'condition-10 :i1 11))) ;;; (condition-10/s1-w 107 c) ;;; (condition-10/s1-r c)) ;;; 107) -;;; +;;; ;;; (define-condition-with-tests condition-11 nil ;;; ((s1 :initarg :i1 :writer (setf condition-11/w) :reader condition-11/r))) -;;; +;;; ;;; (deftest condition-11-slots.1 ;;; (let ((c (make-condition 'condition-11 :i1 11))) ;;; (condition-11/r c)) ;;; 11) -;;; +;;; ;;; (deftest condition-11-slots.2 ;;; (let ((c (make-condition 'condition-11 :i1 11))) ;;; (setf (condition-11/w c) 17)) ;;; 17) -;;; +;;; ;;; (deftest condition-11-slots.3 ;;; (let ((c (make-condition 'condition-11 :i1 11))) ;;; (setf (condition-11/w c) 117) ;;; (condition-11/r c)) ;;; 117) -;;; +;;; ;;; (deftest condition-11-slots.4 ;;; (let ((c (make-condition 'condition-11 :i1 11))) ;;; (values @@ -235,23 +235,23 @@ ;;; (define-condition-with-tests condition-12 nil ;;; (((slot1) :initarg :slot1 :reader condition-12/slot-1) ;;; ((slot2) :initarg :slot2 :reader condition-12/slot-2))) -;;; +;;; ;;; (deftest condition-12-slots.1 ;;; (let ((c (make-condition 'condition-12 :slot1 'a :slot2 'b))) ;;; (and (typep c 'condition-12) -;;; (eqlt (condition-12/slot-1 c) 'a) -;;; (eqlt (condition-12/slot-2 c) 'b))) +;;; (eqlt (condition-12/slot-1 c) 'a) +;;; (eqlt (condition-12/slot-2 c) 'b))) ;;; t) -;;; +;;; ;;; (define-condition-with-tests condition-13 nil ;;; (((slot1 10) :initarg :slot1 :reader condition-13/slot-1))) -;;; +;;; ;;; (deftest condition-13-slots.1 ;;; (let ((c (make-condition 'condition-13))) ;;; (and (typep c 'condition-13) -;;; (condition-13/slot-1 c))) +;;; (condition-13/slot-1 c))) ;;; 10) - + (define-condition-with-tests condition-14 nil ((s1 :initarg :i1 :type fixnum :reader condition-14/s1) (s2 :initarg :i2 :type t :reader condition-14/s2))) @@ -259,20 +259,20 @@ (deftest condition-14-slots.1 (let ((c (make-condition 'condition-14 :i1 10))) (and (typep c 'condition-14) - (condition-14/s1 c))) + (condition-14/s1 c))) 10) (deftest condition-14-slots.2 (let ((c (make-condition 'condition-14 :i2 'a))) (and (typep c 'condition-14) - (condition-14/s2 c))) + (condition-14/s2 c))) a) (deftest condition-14-slots.3 (let ((c (make-condition 'condition-14 :i1 10 :i2 'h))) (and (typep c 'condition-14) - (eqlt (condition-14/s1 c) 10) - (condition-14/s2 c))) + (eqlt (condition-14/s1 c) 10) + (condition-14/s2 c))) h) (define-condition-with-tests condition-15 nil @@ -284,7 +284,7 @@ (deftest condition-16-report.1 (let ((*print-escape* nil) - (c (make-condition 'condition-16))) + (c (make-condition 'condition-16))) (with-output-to-string (s) (print-object c s))) "The report for condition-16") @@ -297,7 +297,7 @@ (deftest condition-17-report.1 (let ((*print-escape* nil) - (c (make-condition 'condition-17 :i1 1234))) + (c (make-condition 'condition-17 :i1 1234))) (with-output-to-string (s) (print-object c s))) "condition-17: 1234") @@ -307,7 +307,7 @@ (deftest condition-18-report.1 (let ((*print-escape* nil) - (c (make-condition 'condition-18 :i1 4321))) + (c (make-condition 'condition-18 :i1 4321))) (with-output-to-string (s) (print-object c s))) "condition-18: 4321") @@ -324,7 +324,7 @@ ((s1 :reader condition-19/s1 :initarg :i1) (s2 :reader condition-19/s2 :initarg :i2)) (:default-initargs :i1 10 - :i2 20)) + :i2 20)) (deftest condition-19-slots.1 (let ((c (make-condition 'condition-19))) @@ -373,11 +373,11 @@ ((s1 :reader condition-20/s1 :initarg :i1) (s2 :reader condition-20/s2 :initarg :i2)) (:default-initargs :i1 (incf *condition-20/s1-val*) - :i2 (incf *condition-20/s2-val*))) + :i2 (incf *condition-20/s2-val*))) (deftest condition-20-slots.1 (let ((*condition-20/s1-val* 0) - (*condition-20/s2-val* 10)) + (*condition-20/s2-val* 10)) (declare (special *condition-20/s1-val* *condition-20/s2-val*)) (let ((c (make-condition 'condition-20))) (values @@ -390,7 +390,7 @@ (deftest condition-20-slots.2 (let ((*condition-20/s1-val* 0) - (*condition-20/s2-val* 10)) + (*condition-20/s2-val* 10)) (declare (special *condition-20/s1-val* *condition-20/s2-val*)) (let ((c (make-condition 'condition-20 :i1 'x))) (values @@ -403,7 +403,7 @@ (deftest condition-20-slots.3 (let ((*condition-20/s1-val* 0) - (*condition-20/s2-val* 10)) + (*condition-20/s2-val* 10)) (declare (special *condition-20/s1-val* *condition-20/s2-val*)) (let ((c (make-condition 'condition-20 :i2 'y))) (values @@ -416,7 +416,7 @@ (deftest condition-20-slots.4 (let ((*condition-20/s1-val* 0) - (*condition-20/s2-val* 10)) + (*condition-20/s2-val* 10)) (declare (special *condition-20/s1-val* *condition-20/s2-val*)) (let ((c (make-condition 'condition-20 :i2 'y :i1 'x))) (values @@ -435,9 +435,9 @@ (deftest condition-21-slots.1 (let ((c (make-condition 'condition-21 :slot1 'a :slot2 'b))) (and (typep c 'condition-4) - (typep c 'condition-21) - (eqlt (condition-4/slot-1 c) 'a) - (eqlt (condition-4/slot-2 c) 'b))) + (typep c 'condition-21) + (eqlt (condition-4/slot-1 c) 'a) + (eqlt (condition-4/slot-2 c) 'b))) t) (define-condition-with-tests condition-22 (condition-4) @@ -446,14 +446,14 @@ (deftest condition-22-slots.1 (let ((c (make-condition 'condition-22 :slot1 'a :slot2 'b - :slot3 'c :slot4 'd))) + :slot3 'c :slot4 'd))) (and (typep c 'condition-4) - (typep c 'condition-22) - (eqlt (condition-4/slot-1 c) 'a) - (eqlt (condition-4/slot-2 c) 'b) - (eqlt (condition-22/slot-3 c) 'c) - (eqlt (condition-22/slot-4 c) 'd) - )) + (typep c 'condition-22) + (eqlt (condition-4/slot-1 c) 'a) + (eqlt (condition-4/slot-2 c) 'b) + (eqlt (condition-22/slot-3 c) 'c) + (eqlt (condition-22/slot-4 c) 'd) + )) t) (define-condition-with-tests condition-23 (condition-5) nil) @@ -461,37 +461,37 @@ (deftest condition-23-slots.1 (let ((c (make-condition 'condition-23 :slot1 'a :slot2 'b))) (and (typep c 'condition-5) - (typep c 'condition-23) - (eqlt (condition-5/slot-1 c) 'a) - (eqlt (condition-5/slot-2 c) 'b) - )) + (typep c 'condition-23) + (eqlt (condition-5/slot-1 c) 'a) + (eqlt (condition-5/slot-2 c) 'b) + )) t) (deftest condition-23-slots.2 (let ((c (make-condition 'condition-23 :slot1 'a))) (and (typep c 'condition-5) - (typep c 'condition-23) - (eqlt (condition-5/slot-1 c) 'a) - (eqlt (condition-5/slot-2 c) 'y) - )) + (typep c 'condition-23) + (eqlt (condition-5/slot-1 c) 'a) + (eqlt (condition-5/slot-2 c) 'y) + )) t) (deftest condition-23-slots.3 (let ((c (make-condition 'condition-23 :slot2 'b))) (and (typep c 'condition-5) - (typep c 'condition-23) - (eqlt (condition-5/slot-1 c) 'x) - (eqlt (condition-5/slot-2 c) 'b) - )) + (typep c 'condition-23) + (eqlt (condition-5/slot-1 c) 'x) + (eqlt (condition-5/slot-2 c) 'b) + )) t) (deftest condition-23-slots.4 (let ((c (make-condition 'condition-23))) (and (typep c 'condition-5) - (typep c 'condition-23) - (eqlt (condition-5/slot-1 c) 'x) - (eqlt (condition-5/slot-2 c) 'y) - )) + (typep c 'condition-23) + (eqlt (condition-5/slot-1 c) 'x) + (eqlt (condition-5/slot-2 c) 'y) + )) t) (define-condition-with-tests condition-24 (condition-5) @@ -501,37 +501,37 @@ (deftest condition-24-slots.1 (let ((c (make-condition 'condition-24))) (and (typep c 'condition-5) - (typep c 'condition-24) - (eqlt (condition-5/slot-1 c) 'z) - (eqlt (condition-5/slot-2 c) 'y) - )) + (typep c 'condition-24) + (eqlt (condition-5/slot-1 c) 'z) + (eqlt (condition-5/slot-2 c) 'y) + )) t) (deftest condition-24-slots.2 (let ((c (make-condition 'condition-24 :slot1 'a))) (and (typep c 'condition-5) - (typep c 'condition-24) - (eqlt (condition-5/slot-1 c) 'a) - (eqlt (condition-5/slot-2 c) 'y) - )) + (typep c 'condition-24) + (eqlt (condition-5/slot-1 c) 'a) + (eqlt (condition-5/slot-2 c) 'y) + )) t) (deftest condition-24-slots.3 (let ((c (make-condition 'condition-24 :slot2 'a))) (and (typep c 'condition-5) - (typep c 'condition-24) - (eqlt (condition-5/slot-1 c) 'z) - (eqlt (condition-5/slot-2 c) 'a) - )) + (typep c 'condition-24) + (eqlt (condition-5/slot-1 c) 'z) + (eqlt (condition-5/slot-2 c) 'a) + )) t) (deftest condition-24-slots.4 (let ((c (make-condition 'condition-24 :slot1 'b :slot2 'a))) (and (typep c 'condition-5) - (typep c 'condition-24) - (eqlt (condition-5/slot-1 c) 'b) - (eqlt (condition-5/slot-2 c) 'a) - )) + (typep c 'condition-24) + (eqlt (condition-5/slot-1 c) 'b) + (eqlt (condition-5/slot-2 c) 'a) + )) t) ;;; Multiple inheritance @@ -548,51 +548,51 @@ (deftest condition-25-slots.1 (let ((c (make-condition 'condition-25))) (and (typep c 'condition-25a) - (typep c 'condition-25b) - (typep c 'condition-25) - (eqlt (condition-25a/s1 c) 'a) - (eqlt (condition-25b/s2 c) 'b) - (eqlt (condition-25/s3 c) 'c))) + (typep c 'condition-25b) + (typep c 'condition-25) + (eqlt (condition-25a/s1 c) 'a) + (eqlt (condition-25b/s2 c) 'b) + (eqlt (condition-25/s3 c) 'c))) t) (deftest condition-25-slots.2 (let ((c (make-condition 'condition-25 :s1 'x))) (and (typep c 'condition-25a) - (typep c 'condition-25b) - (typep c 'condition-25) - (eqlt (condition-25a/s1 c) 'x) - (eqlt (condition-25b/s2 c) 'b) - (eqlt (condition-25/s3 c) 'c))) + (typep c 'condition-25b) + (typep c 'condition-25) + (eqlt (condition-25a/s1 c) 'x) + (eqlt (condition-25b/s2 c) 'b) + (eqlt (condition-25/s3 c) 'c))) t) (deftest condition-25-slots.3 (let ((c (make-condition 'condition-25 :s2 'x))) (and (typep c 'condition-25a) - (typep c 'condition-25b) - (typep c 'condition-25) - (eqlt (condition-25a/s1 c) 'a) - (eqlt (condition-25b/s2 c) 'x) - (eqlt (condition-25/s3 c) 'c))) + (typep c 'condition-25b) + (typep c 'condition-25) + (eqlt (condition-25a/s1 c) 'a) + (eqlt (condition-25b/s2 c) 'x) + (eqlt (condition-25/s3 c) 'c))) t) (deftest condition-25-slots.4 (let ((c (make-condition 'condition-25 :s3 'x))) (and (typep c 'condition-25a) - (typep c 'condition-25b) - (typep c 'condition-25) - (eqlt (condition-25a/s1 c) 'a) - (eqlt (condition-25b/s2 c) 'b) - (eqlt (condition-25/s3 c) 'x))) + (typep c 'condition-25b) + (typep c 'condition-25) + (eqlt (condition-25a/s1 c) 'a) + (eqlt (condition-25b/s2 c) 'b) + (eqlt (condition-25/s3 c) 'x))) t) (deftest condition-25-slots.5 (let ((c (make-condition 'condition-25 :s3 'z :s2 'y :s1 'x))) (and (typep c 'condition-25a) - (typep c 'condition-25b) - (typep c 'condition-25) - (eqlt (condition-25a/s1 c) 'x) - (eqlt (condition-25b/s2 c) 'y) - (eqlt (condition-25/s3 c) 'z))) + (typep c 'condition-25b) + (typep c 'condition-25) + (eqlt (condition-25a/s1 c) 'x) + (eqlt (condition-25b/s2 c) 'y) + (eqlt (condition-25/s3 c) 'z))) t) ;;; @@ -607,19 +607,19 @@ (deftest condition-26-slots.1 (let ((c (make-condition 'condition-26))) (and (typep c 'condition-26a) - (typep c 'condition-26b) - (typep c 'condition-26c) - (typep c 'condition-26) - (eqlt (condition-26a/s1 c) 'a))) + (typep c 'condition-26b) + (typep c 'condition-26c) + (typep c 'condition-26) + (eqlt (condition-26a/s1 c) 'a))) t) (deftest condition-26-slots.2 (let ((c (make-condition 'condition-26 :s1 'x))) (and (typep c 'condition-26a) - (typep c 'condition-26b) - (typep c 'condition-26c) - (typep c 'condition-26) - (eqlt (condition-26a/s1 c) 'x))) + (typep c 'condition-26b) + (typep c 'condition-26c) + (typep c 'condition-26) + (eqlt (condition-26a/s1 c) 'x))) t) @@ -636,15 +636,15 @@ (deftest condition-27-slots.1 (let ((c (make-condition 'condition-27a))) (and (typep c 'condition-27a) - (not (typep c 'condition-27b)) - (eqlt (condition-27/s1 c) 'a))) + (not (typep c 'condition-27b)) + (eqlt (condition-27/s1 c) 'a))) t) (deftest condition-27-slots.2 (let ((c (make-condition 'condition-27b))) (and (typep c 'condition-27b) - (not (typep c 'condition-27a)) - (eqlt (condition-27/s1 c) 'a))) + (not (typep c 'condition-27a)) + (eqlt (condition-27/s1 c) 'a))) t) (deftest condition-27-reader-is-generic @@ -668,41 +668,41 @@ (deftest condition-28-slots.1 (let ((c (make-condition 'condition-28))) (and (typep c 'condition-28a) - (typep c 'condition-28) - (eqlt (condition-28a/s1 c) 'x) - (eqlt (condition-28/s1 c) 'x))) + (typep c 'condition-28) + (eqlt (condition-28a/s1 c) 'x) + (eqlt (condition-28/s1 c) 'x))) t) (deftest condition-28-slots.2 (let ((c (make-condition 'condition-28 :i1 'z))) (and (typep c 'condition-28a) - (typep c 'condition-28) - (eqlt (condition-28a/s1 c) 'z) - (eqlt (condition-28/s1 c) 'z))) + (typep c 'condition-28) + (eqlt (condition-28a/s1 c) 'z) + (eqlt (condition-28/s1 c) 'z))) t) (deftest condition-28-slots.3 (let ((c (make-condition 'condition-28 :i1a 'w))) (and (typep c 'condition-28a) - (typep c 'condition-28) - (eqlt (condition-28a/s1 c) 'w) - (eqlt (condition-28/s1 c) 'w))) + (typep c 'condition-28) + (eqlt (condition-28a/s1 c) 'w) + (eqlt (condition-28/s1 c) 'w))) t) (deftest condition-28-slots.4 (let ((c (make-condition 'condition-28 :i1 'y :i1a 'w))) (and (typep c 'condition-28a) - (typep c 'condition-28) - (eqlt (condition-28a/s1 c) 'y) - (eqlt (condition-28/s1 c) 'y))) + (typep c 'condition-28) + (eqlt (condition-28a/s1 c) 'y) + (eqlt (condition-28/s1 c) 'y))) t) (deftest condition-28-slots.5 (let ((c (make-condition 'condition-28 :i1a 'y :i1 'w))) (and (typep c 'condition-28a) - (typep c 'condition-28) - (eqlt (condition-28a/s1 c) 'y) - (eqlt (condition-28/s1 c) 'y))) + (typep c 'condition-28) + (eqlt (condition-28a/s1 c) 'y) + (eqlt (condition-28/s1 c) 'y))) t) |# diff --git a/ansi-tests/define-method-combination-long-form.lsp b/ansi-tests/define-method-combination-long-form.lsp index 28eb4867..894333f2 100644 --- a/ansi-tests/define-method-combination-long-form.lsp +++ b/ansi-tests/define-method-combination-long-form.lsp @@ -65,8 +65,8 @@ (report-and-ignore-errors (defparameter *dmc-long-03* (define-method-combination mc-long-03 nil ((method-list * :order :most-specific-first - :description "This method has qualifiers ~A" - )) + :description "This method has qualifiers ~A" + )) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors (defgeneric dmc-long-gf-03 (x y) (:method-combination mc-long-03))) @@ -100,7 +100,7 @@ (defparameter *dmc-long-04* (let ((order :most-specific-last)) (define-method-combination mc-long-04 nil ((method-list * :order order)) - `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list)))))) + `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list)))))) (report-and-ignore-errors (defgeneric dmc-long-gf-04 (x y) (:method-combination mc-long-04))) ) @@ -126,12 +126,12 @@ t) ;;; Empty qualifier list - + (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-05* (define-method-combination mc-long-05 nil ((method-list nil) - (ignored-methods *)) + (ignored-methods *)) (declare (ignorable ignored-methods)) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors @@ -157,12 +157,12 @@ #() #(z) #(a z) #(b z) #(a b z)) ;;; :required - + (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defparameter *dmc-long-06* (define-method-combination mc-long-06 nil ((method-list nil :required t) - (ignored-methods *)) + (ignored-methods *)) (declare (ignorable ignored-methods)) `(vector ,@(mapcar #'(lambda (m) `(call-method ,m)) method-list))))) (report-and-ignore-errors diff --git a/ansi-tests/define-method-combination.lsp b/ansi-tests/define-method-combination.lsp index 95346593..2b7dc924 100644 --- a/ansi-tests/define-method-combination.lsp +++ b/ansi-tests/define-method-combination.lsp @@ -20,9 +20,9 @@ (define-method-combination times :documentation "Multiplicative method combination, version 1" :operator *)) - + (defgeneric dmc-gf-01 (x) (:method-combination times)) - + (defmethod dmc-gf-01 times ((x integer)) 2) (defmethod dmc-gf-01 times ((x rational)) 3) (defmethod dmc-gf-01 times ((x real)) 5) @@ -41,7 +41,7 @@ (deftest define-method-combination-01.2 (handler-case (eval '(locally (declare (optimize (safety 3))) - (dmc-gf-01 'x))) + (dmc-gf-01 'x))) (error () :good)) :good) @@ -52,13 +52,13 @@ (deftest define-method-combination-01.4 (let ((doc (documentation *dmc-times* 'method-combination))) (or (null doc) - (equalt doc "Multiplicative method combination, version 1"))) - t) + (equalt doc "Multiplicative method combination, version 1"))) + t) (eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors (defgeneric dmc-gf-02 (x) (:method-combination times)) - + (defmethod dmc-gf-02 times ((x integer)) 2) (defmethod dmc-gf-02 :around ((x rational)) (1- (call-next-method))) (defmethod dmc-gf-02 times ((x real)) 3) @@ -83,9 +83,9 @@ (prog1 (handler-case (progn - (eval '(defmethod dmc-gf-03 ((x integer)) t)) - (eval '(dmc-gf-03 1)) - :bad) + (eval '(defmethod dmc-gf-03 ((x integer)) t)) + (eval '(dmc-gf-03 1)) + :bad) (error () :good)) (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list 1))) (remove-method #'dmc-gf-03 meth))) @@ -95,9 +95,9 @@ (prog1 (handler-case (progn - (eval '(defmethod dmc-gf-03 :before ((x cons)) t)) - (eval '(dmc-gf-03 (cons 'a 'b))) - :bad) + (eval '(defmethod dmc-gf-03 :before ((x cons)) t)) + (eval '(dmc-gf-03 (cons 'a 'b))) + :bad) (error () :good)) (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list '(a)))) (remove-method #'dmc-gf-03 meth))) @@ -107,9 +107,9 @@ (prog1 (handler-case (progn - (eval '(defmethod dmc-gf-03 :after ((x symbol)) t)) - (eval '(dmc-gf-03 'a)) - :bad) + (eval '(defmethod dmc-gf-03 :after ((x symbol)) t)) + (eval '(dmc-gf-03 'a)) + :bad) (error () :good)) (dolist (meth (compute-applicable-methods #'dmc-gf-03 (list 'a))) (remove-method #'dmc-gf-03 meth))) @@ -120,9 +120,9 @@ (define-method-combination times2 :operator * :identity-with-one-argument t) - + (defgeneric dmc-gf-04 (x) (:method-combination times2)) - + (defmethod dmc-gf-04 times2 ((x dmc-class-01b)) 2) (defmethod dmc-gf-04 times2 ((x dmc-class-01c)) 3) (defmethod dmc-gf-04 times2 ((x dmc-class-01d)) 5) @@ -148,12 +148,12 @@ (deftest define-method-combination-05.1 (let* ((doc1 (setf (documentation *dmc-times-5* 'method-combination) - "foo")) - (doc2 (documentation *dmc-times-5* 'method-combination))) + "foo")) + (doc2 (documentation *dmc-times-5* 'method-combination))) (values doc1 (or (null doc2) - (equalt doc2 "foo")))) + (equalt doc2 "foo")))) "foo" t) ;; Operator name defaults to the method combination name. diff --git a/ansi-tests/define-modify-macro.lsp b/ansi-tests/define-modify-macro.lsp index a6c13e38..606fda14 100644 --- a/ansi-tests/define-modify-macro.lsp +++ b/ansi-tests/define-modify-macro.lsp @@ -7,17 +7,17 @@ (deftest define-modify-macro.1 (values - (eval '(define-modify-macro dmm1-appendf (&rest args) - append "Append lists onto a list")) - (eval + (eval '(define-modify-macro dmm1-appendf (&rest args) + append "Append lists onto a list")) + (eval '(let ((u '(p q r)) v) (list - (setq v u) - (dmm1-appendf u '(a b c d)) - (dmm1-appendf u ()) - (dmm1-appendf u '(e f g)) - u - v)))) + (setq v u) + (dmm1-appendf u '(a b c d)) + (dmm1-appendf u ()) + (dmm1-appendf u '(e f g)) + u + v)))) dmm1-appendf ((p q r) (p q r a b c d) @@ -32,9 +32,9 @@ (eval '(let ((i 10)) (list - (new-incf i) - (new-incf i 100) - i)))) + (new-incf i) + (new-incf i 100) + i)))) new-incf (11 111 111)) @@ -43,11 +43,11 @@ (eval '(define-modify-macro new-incf1 (&optional (delta 1)) +)) (eval '(let ((a (vector 0 0 0 0 0)) - (i 1)) + (i 1)) (list - (new-incf1 (aref a (incf i))) - a - i)))) + (new-incf1 (aref a (incf i))) + a + i)))) new-incf1 (1 #(0 0 1 0 0) 2)) @@ -56,29 +56,29 @@ (eval '(define-modify-macro new-incf2 (&optional (delta 1)) +)) (eval '(let ((a (vector 0 0 0 0 0)) - (i 1)) + (i 1)) (list - (new-incf2 (aref a (incf i)) (incf i)) - a - i)))) + (new-incf2 (aref a (incf i)) (incf i)) + a + i)))) new-incf2 (3 #(0 0 3 0 0) 3)) ;;; (deftest define-modify-macro.error.1 ;;; (signals-error (define-modify-macro) program-error) ;;; t) -;;; +;;; ;;; (deftest define-modify-macro.error.2 ;;; (signals-error (define-modify-macro dfm-error-1) program-error) ;;; t) -;;; +;;; ;;; (deftest define-modify-macro.error.3 ;;; (signals-error (define-modify-macro dfm-error-2 ()) program-error) ;;; t) -;;; +;;; ;;; (deftest define-modify-macro.error.4 ;;; (signals-error (define-modify-macro dfm-error-2 () nil "Documentation" -;;; "extra illegal argument") +;;; "extra illegal argument") ;;; program-error) ;;; t) @@ -98,7 +98,7 @@ (deftest define-modify-macro.documentation.2 (let ((sym (gensym)) - (doc "DMM-DOC")) + (doc "DMM-DOC")) (eval `(define-modify-macro ,sym (&optional (delta 1)) + ,doc)) (values (equalt doc (or (documentation sym 'function) doc)) diff --git a/ansi-tests/define-setf-expander.lsp b/ansi-tests/define-setf-expander.lsp index 005b268c..6552ecfb 100644 --- a/ansi-tests/define-setf-expander.lsp +++ b/ansi-tests/define-setf-expander.lsp @@ -17,16 +17,16 @@ (multiple-value-list (define-setf-expander my-car (place &environment env) (multiple-value-bind (temps vals stores set-form get-form) - (get-setf-expansion place env) - (declare (ignore stores set-form)) - (let ((store (gensym)) - (temp (gensym))) - (values - `(,@temps ,temp) - `(,@vals ,get-form) - `(,store) - `(progn (rplaca ,temp ,store) ,store) - `(my-car ,temp)))))))) + (get-setf-expansion place env) + (declare (ignore stores set-form)) + (let ((store (gensym)) + (temp (gensym))) + (values + `(,@temps ,temp) + `(,@vals ,get-form) + `(,store) + `(progn (rplaca ,temp ,store) ,store) + `(my-car ,temp)))))))) (deftest define-setf-expander.1 *define-setf-expander-vals.1* @@ -46,11 +46,11 @@ (get-setf-expansion '(my-car x)) (values (and (listp temps) - (notnot (every #'symbolp temps))) + (notnot (every #'symbolp temps))) (notnot (listp vals)) (and (listp stores) - (= (length stores) 1) - (notnot (every #'symbolp stores))) + (= (length stores) 1) + (notnot (every #'symbolp stores))) (equalt get `(my-car ,(second (second set)))))) t t t t) @@ -65,29 +65,29 @@ (defun my-assoc (key alist) (loop for pair in alist - when (and (consp pair) (eql key (car pair))) - return pair)) + when (and (consp pair) (eql key (car pair))) + return pair)) (ignore-errors (define-setf-expander my-assoc (key place &environment env) (multiple-value-bind (temps vals stores set-form get-form) - (get-setf-expansion place env) + (get-setf-expansion place env) (let ((store (gensym)) - (key-temp (gensym)) - (pair-temp (gensym)) - (place-temp (gensym))) - (return-from my-assoc - (values - `(,@temps ,key-temp ,place-temp ,pair-temp) - `(,@vals ,key ,get-form (my-assoc ,key-temp ,place-temp)) - `(,store) - `(if (null ,pair-temp) - (let ((,(car stores) - (cons (cons ,key-temp ,store) ,place-temp))) - ,set-form - ,store) - (setf (cdr ,pair-temp) ,store)) - `(cdr ,pair-temp))))))) + (key-temp (gensym)) + (pair-temp (gensym)) + (place-temp (gensym))) + (return-from my-assoc + (values + `(,@temps ,key-temp ,place-temp ,pair-temp) + `(,@vals ,key ,get-form (my-assoc ,key-temp ,place-temp)) + `(,store) + `(if (null ,pair-temp) + (let ((,(car stores) + (cons (cons ,key-temp ,store) ,place-temp))) + ,set-form + ,store) + (setf (cdr ,pair-temp) ,store)) + `(cdr ,pair-temp))))))) (deftest define-setf-expander.5 (let ((x nil)) @@ -103,21 +103,21 @@ (deftest define-setf-expander.6 (let ((n (gensym)) - (doc "D-S-EX.6")) + (doc "D-S-EX.6")) (assert (null (documentation n 'setf))) (assert (eql (eval `(define-setf-expander ,n () - ,doc (values nil nil nil nil nil))) - n)) + ,doc (values nil nil nil nil nil))) + n)) (or (documentation n 'setf) doc)) "D-S-EX.6") (deftest define-setf-expander.7 (let ((n (gensym)) - (doc "D-S-EX.7")) + (doc "D-S-EX.7")) (assert (null (documentation n 'setf))) (assert (eql (eval `(define-setf-expander ,n () - (values nil nil nil nil nil))) - n)) + (values nil nil nil nil nil))) + n)) (assert (null (documentation n 'setf))) (values (setf (documentation n 'setf) doc) diff --git a/ansi-tests/define-symbol-macro.lsp b/ansi-tests/define-symbol-macro.lsp index 623477fd..e3af2f46 100644 --- a/ansi-tests/define-symbol-macro.lsp +++ b/ansi-tests/define-symbol-macro.lsp @@ -7,20 +7,20 @@ (deftest define-symbol-macro.error.1 (signals-error (funcall (macro-function 'define-symbol-macro)) - program-error) + program-error) t) (deftest define-symbol-macro.error.2 (signals-error (funcall (macro-function 'define-symbol-macro) - '(define-symbol-macro - nonexistent-symbol-macro nil)) - program-error) + '(define-symbol-macro + nonexistent-symbol-macro nil)) + program-error) t) (deftest define-symbol-macro.error.3 (signals-error (funcall (macro-function 'define-symbol-macro) - '(define-symbol-macro - nonexistent-symbol-macro nil) - nil nil) - program-error) + '(define-symbol-macro + nonexistent-symbol-macro nil) + nil nil) + program-error) t) diff --git a/ansi-tests/defmacro.lsp b/ansi-tests/defmacro.lsp index bfe7dbee..5510951d 100644 --- a/ansi-tests/defmacro.lsp +++ b/ansi-tests/defmacro.lsp @@ -7,20 +7,20 @@ (deftest defmacro.error.1 (signals-error (funcall (macro-function 'defmacro)) - program-error) + program-error) t) (deftest defmacro.error.2 (signals-error (funcall (macro-function 'defmacro) - '(defmacro nonexistent-macro ())) - program-error) + '(defmacro nonexistent-macro ())) + program-error) t) (deftest defmacro.error.3 (signals-error (funcall (macro-function 'defmacro) - '(defmacro nonexistent-macro ()) - nil nil) - program-error) + '(defmacro nonexistent-macro ()) + nil nil) + program-error) t) ;;; FIXME @@ -29,7 +29,7 @@ (deftest defmacro.1 (progn (assert (eq (defmacro defmacro.1-macro (x y) `(list 1 ,x 2 ,y 3)) - 'defmacro.1-macro)) + 'defmacro.1-macro)) (assert (macro-function 'defmacro.1-macro)) (eval `(defmacro.1-macro 'a 'b))) (1 a 2 b 3)) @@ -37,8 +37,8 @@ (deftest defmacro.2 (progn (assert (eq (defmacro defmacro.2-macro (x y) - (return-from defmacro.2-macro `(cons ,x ,y))) - 'defmacro.2-macro)) + (return-from defmacro.2-macro `(cons ,x ,y))) + 'defmacro.2-macro)) (assert (macro-function 'defmacro.2-macro)) (eval `(defmacro.2-macro 'a 'b))) (a . b)) @@ -63,9 +63,9 @@ (deftest defmacro.4 (let ((y :good)) (assert (eq (defmacro defmacro.4-macro (&optional (x y)) - (declare (special y)) - x) - 'defmacro.4-macro)) + (declare (special y)) + x) + 'defmacro.4-macro)) (let ((y :bad)) (declare (special y)) (values (macroexpand-1 '(defmacro.4-macro))))) @@ -74,9 +74,9 @@ (deftest defmacro.5 (progn (assert (eq (defmacro defmacro.5-macro () - (declare) (declare) "a doc string" (declare) - t) - 'defmacro.5-macro)) + (declare) (declare) "a doc string" (declare) + t) + 'defmacro.5-macro)) (eval `(defmacro.5-macro))) t) @@ -94,7 +94,7 @@ (defmacro defmacro.7-macro (arg1 (&whole w arg2)) `(list ',w ',arg1 ',arg2)) (eval `(defmacro.7-macro x (y)))) - ((y) x y)) + ((y) x y)) ;;; keyword parameters (deftest defmacro.8 @@ -102,9 +102,9 @@ (defmacro defmacro.8-macro (&key foo bar) `(list ',foo ',bar)) (mapcar #'eval '((defmacro.8-macro :foo x) - (defmacro.8-macro :bar y) - (defmacro.8-macro :bar a :foo b) - (defmacro.8-macro :bar a :foo b :bar c)))) + (defmacro.8-macro :bar y) + (defmacro.8-macro :bar a :foo b) + (defmacro.8-macro :bar a :foo b :bar c)))) ((x nil) (nil y) (b a) (b a))) ;;; keyword parameters with default value @@ -113,11 +113,11 @@ (defmacro defmacro.9-macro (&key (foo 1) (bar 2)) `(list ',foo ',bar)) (mapcar #'eval '((defmacro.9-macro :foo x) - (defmacro.9-macro :bar y) - (defmacro.9-macro :foo nil) - (defmacro.9-macro :bar nil) - (defmacro.9-macro :bar a :foo b) - (defmacro.9-macro :bar a :foo b :bar c)))) + (defmacro.9-macro :bar y) + (defmacro.9-macro :foo nil) + (defmacro.9-macro :bar nil) + (defmacro.9-macro :bar a :foo b) + (defmacro.9-macro :bar a :foo b :bar c)))) ((x 2) (1 y) (nil 2) (1 nil) (b a) (b a))) ;;; keyword parameters with supplied-p parameter @@ -126,14 +126,14 @@ (defmacro defmacro.10-macro (&key (foo 1 foo-p) (bar 2 bar-p)) `(list ',foo ,(notnot foo-p) ',bar ,(notnot bar-p))) (mapcar #'eval '((defmacro.10-macro) - (defmacro.10-macro :foo x) - (defmacro.10-macro :bar y) - (defmacro.10-macro :foo nil) - (defmacro.10-macro :bar nil) - (defmacro.10-macro :foo x :bar y) - (defmacro.10-macro :bar y :foo x) - (defmacro.10-macro :bar a :bar b) - (defmacro.10-macro :foo a :foo b)))) + (defmacro.10-macro :foo x) + (defmacro.10-macro :bar y) + (defmacro.10-macro :foo nil) + (defmacro.10-macro :bar nil) + (defmacro.10-macro :foo x :bar y) + (defmacro.10-macro :bar y :foo x) + (defmacro.10-macro :bar a :bar b) + (defmacro.10-macro :foo a :foo b)))) ((1 nil 2 nil) (x t 2 nil) (1 nil y t) (nil t 2 nil) (1 nil nil t) (x t y t) (x t y t) (1 nil a t) (a t 2 nil))) @@ -144,10 +144,10 @@ (progn (defmacro defmacro.11-macro ((&key foo bar)) `(list ',foo ',bar)) (mapcar #'eval '((defmacro.11-macro nil) - (defmacro.11-macro (:foo x)) - (defmacro.11-macro (:bar y)) - (defmacro.11-macro (:foo x :bar y :foo z)) - (defmacro.11-macro (:bar y :bar z :foo x))))) + (defmacro.11-macro (:foo x)) + (defmacro.11-macro (:bar y)) + (defmacro.11-macro (:foo x :bar y :foo z)) + (defmacro.11-macro (:bar y :bar z :foo x))))) ((nil nil) (x nil) (nil y) (x y) (x y))) ;;; key arguments in destructuring and defaults @@ -155,15 +155,15 @@ (deftest defmacro.12 (progn (let ((foo-default 1) - (bar-default 2)) + (bar-default 2)) (defmacro defmacro.12-macro ((&key (foo foo-default) - (bar bar-default))) - `(list ',foo ',bar))) + (bar bar-default))) + `(list ',foo ',bar))) (mapcar #'eval '((defmacro.12-macro nil) - (defmacro.12-macro (:foo x)) - (defmacro.12-macro (:bar y)) - (defmacro.12-macro (:foo x :bar y :foo z)) - (defmacro.12-macro (:bar y :bar z :foo x))))) + (defmacro.12-macro (:foo x)) + (defmacro.12-macro (:bar y)) + (defmacro.12-macro (:foo x :bar y :foo z)) + (defmacro.12-macro (:bar y :bar z :foo x))))) ((1 2) (x 2) (1 y) (x y) (x y))) ;;; key arguments in destructuring and supplied-p parameter @@ -171,17 +171,17 @@ (deftest defmacro.13 (progn (let ((foo-default 1) - (bar-default 2)) + (bar-default 2)) (defmacro defmacro.13-macro ((&key (foo foo-default foo-p) - (bar bar-default bar-p))) - `(list ',foo ,(notnot foo-p) ',bar ,(notnot bar-p)))) + (bar bar-default bar-p))) + `(list ',foo ,(notnot foo-p) ',bar ,(notnot bar-p)))) (mapcar #'eval '((defmacro.13-macro nil) - (defmacro.13-macro (:foo x)) - (defmacro.13-macro (:bar y)) - (defmacro.13-macro (:foo nil :bar nil :foo 4 :bar 14)) - (defmacro.13-macro (:foo 1 :bar 2)) - (defmacro.13-macro (:foo x :bar y :foo z)) - (defmacro.13-macro (:bar y :bar z :foo x))))) + (defmacro.13-macro (:foo x)) + (defmacro.13-macro (:bar y)) + (defmacro.13-macro (:foo nil :bar nil :foo 4 :bar 14)) + (defmacro.13-macro (:foo 1 :bar 2)) + (defmacro.13-macro (:foo x :bar y :foo z)) + (defmacro.13-macro (:bar y :bar z :foo x))))) ((1 nil 2 nil) (x t 2 nil) (1 nil y t) (nil t nil t) (1 t 2 t) (x t y t) (x t y t))) @@ -192,8 +192,8 @@ (defmacro defmacro.14-macro (foo &rest bar) `(list ',foo ',bar)) (mapcar #'eval '((defmacro.14-macro x) - (defmacro.14-macro x y) - (defmacro.14-macro x y z)))) + (defmacro.14-macro x y) + (defmacro.14-macro x y z)))) ((x nil) (x (y)) (x (y z)))) ;;; rest parameter with destructuring @@ -210,8 +210,8 @@ (defmacro defmacro.16-macro (&whole w foo &rest bar) `(list ',w ',foo ',bar)) (mapcar #'eval '((defmacro.16-macro x) - (defmacro.16-macro x y) - (defmacro.16-macro x y z)))) + (defmacro.16-macro x y) + (defmacro.16-macro x y z)))) (((defmacro.16-macro x) x nil) ((defmacro.16-macro x y) x (y)) ((defmacro.16-macro x y z) x (y z)))) @@ -223,7 +223,7 @@ `(quote ,(macroexpand x env))) (eval `(macrolet ((%m () :good)) - (defmacro.17-macro (%m))))) + (defmacro.17-macro (%m))))) :good) (deftest defmacro.17a @@ -232,7 +232,7 @@ `(quote ,(macroexpand x env))) (eval `(macrolet ((%m () :good)) - (defmacro.17a-macro (%m))))) + (defmacro.17a-macro (%m))))) :good) ;;; &optional with supplied-p parameter @@ -242,8 +242,8 @@ (defmacro defmacro.18-macro (x &optional (y 'a y-p) (z 'b z-p)) `(list ',x ',y ',y-p ',z ',z-p)) (mapcar #'eval '((defmacro.18-macro p) - (defmacro.18-macro p q) - (defmacro.18-macro p q r)))) + (defmacro.18-macro p q) + (defmacro.18-macro p q r)))) ((p a nil b nil) (p q t b nil) (p q t r t))) @@ -254,7 +254,7 @@ (defmacro defmacro.19-macro (&optional ((x . y) '(a . b))) `(list ',x ',y)) (mapcar #'eval '((defmacro.19-macro) - (defmacro.19-macro (c d))))) + (defmacro.19-macro (c d))))) ((a b) (c (d)))) ;;; Allow other keys @@ -264,17 +264,17 @@ (defmacro defmacro.20-macro (&key x y z &allow-other-keys) `(list ',x ',y ',z)) (mapcar #'eval '((defmacro.20-macro) - (defmacro.20-macro :x a) - (defmacro.20-macro :y b) - (defmacro.20-macro :z c) - (defmacro.20-macro :x a :y b) - (defmacro.20-macro :z c :y b) - (defmacro.20-macro :z c :x a) - (defmacro.20-macro :z c :x a :y b) - (defmacro.20-macro nil nil) - (defmacro.20-macro :allow-other-keys nil) - (defmacro.20-macro :allow-other-keys nil :foo bar) - (defmacro.20-macro :z c :z nil :x a :abc 0 :y b :x t)))) + (defmacro.20-macro :x a) + (defmacro.20-macro :y b) + (defmacro.20-macro :z c) + (defmacro.20-macro :x a :y b) + (defmacro.20-macro :z c :y b) + (defmacro.20-macro :z c :x a) + (defmacro.20-macro :z c :x a :y b) + (defmacro.20-macro nil nil) + (defmacro.20-macro :allow-other-keys nil) + (defmacro.20-macro :allow-other-keys nil :foo bar) + (defmacro.20-macro :z c :z nil :x a :abc 0 :y b :x t)))) ((nil nil nil) (a nil nil) (nil b nil) @@ -293,15 +293,15 @@ (defmacro defmacro.21-macro (&key x y z) `(list ',x ',y ',z)) (mapcar #'eval '((defmacro.21-macro) - (defmacro.21-macro :x a) - (defmacro.21-macro :y b) - (defmacro.21-macro :z c) - (defmacro.21-macro :x a :y b) - (defmacro.21-macro :z c :y b) - (defmacro.21-macro :z c :x a) - (defmacro.21-macro :z c :x a :y b) - (defmacro.21-macro :allow-other-keys nil) - (defmacro.21-macro :allow-other-keys t :foo bar)))) + (defmacro.21-macro :x a) + (defmacro.21-macro :y b) + (defmacro.21-macro :z c) + (defmacro.21-macro :x a :y b) + (defmacro.21-macro :z c :y b) + (defmacro.21-macro :z c :x a) + (defmacro.21-macro :z c :x a :y b) + (defmacro.21-macro :allow-other-keys nil) + (defmacro.21-macro :allow-other-keys t :foo bar)))) ((nil nil nil) (a nil nil) (nil b nil) @@ -313,6 +313,6 @@ (nil nil nil) (nil nil nil))) - - - \ No newline at end of file + + + diff --git a/ansi-tests/defmethod.lsp b/ansi-tests/defmethod.lsp index d4d5e3c9..6d2e3178 100644 --- a/ansi-tests/defmethod.lsp +++ b/ansi-tests/defmethod.lsp @@ -15,8 +15,8 @@ (deftest defmethod.2 (let* ((sym (gensym)) - (method - (eval `(defmethod ,sym ((x integer)) (list x))))) + (method + (eval `(defmethod ,sym ((x integer)) (list x))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) @@ -25,8 +25,8 @@ (deftest defmethod.3 (let* ((sym (gensym)) - (method - (eval `(let ((x 0)) (defmethod ,sym ((x (eql (incf x)))) (list x)))))) + (method + (eval `(let ((x 0)) (defmethod ,sym ((x (eql (incf x)))) (list x)))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) @@ -36,8 +36,8 @@ (deftest defmethod.4 (let* ((sym (gensym)) - (method - (eval `(defmethod (setf ,sym) ((x t) (y cons)) (setf (car y) x))))) + (method + (eval `(defmethod (setf ,sym) ((x t) (y cons)) (setf (car y) x))))) (values (typep* method 'standard-method) (fboundp sym) @@ -47,8 +47,8 @@ (deftest defmethod.5 (let* ((sym (gensym)) - (method - (eval `(defmethod ,sym ((x integer)) (return-from ,sym (list x)))))) + (method + (eval `(defmethod ,sym ((x integer)) (return-from ,sym (list x)))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) @@ -57,8 +57,8 @@ (deftest defmethod.6 (let* ((sym (gensym)) - (method - (eval `(defmethod (setf ,sym) ((x t) (y cons)) (return-from ,sym (setf (car y) x)))))) + (method + (eval `(defmethod (setf ,sym) ((x t) (y cons)) (return-from ,sym (setf (car y) x)))))) (values (typep* method 'standard-method) (fboundp sym) @@ -68,8 +68,8 @@ (deftest defmethod.7 (let* ((sym (gensym)) - (method - (eval `(defmethod ,sym ((x integer) &aux (y (list x))) y)))) + (method + (eval `(defmethod ,sym ((x integer) &aux (y (list x))) y)))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) @@ -78,7 +78,7 @@ (deftest defmethod.8 (let* ((sym (gensym)) - (method (eval `(defmethod ,sym ((x integer) &key z) (list x z))))) + (method (eval `(defmethod ,sym ((x integer) &key z) (list x z))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) @@ -92,7 +92,7 @@ (deftest defmethod.9 (let* ((sym (gensym)) - (method (eval `(defmethod ,sym ((x integer) &key (z :missing)) (list x z))))) + (method (eval `(defmethod ,sym ((x integer) &key (z :missing)) (list x z))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) @@ -104,7 +104,7 @@ (deftest defmethod.10 (let* ((sym (gensym)) - (method (eval `(defmethod ,sym ((x integer) &key (z :missing z-p)) (list x z (notnot z-p)))))) + (method (eval `(defmethod ,sym ((x integer) &key (z :missing z-p)) (list x z (notnot z-p)))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) @@ -116,7 +116,7 @@ (deftest defmethod.11 (let* ((sym (gensym)) - (method (eval `(defmethod ,sym ((x integer) &rest z) (list x z))))) + (method (eval `(defmethod ,sym ((x integer) &rest z) (list x z))))) (values (typep* method 'standard-method) (typep* (fdefinition sym) 'standard-generic-function) @@ -207,24 +207,24 @@ (let ((sym (gensym))) (eval `(locally (declare (optimize safety)) (defmethod ,sym ((x t)) x))) (values (eval `(signals-error (,sym) program-error)) - (eval `(signals-error (,sym 1 2) program-error)))) + (eval `(signals-error (,sym 1 2) program-error)))) t t) (deftest defmethod.error.14 (let ((sym (gensym))) (eval `(locally (declare (optimize safety)) (defmethod ,sym ((x t) &key) x))) (values (eval `(signals-error (,sym) program-error)) - (eval `(signals-error (,sym 1 2) program-error)) - (eval `(signals-error (,sym 1 :bogus t) program-error)) - (eval `(signals-error (,sym 1 :allow-other-keys nil :allow-other-keys t :bogus t) program-error)))) + (eval `(signals-error (,sym 1 2) program-error)) + (eval `(signals-error (,sym 1 :bogus t) program-error)) + (eval `(signals-error (,sym 1 :allow-other-keys nil :allow-other-keys t :bogus t) program-error)))) t t t t) (deftest defmethod.error.15 (let ((sym (gensym))) (eval `(locally (declare (optimize safety)) (defmethod ,sym ((x t) &key y) x))) (values (eval `(signals-error (,sym 1 :bogus t) program-error)) - (eval `(signals-error (,sym 1 :y) program-error)) - (eval `(signals-error (,sym 1 3 nil) program-error)))) + (eval `(signals-error (,sym 1 :y) program-error)) + (eval `(signals-error (,sym 1 3 nil) program-error)))) t t t) diff --git a/ansi-tests/defpackage.lsp b/ansi-tests/defpackage.lsp index b199ebdb..b067d5f8 100644 --- a/ansi-tests/defpackage.lsp +++ b/ansi-tests/defpackage.lsp @@ -23,15 +23,15 @@ (progn (safely-delete-package "H") (let ((p (ignore-errors (eval `(defpackage ,n))))) - (and - (packagep p) - (equal (package-name p) "H") - ;; (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (null (documentation p t)) - ))))) + (and + (packagep p) + (equal (package-name p) "H") + ;; (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (null (documentation p t)) + ))))) 0) ;; Test :nicknames option @@ -43,20 +43,20 @@ (not (ignore-errors (progn - (safely-delete-package "H") - (let ((p (ignore-errors - (eval `(defpackage "H" (:nicknames ,n "J")))))) - (and - (packagep p) - (equal (package-name p) "H") - ;; (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (sort (copy-list (package-nicknames p)) - #'string<) - '("I" "J")) - (equal (package-shadowing-symbols p) nil) - (null (documentation p t)) - )))))) + (safely-delete-package "H") + (let ((p (ignore-errors + (eval `(defpackage "H" (:nicknames ,n "J")))))) + (and + (packagep p) + (equal (package-name p) "H") + ;; (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (sort (copy-list (package-nicknames p)) + #'string<) + '("I" "J")) + (equal (package-shadowing-symbols p) nil) + (null (documentation p t)) + )))))) 0) ;; Test defpackage with documentation option @@ -66,20 +66,20 @@ (safely-delete-package "H") (ignore-errors (let ((p (eval '(defpackage "H" (:documentation "This is a doc string"))))) - (and - (packagep p) - (equal (package-name p) "H") - ;; (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - ;; The spec says implementations are free to discard - ;; documentations, so this next form was wrong. - ;; Instead, we'll just computation DOCUMENTATION - ;; and throw away the value. - ;; (equal (documentation p t) "This is a doc string") - (progn (documentation p t) t) - )))) + (and + (packagep p) + (equal (package-name p) "H") + ;; (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + ;; The spec says implementations are free to discard + ;; documentations, so this next form was wrong. + ;; Instead, we'll just computation DOCUMENTATION + ;; and throw away the value. + ;; (equal (documentation p t) "This is a doc string") + (progn (documentation p t) t) + )))) t) ;; Check use argument @@ -91,20 +91,20 @@ for n in '("A" :|A| #\A) count (not (ignore-errors - (progn - (safely-delete-package "H") - (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n)))))) - (and - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) (list (find-package "A"))) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (eql (num-symbols-in-package p) - (num-external-symbols-in-package "A")) - (equal (documentation p t) nil) - ))))))) + (progn + (safely-delete-package "H") + (let ((p (ignore-errors (eval `(defpackage "H" (:use ,n)))))) + (and + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) (list (find-package "A"))) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) + (num-external-symbols-in-package "A")) + (equal (documentation p t) nil) + ))))))) 0) ;; Test defpackage shadow option, and null use @@ -112,26 +112,26 @@ (let () (safely-delete-package "H") (ignore-errors - (let ((p (ignore-errors (eval `(defpackage "H" (:use) - (:shadow "foo")))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (eql (num-symbols-in-package p) 1) - (multiple-value-bind* (sym access) - (find-symbol "foo" p) - (and (eqt access :internal) - (equal (symbol-name sym) "foo") - (equal (symbol-package sym) p) - (equal (package-shadowing-symbols p) - (list sym)))) - (equal (documentation p t) nil) - ))))) + (let ((p (ignore-errors (eval `(defpackage "H" (:use) + (:shadow "foo")))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (eql (num-symbols-in-package p) 1) + (multiple-value-bind* (sym access) + (find-symbol "foo" p) + (and (eqt access :internal) + (equal (symbol-name sym) "foo") + (equal (symbol-package sym) p) + (equal (package-shadowing-symbols p) + (list sym)))) + (equal (documentation p t) nil) + ))))) (t t t t t t t t)) ;; Test defpackage shadow and null use, with several ways @@ -142,27 +142,27 @@ collect (ignore-errors (safely-delete-package "H") - (let ((p (ignore-errors (eval `(defpackage "H" - (:use) - (:shadow ,s)))))) + (let ((p (ignore-errors (eval `(defpackage "H" + (:use) + (:shadow ,s)))))) (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (eql (num-symbols-in-package p) 1) - (multiple-value-bind* (sym access) - (find-symbol "f" p) - (and (eqt access :internal) - (equal (symbol-name sym) "f") - (equal (symbol-package sym) p) - (equal (package-shadowing-symbols p) - (list sym)))) - (equal (documentation p t) nil) - ))))) + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (eql (num-symbols-in-package p) 1) + (multiple-value-bind* (sym access) + (find-symbol "f" p) + (and (eqt access :internal) + (equal (symbol-name sym) "f") + (equal (symbol-package sym) p) + (equal (package-shadowing-symbols p) + (list sym)))) + (equal (documentation p t) nil) + ))))) ((t t t t t t t t) (t t t t t t t t))) @@ -184,30 +184,30 @@ for n in '("A" :|A| #\A) collect (ignore-errors - (safely-delete-package "H") - (let ((p (ignore-errors - (eval - `(defpackage "H" - (:use) - (:shadowing-import-from "G" ,n)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (eql (num-symbols-in-package p) 1) - (multiple-value-bind* (sym access) - (find-symbol "A" p) - (and (eqt access :internal) - (equal (symbol-name sym) "A") - (equal (symbol-package sym) pg) - (equal (package-shadowing-symbols p) - (list sym)))) - (equal (documentation p t) nil) - ))))))) + (safely-delete-package "H") + (let ((p (ignore-errors + (eval + `(defpackage "H" + (:use) + (:shadowing-import-from "G" ,n)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (eql (num-symbols-in-package p) 1) + (multiple-value-bind* (sym access) + (find-symbol "A" p) + (and (eqt access :internal) + (equal (symbol-name sym) "A") + (equal (symbol-package sym) pg) + (equal (package-shadowing-symbols p) + (list sym)))) + (equal (documentation p t) nil) + ))))))) ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t))) @@ -221,40 +221,40 @@ (safely-delete-package "H") (safely-delete-package "G") (let ((pg (eval '(defpackage "G" (:use) (:intern "A" "B" "C"))))) - (loop - for pn in '("G" #:|G| #\G) - collect - (loop - for n in '("B" #:|B| #\B) - collect - (ignore-errors - (safely-delete-package "H") - (let ((p (ignore-errors - (eval `(defpackage - "H" (:use) - (:import-from ,pn ,n "A")))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (eql (num-symbols-in-package p) 2) - (multiple-value-bind* (sym access) - (find-symbol "A" p) - (and (eqt access :internal) - (equal (symbol-name sym) "A") - (equal (symbol-package sym) pg))) - (multiple-value-bind* (sym access) - (find-symbol "B" p) - (and (eqt access :internal) - (equal (symbol-name sym) "B") - (equal (symbol-package sym) pg))) - (equal (documentation p t) nil) - )))))))) + (loop + for pn in '("G" #:|G| #\G) + collect + (loop + for n in '("B" #:|B| #\B) + collect + (ignore-errors + (safely-delete-package "H") + (let ((p (ignore-errors + (eval `(defpackage + "H" (:use) + (:import-from ,pn ,n "A")))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) 2) + (multiple-value-bind* (sym access) + (find-symbol "A" p) + (and (eqt access :internal) + (equal (symbol-name sym) "A") + (equal (symbol-package sym) pg))) + (multiple-value-bind* (sym access) + (find-symbol "B" p) + (and (eqt access :internal) + (equal (symbol-name sym) "B") + (equal (symbol-package sym) pg))) + (equal (documentation p t) nil) + )))))))) (((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)) ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)) ((t t t t t t t t t t) (t t t t t t t t t t) (t t t t t t t t t t)))) @@ -269,30 +269,30 @@ (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors - (eval `(defpackage - "H" - (:export "Q" ,n "R") (:use)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (eql (num-symbols-in-package p) 3) - (loop - for s in '("Q" "Z" "R") do - (unless - (multiple-value-bind* (sym access) - (find-symbol s p) - (and (eqt access :external) - (equal (symbol-name sym) s) - (equal (symbol-package sym) p))) - (return nil)) - finally (return t)) - )))))) + (eval `(defpackage + "H" + (:export "Q" ,n "R") (:use)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) 3) + (loop + for s in '("Q" "Z" "R") do + (unless + (multiple-value-bind* (sym access) + (find-symbol s p) + (and (eqt access :external) + (equal (symbol-name sym) s) + (equal (symbol-package sym) p))) + (return nil)) + finally (return t)) + )))))) ((t t t t t t t t)(t t t t t t t t)(t t t t t t t t))) ;; Test defpackage with the intern option @@ -305,30 +305,30 @@ (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors - (eval `(defpackage - "H" - (:intern "Q" ,n "R") (:use)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (eql (num-symbols-in-package p) 3) - (loop - for s in '("Q" "Z" "R") do - (unless - (multiple-value-bind* (sym access) - (find-symbol s p) - (and (eqt access :internal) - (equal (symbol-name sym) s) - (equal (symbol-package sym) p))) - (return nil)) - finally (return t)) - )))))) + (eval `(defpackage + "H" + (:intern "Q" ,n "R") (:use)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (eql (num-symbols-in-package p) 3) + (loop + for s in '("Q" "Z" "R") do + (unless + (multiple-value-bind* (sym access) + (find-symbol s p) + (and (eqt access :internal) + (equal (symbol-name sym) s) + (equal (symbol-package sym) p))) + (return nil)) + finally (return t)) + )))))) ((t t t t t t t t) (t t t t t t t t) (t t t t t t t t))) ;; Test defpackage with size @@ -338,17 +338,17 @@ (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors - (eval '(defpackage "H" (:use) (:size 0)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (zerop (num-symbols-in-package p))))))) + (eval '(defpackage "H" (:use) (:size 0)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (zerop (num-symbols-in-package p))))))) (t t t t t t t)) (deftest defpackage.12 @@ -356,17 +356,17 @@ (ignore-errors (safely-delete-package "H") (let ((p (ignore-errors - (eval '(defpackage "H" (:use) (:size 10000)))))) - (mapcar - #'notnot - (list - (packagep p) - (equal (package-name p) "H") - (equal (package-use-list p) nil) - (equal (package-used-by-list p) nil) - (equal (package-nicknames p) nil) - (equal (package-shadowing-symbols p) nil) - (zerop (num-symbols-in-package p))))))) + (eval '(defpackage "H" (:use) (:size 10000)))))) + (mapcar + #'notnot + (list + (packagep p) + (equal (package-name p) "H") + (equal (package-use-list p) nil) + (equal (package-used-by-list p) nil) + (equal (package-nicknames p) nil) + (equal (package-shadowing-symbols p) nil) + (zerop (num-symbols-in-package p))))))) (t t t t t t t)) ;; defpackage error handling @@ -510,7 +510,7 @@ (eval '(defpackage "G" (:use))) (handle-non-abort-restart (eval '(defpackage "H" (:shadowing-import-from - "G" "NOT-THERE"))))) + "G" "NOT-THERE"))))) success) ;; :import-from signals a correctable package-error if a symbol with @@ -531,104 +531,104 @@ (let () (ignore-errors (flet - ((%do-it% - (args) - (safely-delete-package "H") - (safely-delete-package "G1") - (safely-delete-package "G2") - (safely-delete-package "G3") - (let ((pg1 - (progn - (format t "Making G1...~%") - (eval '(defpackage "G1" - (:use) - (:export "A" "B" "C") - (:intern "D" "E" "F"))))) - (pg2 - (progn - (format t "Making G2...~%") - (eval '(defpackage "G2" - (:use) - (:export "A" "D" "G") - (:intern "E" "H" "I"))))) - (pg3 - (progn - (format t "Making G3...~%") - (eval '(defpackage "G3" - (:use) - (:export "J" "K" "L") - (:intern "M" "N" "O")))))) - (let ((p (eval (list* 'defpackage "H" (copy-tree args))))) - (prog - () - (unless (packagep p) (return 1)) - (unless (equal (package-name p) "H") (return 2)) - (unless (equal (package-name pg1) "G1") (return 3)) - (unless (equal (package-name pg2) "G2") (return 4)) - (unless (equal (package-name pg3) "G3") (return 5)) - (unless - (equal (sort (copy-list (package-nicknames p)) #'string<) - '("H1" "H2")) - (return 6)) - (unless - (or - (equal (package-use-list p) (list pg1 pg2)) - (equal (package-use-list p) (list pg2 pg1))) - (return 7)) - (unless (equal (package-used-by-list pg1) (list p)) - (return 8)) - (unless (equal (package-used-by-list pg2) (list p)) - (return 9)) - (when (package-used-by-list pg3) (return 10)) - (unless (equal (sort (mapcar #'symbol-name - (package-shadowing-symbols p)) - #'string<) - '("A" "B")) - (return 10)) - (let ((num 11)) - (unless - (every - #'(lambda (str acc pkg) - (multiple-value-bind* - (sym access) - (find-symbol str p) - (or - (and (or (not acc) (equal (symbol-name sym) str)) - (or (not acc) (equal (symbol-package sym) pkg)) - (equal access acc) - (incf num)) - (progn - (format t - "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%" - str acc pkg sym access) - nil)))) - (list "A" "B" "C" "D" "E" "F" "G" - "H" "I" "J" "K" "L" "M" "N" "O") - (list :internal :internal - :external :inherited - nil nil - :inherited :internal - nil nil - nil :external - nil nil - :internal) - (list pg2 p pg1 pg2 nil nil - pg2 p nil nil nil pg3 - nil nil pg3)) - (return num))) - (return 'success)))))) - (let ((args '((:nicknames "H1" "H2") - (:use "G1" "G2") - (:shadow "B") - (:shadowing-import-from "G2" "A") - (:import-from "G3" "L" "O") - (:intern "D" "H") - (:export "L" "C") - (:size 20) - (:documentation "A test package")))) - (list (%do-it% args) - (%do-it% (reverse args))))))) + ((%do-it% + (args) + (safely-delete-package "H") + (safely-delete-package "G1") + (safely-delete-package "G2") + (safely-delete-package "G3") + (let ((pg1 + (progn + (format t "Making G1...~%") + (eval '(defpackage "G1" + (:use) + (:export "A" "B" "C") + (:intern "D" "E" "F"))))) + (pg2 + (progn + (format t "Making G2...~%") + (eval '(defpackage "G2" + (:use) + (:export "A" "D" "G") + (:intern "E" "H" "I"))))) + (pg3 + (progn + (format t "Making G3...~%") + (eval '(defpackage "G3" + (:use) + (:export "J" "K" "L") + (:intern "M" "N" "O")))))) + (let ((p (eval (list* 'defpackage "H" (copy-tree args))))) + (prog + () + (unless (packagep p) (return 1)) + (unless (equal (package-name p) "H") (return 2)) + (unless (equal (package-name pg1) "G1") (return 3)) + (unless (equal (package-name pg2) "G2") (return 4)) + (unless (equal (package-name pg3) "G3") (return 5)) + (unless + (equal (sort (copy-list (package-nicknames p)) #'string<) + '("H1" "H2")) + (return 6)) + (unless + (or + (equal (package-use-list p) (list pg1 pg2)) + (equal (package-use-list p) (list pg2 pg1))) + (return 7)) + (unless (equal (package-used-by-list pg1) (list p)) + (return 8)) + (unless (equal (package-used-by-list pg2) (list p)) + (return 9)) + (when (package-used-by-list pg3) (return 10)) + (unless (equal (sort (mapcar #'symbol-name + (package-shadowing-symbols p)) + #'string<) + '("A" "B")) + (return 10)) + (let ((num 11)) + (unless + (every + #'(lambda (str acc pkg) + (multiple-value-bind* + (sym access) + (find-symbol str p) + (or + (and (or (not acc) (equal (symbol-name sym) str)) + (or (not acc) (equal (symbol-package sym) pkg)) + (equal access acc) + (incf num)) + (progn + (format t + "Failed on str = ~S, acc = ~S, pkg = ~S, sym = ~S, access = ~S~%" + str acc pkg sym access) + nil)))) + (list "A" "B" "C" "D" "E" "F" "G" + "H" "I" "J" "K" "L" "M" "N" "O") + (list :internal :internal + :external :inherited + nil nil + :inherited :internal + nil nil + nil :external + nil nil + :internal) + (list pg2 p pg1 pg2 nil nil + pg2 p nil nil nil pg3 + nil nil pg3)) + (return num))) + (return 'success)))))) + (let ((args '((:nicknames "H1" "H2") + (:use "G1" "G2") + (:shadow "B") + (:shadowing-import-from "G2" "A") + (:import-from "G3" "L" "O") + (:intern "D" "H") + (:export "L" "C") + (:size 20) + (:documentation "A test package")))) + (list (%do-it% args) + (%do-it% (reverse args))))))) (success success)) (def-macro-test defpackage.error.1 - (defpackage :nonexistent-package (:use))) \ No newline at end of file + (defpackage :nonexistent-package (:use))) diff --git a/ansi-tests/defparameter.lsp b/ansi-tests/defparameter.lsp index 9caafa32..729f3a6b 100644 --- a/ansi-tests/defparameter.lsp +++ b/ansi-tests/defparameter.lsp @@ -54,33 +54,33 @@ ;;; (deftest defparameter.error.1 ;;; (signals-error (defparameter) program-error) ;;; t) -;;; +;;; ;;; (deftest defparameter.error.2 ;;; (signals-error (defparameter *ignored-defparameter-name*) ;;; program-error) ;;; t) -;;; +;;; ;;; (deftest defparameter.error.3 ;;; (signals-error (defparameter *ignored-defparameter-name* nil -;;; "documentation" -;;; "illegal extra argument") +;;; "documentation" +;;; "illegal extra argument") ;;; program-error) ;;; t) (deftest defparameter.error.1 (signals-error (funcall (macro-function 'defparameter)) - program-error) + program-error) t) (deftest defparameter.error.2 (signals-error (funcall (macro-function 'defparameter) - '(defparameter *nonexistent-variable* nil)) - program-error) + '(defparameter *nonexistent-variable* nil)) + program-error) t) (deftest defparameter.error.3 (signals-error (funcall (macro-function 'defparameter) - '(defparameter *nonexistent-variable* nil) - nil nil) - program-error) + '(defparameter *nonexistent-variable* nil) + nil nil) + program-error) t) diff --git a/ansi-tests/defsetf.lsp b/ansi-tests/defsetf.lsp index a026beff..6d865c9b 100644 --- a/ansi-tests/defsetf.lsp +++ b/ansi-tests/defsetf.lsp @@ -8,7 +8,7 @@ ;;; Need to add non-error tests (def-macro-test defsetf.error.1 (defsetf nonexistent-access-fn - nonexistent-update-fn)) + nonexistent-update-fn)) ;;; Short form @@ -21,15 +21,15 @@ (deftest defsetf.1 (progn (let ((vals (multiple-value-list - (defsetf defsetf.1-accessor defsetf.1-accessor-settor)))) + (defsetf defsetf.1-accessor defsetf.1-accessor-settor)))) (assert (equal vals '(defsetf.1-accessor)) - () - "Return values are ~A~%" vals)) + () + "Return values are ~A~%" vals)) (eval '(let ((x (list 1 2 3))) - (values - (setf (defsetf.1-accessor x) 4) - x)))) + (values + (setf (defsetf.1-accessor x) 4) + x)))) 4 (1 4 3)) @@ -94,7 +94,7 @@ (defparameter *defsetf.4-vals* (multiple-value-list - (defsetf defsetf.4-accessor (n seq) (val) + (defsetf defsetf.4-accessor (n seq) (val) (declare) "Doc string for defsetf.4-accessor setf" `(setf (elt ,seq ,n) ,val)))) @@ -110,15 +110,15 @@ (deftest defsetf.4c (let ((x (list 1 2 3 4)) - (i 0) - (j nil) - (k nil)) + (i 0) + (j nil) + (k nil)) (values (setf (defsetf.4-accessor - (progn (setf j (incf i)) - 2) - (progn (setf k (incf i)) x)) - (progn (incf i) 'a)) + (progn (setf j (incf i)) + 2) + (progn (setf k (incf i)) x)) + (progn (incf i) 'a)) x i j k)) a diff --git a/ansi-tests/deftype.lsp b/ansi-tests/deftype.lsp index 66c29271..acc218ba 100644 --- a/ansi-tests/deftype.lsp +++ b/ansi-tests/deftype.lsp @@ -33,7 +33,7 @@ (deftest deftype.6 (notnot-mv (typep (make-array '(3 5 6) :element-type '(unsigned-byte 8)) - '(even-array (unsigned-byte 8)))) + '(even-array (unsigned-byte 8)))) t) (deftest deftype.7 @@ -50,7 +50,7 @@ (deftest deftype.9 (let* ((sym (gensym)) - (form `(deftype ,sym (&optional x) `(integer 0 ,x)))) + (form `(deftype ,sym (&optional x) `(integer 0 ,x)))) (values (eqlt (eval form) sym) (multiple-value-list (subtypep* `(,sym) 'unsigned-byte)) @@ -58,9 +58,9 @@ (multiple-value-list (subtypep* `(,sym 4) '(integer 0 4))) (multiple-value-list (subtypep* '(integer 0 4) `(,sym 4))) (loop for x in '(a -1 0 1 2 3 4 5 b) - collect (notnot (typep x sym))) + collect (notnot (typep x sym))) (loop for x in '(a -1 0 1 2 3 4 5 b) - collect (notnot (typep x `(,sym 4)))) + collect (notnot (typep x `(,sym 4)))) )) t (t t) (t t) (t t) (t t) (nil nil t t t t t t nil) @@ -68,7 +68,7 @@ (deftest deftype.10 (let* ((sym (gensym)) - (form `(deftype ,sym (&optional (x 14)) `(integer 0 ,x)))) + (form `(deftype ,sym (&optional (x 14)) `(integer 0 ,x)))) (values (eqlt (eval form) sym) (multiple-value-list (subtypep* `(,sym) '(integer 0 14))) @@ -76,9 +76,9 @@ (multiple-value-list (subtypep* `(,sym 4) '(integer 0 4))) (multiple-value-list (subtypep* '(integer 0 4) `(,sym 4))) (loop for x in '(a -1 0 1 2 3 4 5 14 15 b) - collect (notnot (typep x sym))) + collect (notnot (typep x sym))) (loop for x in '(a -1 0 1 2 3 4 5 14 15 b) - collect (notnot (typep x `(,sym 4)))) + collect (notnot (typep x `(,sym 4)))) )) t (t t) (t t) (t t) (t t) (nil nil t t t t t t t nil nil) @@ -86,7 +86,7 @@ (deftest deftype.11 (let* ((sym (gensym)) - (form `(deftype ,sym (&key foo bar) `(integer ,foo ,bar)))) + (form `(deftype ,sym (&key foo bar) `(integer ,foo ,bar)))) (values (eqlt (eval form) sym) (multiple-value-list (subtypep* `(,sym) 'integer)) @@ -116,7 +116,7 @@ (deftest deftype.12 (let* ((sym (gensym)) - (form `(deftype ,sym (&key foo bar &allow-other-keys) `(integer ,foo ,bar)))) + (form `(deftype ,sym (&key foo bar &allow-other-keys) `(integer ,foo ,bar)))) (values (eqlt (eval form) sym) (multiple-value-list (subtypep* `(,sym :xyz t) 'integer)) @@ -134,7 +134,7 @@ (deftest deftype.13 (let* ((sym (gensym)) - (form `(deftype ,sym (&rest args) (if args `(member ,@args) nil)))) + (form `(deftype ,sym (&rest args) (if args `(member ,@args) nil)))) (values (eqlt (eval form) sym) ;; (multiple-value-list (subtypep* sym nil)) @@ -157,11 +157,11 @@ #| (deftest deftype.14 (let* ((sym (gensym)) - (*f* nil) - (form `(let ((x 1)) - (declare (special *f*)) - (setf *f* #'(lambda (y) (setf x y))) - (deftype ,sym () `(integer 0 ,x))))) + (*f* nil) + (form `(let ((x 1)) + (declare (special *f*)) + (setf *f* #'(lambda (y) (setf x y))) + (deftype ,sym () `(integer 0 ,x))))) (declare (special *f*)) (values (eqlt (eval form) sym) @@ -173,10 +173,10 @@ (deftest deftype.15 (let* ((sym (gensym)) - (form `(let ((a 1)) - (deftype ,sym (&optional (x a)) - (declare (special a)) - `(integer 0 ,x))))) + (form `(let ((a 1)) + (deftype ,sym (&optional (x a)) + (declare (special a)) + `(integer 0 ,x))))) (values (eqlt (eval form) sym) (let ((a 2)) @@ -188,10 +188,10 @@ t (nil t t nil nil) (nil t t nil nil)) - + (deftest deftype.16 (let* ((sym (gensym)) - (form `(deftype ,sym () (return-from ,sym 'integer)))) + (form `(deftype ,sym () (return-from ,sym 'integer)))) (values (eqlt (eval form) sym) (subtypep* sym 'integer) @@ -200,7 +200,7 @@ (deftest deftype.17 (let* ((sym (gensym)) - (form `(deftype ,sym () (values 'integer t)))) + (form `(deftype ,sym () (values 'integer t)))) (values (eqlt (eval form) sym) (subtypep* sym 'integer) @@ -209,7 +209,7 @@ (deftest deftype.18 (let* ((sym (gensym)) - (form `(deftype ,sym ()))) + (form `(deftype ,sym ()))) (values (eqlt (eval form) sym) (subtypep* sym nil) @@ -218,32 +218,32 @@ (deftest deftype.19 (let* ((sym (gensym)) - (form `(deftype ,sym () - (declare (optimize speed safety debug compilation-speed space)) - 'integer))) + (form `(deftype ,sym () + (declare (optimize speed safety debug compilation-speed space)) + 'integer))) (values (eqlt (eval form) sym) (subtypep* sym 'integer) (subtypep* 'integer sym))) t t t) - + ;;; Error tests (deftest deftype.error.1 (signals-error (funcall (macro-function 'deftype)) - program-error) + program-error) t) (deftest deftype.error.2 (signals-error (funcall (macro-function 'deftype) - '(deftype nonexistent-type () nil)) - program-error) + '(deftype nonexistent-type () nil)) + program-error) t) (deftest deftype.error.3 (signals-error (funcall (macro-function 'deftype) - '(deftype nonexistent-type () nil) - nil nil) - program-error) + '(deftype nonexistent-type () nil) + nil nil) + program-error) t) diff --git a/ansi-tests/defun.lsp b/ansi-tests/defun.lsp index e86db616..794fca0f 100644 --- a/ansi-tests/defun.lsp +++ b/ansi-tests/defun.lsp @@ -48,8 +48,8 @@ (declare (special x)) (let ((x 2)) (defun defun-test-fun-5 (&aux (y x)) - (declare (special x)) - (values y x)) + (declare (special x)) + (values y x)) (defun-test-fun-5))) 2 1) @@ -58,8 +58,8 @@ (declare (special x)) (let ((x 2)) (defun defun-test-fun-6 (&optional (y x)) - (declare (special x)) - (values y x)) + (declare (special x)) + (values y x)) (defun-test-fun-6))) 2 1) @@ -68,8 +68,8 @@ (declare (special x)) (let ((x 2)) (defun defun-test-fun-7 (&key (y x)) - (declare (special x)) - (values y x)) + (declare (special x)) + (values y x)) (defun-test-fun-7))) 2 1) @@ -77,8 +77,8 @@ (deftest defun.8 (let* ((sym (gensym)) - (doc "DEFUN.8") - (form `(defun ,sym () ,doc nil))) + (doc "DEFUN.8") + (form `(defun ,sym () ,doc nil))) (or (documentation sym 'function) doc)) "DEFUN.8") @@ -86,20 +86,20 @@ (deftest defun.error.1 (signals-error (funcall (macro-function 'defun)) - program-error) + program-error) t) (deftest defun.error.2 (signals-error (funcall (macro-function 'defun) - '(defun nonexistent-function ())) - program-error) + '(defun nonexistent-function ())) + program-error) t) (deftest defun.error.3 (signals-error (funcall (macro-function 'defun) - '(defun nonexistent-function ()) - nil nil) - program-error) + '(defun nonexistent-function ()) + nil nil) + program-error) t) ;;; More comprehensive error handling tests of calls to @@ -108,30 +108,30 @@ (deftest defun.error.4 (let* ((name (gensym))) (loop for i below (min 100 lambda-parameters-limit) - for params = nil then (cons (gensym) params) - for args = nil then (cons nil args) - for expected = '(1 2 3) - for fn = (eval `(prog2 (proclaim '(optimize (safety 0))) - (defun ,name ,params (values ,@expected)) - (proclaim '(optimize safety)))) - when - (cond - ((not (equal (multiple-value-list (apply fn args)) expected)) - (list i :fail1)) - ((not (equal (multiple-value-list - (apply (symbol-function fn) args)) - expected)) - (list i :fail2)) - ((not (equal (multiple-value-list (eval `(,name ,@args))) - expected)) - (list i :fail3)) - ;; Error cases - ((and (> i 0) - (let ((val (eval `(signals-error (,name ,@(cdr args)) program-error)))) - (and (not (eq val t)) :fail4)))) - ((and (< i (1- call-arguments-limit)) - (let ((val (eval `(signals-error (,name nil ,@args) program-error)))) - (and (not (eq val t)) :fail5))))) - collect it)) + for params = nil then (cons (gensym) params) + for args = nil then (cons nil args) + for expected = '(1 2 3) + for fn = (eval `(prog2 (proclaim '(optimize (safety 0))) + (defun ,name ,params (values ,@expected)) + (proclaim '(optimize safety)))) + when + (cond + ((not (equal (multiple-value-list (apply fn args)) expected)) + (list i :fail1)) + ((not (equal (multiple-value-list + (apply (symbol-function fn) args)) + expected)) + (list i :fail2)) + ((not (equal (multiple-value-list (eval `(,name ,@args))) + expected)) + (list i :fail3)) + ;; Error cases + ((and (> i 0) + (let ((val (eval `(signals-error (,name ,@(cdr args)) program-error)))) + (and (not (eq val t)) :fail4)))) + ((and (< i (1- call-arguments-limit)) + (let ((val (eval `(signals-error (,name nil ,@args) program-error)))) + (and (not (eq val t)) :fail5))))) + collect it)) nil) diff --git a/ansi-tests/defvar.lsp b/ansi-tests/defvar.lsp index 5bffe6d3..de2beca2 100644 --- a/ansi-tests/defvar.lsp +++ b/ansi-tests/defvar.lsp @@ -57,27 +57,27 @@ ;;; (deftest defvar.error.1 ;;; (signals-error (defvar) program-error) ;;; t) -;;; +;;; ;;; (deftest defvar.error.2 ;;; (signals-error (defvar *ignored-defvar-name* nil "documentation" -;;; "illegal extra argument") +;;; "illegal extra argument") ;;; program-error) ;;; t) (deftest defvar.error.1 (signals-error (funcall (macro-function 'defvar)) - program-error) + program-error) t) (deftest defvar.error.2 (signals-error (funcall (macro-function 'defvar) - '(defvar *nonexistent-variable* nil)) - program-error) + '(defvar *nonexistent-variable* nil)) + program-error) t) (deftest defvar.error.3 (signals-error (funcall (macro-function 'defvar) - '(defvar *nonexistent-variable* nil) - nil nil) - program-error) + '(defvar *nonexistent-variable* nil) + nil nil) + program-error) t) diff --git a/ansi-tests/delete-file.lsp b/ansi-tests/delete-file.lsp index fef9bf01..05d59423 100644 --- a/ansi-tests/delete-file.lsp +++ b/ansi-tests/delete-file.lsp @@ -9,7 +9,7 @@ (let ((pn "scratchfile.txt")) (unless (probe-file pn) (with-open-file (s pn :direction :output) - (format s "Contents~%"))) + (format s "Contents~%"))) (values (notnot (probe-file pn)) (multiple-value-list (delete-file pn)) @@ -20,7 +20,7 @@ (let ((pn #p"scratchfile.txt")) (unless (probe-file pn) (with-open-file (s pn :direction :output) - (format s "Contents~%"))) + (format s "Contents~%"))) (values (notnot (probe-file pn)) (multiple-value-list (delete-file pn)) @@ -32,7 +32,7 @@ (assert (typep (pathname pn) 'logical-pathname)) (unless (probe-file pn) (with-open-file (s pn :direction :output) - (format s "Contents~%"))) + (format s "Contents~%"))) (values (notnot (probe-file pn)) (multiple-value-list (delete-file pn)) @@ -44,7 +44,7 @@ (assert (typep (pathname pn) 'logical-pathname)) (unless (probe-file pn) (with-open-file (s pn :direction :output) - (format s "Contents~%"))) + (format s "Contents~%"))) (let ((s (open pn :direction :input))) (close s) (values @@ -60,7 +60,7 @@ (pn "scratchfile.txt" nil) (unless (probe-file pn) (with-open-file (s pn :direction :output) - (format s "Contents~%"))) + (format s "Contents~%"))) (assert (probe-file pn)) (assert (equal (multiple-value-list (delete-file pn)) '(t))) (assert (not (probe-file pn)))) @@ -76,7 +76,7 @@ (let ((pn "scratch.txt")) (unless (probe-file pn) (with-open-file (s pn :direction :output) - (format s "Contents~%"))) + (format s "Contents~%"))) (values (notnot (probe-file pn)) (signals-error (delete-file "scratch.txt" nil) program-error) diff --git a/ansi-tests/delete-package.lsp b/ansi-tests/delete-package.lsp index 15dee9f1..c153e761 100644 --- a/ansi-tests/delete-package.lsp +++ b/ansi-tests/delete-package.lsp @@ -56,75 +56,75 @@ (deftest delete-package.5 (prog (p1 s1 p2 s2 p3) - (declare (ignorable p1 p2 p3 s1 s2)) - (safely-delete-package "P3") - (safely-delete-package "P2") - (safely-delete-package "P1") - - (setq p1 (make-package "P1" :use ())) - (setq s1 (intern "S1" P1)) - (export s1 "P1") - - (setq p2 (make-package "P2" :use '("P1"))) - (setq s2 (intern "S2" p2)) - (export s1 p2) - (export s2 "P2") - - (setf p3 (make-package "P3" :use '("P2"))) - - ;; Delete the P2 package, catching the continuable - ;; error and deleting the package - - (let ((outer-restarts (compute-restarts))) - (handler-bind ((package-error - #'(lambda (c) - ;; (let ((r (find-restart 'continue c))) (and r (invoke-restart r))) - (let ((my-restarts - (remove 'abort - (set-difference (compute-restarts c) - outer-restarts) - :key #'restart-name))) - (assert my-restarts) - (when (find 'continue my-restarts :key #'restart-name) - (continue c)) - (return t) - )))) - (delete-package p2))) - - (unless (and (equal (package-name P1) "P1") - (null (package-name P2)) - (equal (package-name P3) "P3")) - (return 'fail1)) - - (unless (eqt (symbol-package S1) P1) - (return 'fail2)) - (unless (equal (prin1-to-string S1) "P1:S1") - (return 'fail3)) - - (unless (equal (multiple-value-list (find-symbol "S1" P3)) - '(nil nil)) - (return 'fail4)) - - (unless (equal (multiple-value-list (find-symbol "S2" P3)) - '(nil nil)) - (return 'fail5)) - - (unless (and (null (package-used-by-list P1)) - (null (package-used-by-list P3))) - (return 'fail6)) - - (unless (and (packagep P1) - (packagep P2) - (packagep P3)) (return 'fail7)) - - (unless (and (null (package-use-list P1)) - (null (package-use-list P3))) - (return 'fail8)) - - (safely-delete-package P3) - (safely-delete-package P1) - (return t) - ) + (declare (ignorable p1 p2 p3 s1 s2)) + (safely-delete-package "P3") + (safely-delete-package "P2") + (safely-delete-package "P1") + + (setq p1 (make-package "P1" :use ())) + (setq s1 (intern "S1" P1)) + (export s1 "P1") + + (setq p2 (make-package "P2" :use '("P1"))) + (setq s2 (intern "S2" p2)) + (export s1 p2) + (export s2 "P2") + + (setf p3 (make-package "P3" :use '("P2"))) + + ;; Delete the P2 package, catching the continuable + ;; error and deleting the package + + (let ((outer-restarts (compute-restarts))) + (handler-bind ((package-error + #'(lambda (c) + ;; (let ((r (find-restart 'continue c))) (and r (invoke-restart r))) + (let ((my-restarts + (remove 'abort + (set-difference (compute-restarts c) + outer-restarts) + :key #'restart-name))) + (assert my-restarts) + (when (find 'continue my-restarts :key #'restart-name) + (continue c)) + (return t) + )))) + (delete-package p2))) + + (unless (and (equal (package-name P1) "P1") + (null (package-name P2)) + (equal (package-name P3) "P3")) + (return 'fail1)) + + (unless (eqt (symbol-package S1) P1) + (return 'fail2)) + (unless (equal (prin1-to-string S1) "P1:S1") + (return 'fail3)) + + (unless (equal (multiple-value-list (find-symbol "S1" P3)) + '(nil nil)) + (return 'fail4)) + + (unless (equal (multiple-value-list (find-symbol "S2" P3)) + '(nil nil)) + (return 'fail5)) + + (unless (and (null (package-used-by-list P1)) + (null (package-used-by-list P3))) + (return 'fail6)) + + (unless (and (packagep P1) + (packagep P2) + (packagep P3)) (return 'fail7)) + + (unless (and (null (package-use-list P1)) + (null (package-use-list P3))) + (return 'fail8)) + + (safely-delete-package P3) + (safely-delete-package P1) + (return t) + ) t) ;; deletion of a nonexistent package should cause a continuable @@ -136,11 +136,11 @@ (let ((outer-restarts (compute-restarts))) (safely-delete-package "TEST-20") (handler-bind ((package-error - #'(lambda (c) - (assert (set-difference (compute-restarts c) - outer-restarts)) - (return-from done :good)))) - (delete-package "TEST-20")))) + #'(lambda (c) + (assert (set-difference (compute-restarts c) + outer-restarts)) + (return-from done :good)))) + (delete-package "TEST-20")))) :good) ;;; Specialized sequences @@ -150,51 +150,51 @@ (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) - (list - (notnot (delete-package :test1)) - (notnot (packagep p)) - (package-name p)))) + (list + (notnot (delete-package :test1)) + (notnot (packagep p)) + (package-name p)))) (t t nil))) (def-delete-package-test delete-package.7 (make-array '(5) :initial-contents "TEST1" - :element-type 'base-char)) + :element-type 'base-char)) (def-delete-package-test delete-package.8 (make-array '(10) :initial-contents "TEST1XXXXX" - :fill-pointer 5 - :element-type 'base-char)) + :fill-pointer 5 + :element-type 'base-char)) (def-delete-package-test delete-package.9 (make-array '(10) :initial-contents "TEST1XXXXX" - :fill-pointer 5 - :element-type 'character)) + :fill-pointer 5 + :element-type 'character)) (def-delete-package-test delete-package.10 (make-array '(5) :initial-contents "TEST1" - :adjustable t - :element-type 'base-char)) + :adjustable t + :element-type 'base-char)) (def-delete-package-test delete-package.11 (make-array '(5) :initial-contents "TEST1" - :adjustable t - :element-type 'character)) + :adjustable t + :element-type 'character)) (def-delete-package-test delete-package.12 (let* ((etype 'character) - (name2 (make-array '(10) :initial-contents "XXXTEST1YY" - :element-type etype))) + (name2 (make-array '(10) :initial-contents "XXXTEST1YY" + :element-type etype))) (make-array '(5) :displaced-to name2 - :displaced-index-offset 3 - :element-type etype))) + :displaced-index-offset 3 + :element-type etype))) (def-delete-package-test delete-package.13 (let* ((etype 'base-char) - (name2 (make-array '(10) :initial-contents "XXXTEST1YY" - :element-type etype))) + (name2 (make-array '(10) :initial-contents "XXXTEST1YY" + :element-type etype))) (make-array '(5) :displaced-to name2 - :displaced-index-offset 3 - :element-type etype))) + :displaced-index-offset 3 + :element-type etype))) ;;; Error tests @@ -207,5 +207,5 @@ (unless (find-package "TEST-DPE2") (make-package "TEST-DPE2" :use nil)) (signals-error (delete-package "TEST-DPE2" nil) - program-error)) + program-error)) t) diff --git a/ansi-tests/deposit-field.lsp b/ansi-tests/deposit-field.lsp index 188e17a7..b478f056 100644 --- a/ansi-tests/deposit-field.lsp +++ b/ansi-tests/deposit-field.lsp @@ -27,58 +27,58 @@ (deftest deposit-field.1 (loop for pos = (random 32) - for size = (random 32) - for newbyte = (random (ash 1 (+ pos size))) - for val = (random (1+ (random (ash 1 (+ pos size))))) - for result = (deposit-field newbyte (byte size pos) val) - repeat 100 - unless - (loop for i from 0 to (+ pos size) - always (if (or (< i pos) - (>= i (+ pos size))) - (if (logbitp i val) (logbitp i result) - (not (logbitp i result))) - (if (logbitp i newbyte) (logbitp i result) - (not (logbitp i result))))) - collect (list pos size newbyte val result)) + for size = (random 32) + for newbyte = (random (ash 1 (+ pos size))) + for val = (random (1+ (random (ash 1 (+ pos size))))) + for result = (deposit-field newbyte (byte size pos) val) + repeat 100 + unless + (loop for i from 0 to (+ pos size) + always (if (or (< i pos) + (>= i (+ pos size))) + (if (logbitp i val) (logbitp i result) + (not (logbitp i result))) + (if (logbitp i newbyte) (logbitp i result) + (not (logbitp i result))))) + collect (list pos size newbyte val result)) nil) (deftest deposit-field.2 (loop for pos = (random 1000) - for size = (random 1000) - for newbyte = (random (ash 1 (+ pos size))) - for val = (random (1+ (random (ash 1 (+ pos size))))) - for result = (deposit-field newbyte (byte size pos) val) - repeat 100 - unless - (loop for i from 0 to (+ pos size) - always (if (or (< i pos) - (>= i (+ pos size))) - (if (logbitp i val) (logbitp i result) - (not (logbitp i result))) - (if (logbitp i newbyte) (logbitp i result) - (not (logbitp i result))))) - collect (list pos size newbyte val result)) + for size = (random 1000) + for newbyte = (random (ash 1 (+ pos size))) + for val = (random (1+ (random (ash 1 (+ pos size))))) + for result = (deposit-field newbyte (byte size pos) val) + repeat 100 + unless + (loop for i from 0 to (+ pos size) + always (if (or (< i pos) + (>= i (+ pos size))) + (if (logbitp i val) (logbitp i result) + (not (logbitp i result))) + (if (logbitp i newbyte) (logbitp i result) + (not (logbitp i result))))) + collect (list pos size newbyte val result)) nil) (deftest deposit-field.3 (loop for x = (random-fixnum) - for y = (random-fixnum) - for pos = (random 32) - repeat 100 - always (= (deposit-field x (byte 0 pos) y) y)) + for y = (random-fixnum) + for pos = (random 32) + repeat 100 + always (= (deposit-field x (byte 0 pos) y) y)) t) (deftest deposit-field.4 (let ((bound (ash 1 200))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for pos = (random 200) - repeat 100 - always (= (deposit-field x (byte 0 pos) y) y))) + for y = (random-from-interval bound) + for pos = (random 200) + repeat 100 + always (= (deposit-field x (byte 0 pos) y) y))) t) (deftest deposit-field.5 (loop for i of-type fixnum from -1000 to 1000 - always (eql (deposit-field -1 (byte 0 0) i) i)) + always (eql (deposit-field -1 (byte 0 0) i) i)) t) diff --git a/ansi-tests/describe.lsp b/ansi-tests/describe.lsp index 3361a886..6919d6de 100644 --- a/ansi-tests/describe.lsp +++ b/ansi-tests/describe.lsp @@ -14,10 +14,10 @@ (with-open-stream (tio-output (make-string-output-stream)) (with-open-stream - (*terminal-io* (make-two-way-stream tio-input tio-output)) - (let ((*print-circle* t) - (*print-readably* nil)) - (assert (null (multiple-value-list (funcall fn)))))) + (*terminal-io* (make-two-way-stream tio-input tio-output)) + (let ((*print-circle* t) + (*print-readably* nil)) + (assert (null (multiple-value-list (funcall fn)))))) (setq s2 (get-output-stream-string tio-output))) (assert (equal (read-char tio-input) #\X))) (setq s1 (get-output-stream-string *standard-output*))) @@ -25,33 +25,33 @@ (deftest describe.1 (loop for x in *universe* - for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x)))) - when (and (equal s1 "") (equal s2 "")) - collect x) + for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x)))) + when (and (equal s1 "") (equal s2 "")) + collect x) nil) (deftest describe.2 (loop for x in *universe* - for s1 = nil - for s2 = nil - for s3 = (with-output-to-string (s) - (setf (values s1 s2) (harness-for-describe #'(lambda () (describe x s))))) - when (or (equal s3 "") (not (equal "" s2)) (not (equal "" s1))) - collect (list x s1 s2 s3)) + for s1 = nil + for s2 = nil + for s3 = (with-output-to-string (s) + (setf (values s1 s2) (harness-for-describe #'(lambda () (describe x s))))) + when (or (equal s3 "") (not (equal "" s2)) (not (equal "" s1))) + collect (list x s1 s2 s3)) nil) (deftest describe.3 (loop for x in *universe* - for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x t)))) - when (or (equal "" s2) (not (equal "" s1))) - collect (list x s1 s2)) + for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x t)))) + when (or (equal "" s2) (not (equal "" s1))) + collect (list x s1 s2)) nil) (deftest describe.4 (loop for x in *universe* - for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x nil)))) - when (or (equal "" s1) (not (equal "" s2))) - collect (list x s1 s2)) + for (s1 s2) = (multiple-value-list (harness-for-describe #'(lambda () (describe x nil)))) + when (or (equal "" s1) (not (equal "" s2))) + collect (list x s1 s2)) nil) ;;; Defining methods for describe-object @@ -65,9 +65,9 @@ (let ((obj (make-instance 'describe-object-test-class-01 :s1 2 :s2 6 :s3 17))) (multiple-value-bind (str1 str2) (harness-for-describe #'(lambda () (describe obj))) (if (or (search "ABCDE 2 6 17 XYZ" str1) - (search "ABCDE 2 6 17 XYZ" str2)) - :good - (list str1 str2)))) + (search "ABCDE 2 6 17 XYZ" str2)) + :good + (list str1 str2)))) :good) ;;; Error cases diff --git a/ansi-tests/destructuring-bind.lsp b/ansi-tests/destructuring-bind.lsp index 7c61ee55..60972636 100644 --- a/ansi-tests/destructuring-bind.lsp +++ b/ansi-tests/destructuring-bind.lsp @@ -134,8 +134,8 @@ (declare (special x)) (let ((x :good)) (destructuring-bind (y) (list x) - (declare (special x)) - y))) + (declare (special x)) + y))) :good) (deftest destructuring-bind.26 @@ -156,7 +156,7 @@ (deftest destructuring-bind.29 (destructuring-bind (x &aux y) '(:foo) (values x y)) :foo nil) - + (deftest destructuring-bind.30 (destructuring-bind (x &aux (y (list x))) '(:foo) (values x y)) :foo (:foo)) @@ -175,22 +175,22 @@ #| (deftest destructuring-bind.error.1 (signals-error (destructuring-bind (a b c) nil (list a b c)) - program-error) + program-error) t) (deftest destructuring-bind.error.2 (signals-error (destructuring-bind ((a b c)) nil (list a b c)) - program-error) + program-error) t) (deftest destructuring-bind.error.3 (signals-error (destructuring-bind (a b) 'x (list a b)) - program-error) + program-error) t) (deftest destructuring-bind.error.4 (signals-error (destructuring-bind (a . b) 'x (list a b)) - program-error) + program-error) t) |# @@ -204,18 +204,18 @@ (deftest destructuring-bind.error.7 (signals-error (funcall (macro-function 'destructuring-bind)) - program-error) + program-error) t) (deftest destructuring-bind.error.8 (signals-error (funcall (macro-function 'destructuring-bind) - '(destructuring-bind (a . b) '(1 2) nil)) - program-error) + '(destructuring-bind (a . b) '(1 2) nil)) + program-error) t) (deftest destructuring-bind.error.9 (signals-error (funcall (macro-function 'destructuring-bind) - '(destructuring-bind (a . b) '(1 2) nil) - nil nil) - program-error) + '(destructuring-bind (a . b) '(1 2) nil) + nil nil) + program-error) t) diff --git a/ansi-tests/directory-namestring.lsp b/ansi-tests/directory-namestring.lsp index a330001e..de403177 100644 --- a/ansi-tests/directory-namestring.lsp +++ b/ansi-tests/directory-namestring.lsp @@ -7,12 +7,12 @@ (deftest directory-namestring.1 (let* ((vals (multiple-value-list - (directory-namestring "directory-namestring.lsp"))) - (s (first vals))) + (directory-namestring "directory-namestring.lsp"))) + (s (first vals))) (if (and (null (cdr vals)) - (stringp s) - (equal (directory-namestring s) s)) - :good + (stringp s) + (equal (directory-namestring s) s)) + :good vals)) :good) @@ -32,10 +32,10 @@ #-lispworks (deftest directory-namestring.3 (let* ((name "directory-namestring.lsp") - (pn (merge-pathnames (pathname name))) - (name2 (with-open-file (s pn :direction :input) - (directory-namestring s))) - (name3 (directory-namestring pn))) + (pn (merge-pathnames (pathname name))) + (name2 (with-open-file (s pn :direction :input) + (directory-namestring s))) + (name3 (directory-namestring pn))) (or (equalt name2 name3) (list name2 name3))) t) diff --git a/ansi-tests/directory.lsp b/ansi-tests/directory.lsp index c602140e..f39701c1 100644 --- a/ansi-tests/directory.lsp +++ b/ansi-tests/directory.lsp @@ -27,32 +27,32 @@ (deftest directory.6 (let* ((pattern-pathname (make-pathname :name :wild :type :wild - :defaults *default-pathname-defaults*)) - (pathnames (directory pattern-pathname))) + :defaults *default-pathname-defaults*)) + (pathnames (directory pattern-pathname))) (values (remove-if #'pathnamep pathnames) (loop for pn in pathnames - unless (equal pn (truename pn)) - collect pn) + unless (equal pn (truename pn)) + collect pn) ;; (loop for pn in pathnames -;; unless (pathname-match-p pn pattern-pathname) -;; collect pn)) +;; unless (pathname-match-p pn pattern-pathname) +;; collect pn)) )) nil nil ;; nil ) (deftest directory.7 (let* ((pattern-pathname (make-pathname :name :wild :type :wild - :defaults *default-pathname-defaults*)) - (pathnames (directory pattern-pathname))) + :defaults *default-pathname-defaults*)) + (pathnames (directory pattern-pathname))) (loop for pn in pathnames - unless (equal pn (probe-file pn)) - collect pn)) + unless (equal pn (probe-file pn)) + collect pn)) nil) (deftest directory.8 (let* ((pathname-pattern "CLTEST:*.*") - (len (length (directory pathname-pattern)))) + (len (length (directory pathname-pattern)))) (if (< len 500) len nil)) nil) diff --git a/ansi-tests/disassemble.lsp b/ansi-tests/disassemble.lsp index 36f436b3..99e0511d 100644 --- a/ansi-tests/disassemble.lsp +++ b/ansi-tests/disassemble.lsp @@ -11,7 +11,7 @@ (notnot (stringp (with-output-to-string (*standard-output*) - (setf val (disassemble fn))))) + (setf val (disassemble fn))))) val))) (deftest disassemble.1 @@ -53,7 +53,7 @@ (deftest disassemble.8 (progn (eval '(defun (setf disassemble-example-fn) (val arg) - (setf (car arg) val))) + (setf (car arg) val))) (disassemble-it '(setf disassemble-example-fn))) t nil) @@ -79,7 +79,7 @@ #'values (disassemble-it fn) (if is-compiled? (notnot (typep (symbol-function fn) 'compiled-function)) - (not (typep (symbol-function fn) 'compiled-function)))))) + (not (typep (symbol-function fn) 'compiled-function)))))) t nil t) ;;; Error tests @@ -94,6 +94,6 @@ (deftest disassemble.error.3 (check-type-error #'disassemble - (typef '(or function symbol (cons (eql setf) (cons symbol null))))) + (typef '(or function symbol (cons (eql setf) (cons symbol null))))) nil) diff --git a/ansi-tests/dispatch-macro-characters.lsp b/ansi-tests/dispatch-macro-characters.lsp index eecfadab..fbb15dcc 100644 --- a/ansi-tests/dispatch-macro-characters.lsp +++ b/ansi-tests/dispatch-macro-characters.lsp @@ -8,7 +8,7 @@ (deftest make-dispatch-macro-character.1 (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) + (*package* (find-package "CL-TEST"))) (values (make-dispatch-macro-character #\!) (read-from-string "123!")))) @@ -17,7 +17,7 @@ (deftest make-dispatch-macro-character.2 (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) + (*package* (find-package "CL-TEST"))) (values (make-dispatch-macro-character #\! t) (read-from-string "123!")))) @@ -26,27 +26,27 @@ (deftest make-dispatch-macro-character.3 (with-standard-io-syntax (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) + (*package* (find-package "CL-TEST"))) (values (make-dispatch-macro-character #\!) (loop for c across +standard-chars+ - for result = (handler-case - (read-from-string (coerce (list #\! c #\X) 'string)) - (reader-error (c) :good) - (error (c) :bad)) - unless (eql result :good) - collect (list c result))))) + for result = (handler-case + (read-from-string (coerce (list #\! c #\X) 'string)) + (reader-error (c) :good) + (error (c) :bad)) + unless (eql result :good) + collect (list c result))))) t nil) (deftest make-dispatch-macro-character.4 (with-standard-io-syntax (let* ((rt (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) + (*package* (find-package "CL-TEST"))) (values (make-dispatch-macro-character #\! t rt) (read-from-string "!") (let ((*readtable* rt)) - (read-from-string "123!"))))) + (read-from-string "123!"))))) t ! 123!) (deftest make-dispatch-macro-character.error.1 @@ -57,22 +57,22 @@ (deftest make-dispatch-macro-character.error.2 (let ((*readtable* (copy-readtable nil))) (signals-error (make-dispatch-macro-character #\! t *readtable* nil) - program-error)) + program-error)) t) ;;; GET-DISPATCH-MACRO-CHARACTER (deftest get-dispatch-macro-character.1 (loop for c across +standard-chars+ - when (and (not (eql c #\#)) - (handler-case - (list - (get-dispatch-macro-character c #\a) - c) - (error (cnd) nil))) - collect it) + when (and (not (eql c #\#)) + (handler-case + (list + (get-dispatch-macro-character c #\a) + c) + (error (cnd) nil))) + collect it) nil) - \ No newline at end of file + diff --git a/ansi-tests/divide.lsp b/ansi-tests/divide.lsp index 00f8e0e8..9cb906ce 100644 --- a/ansi-tests/divide.lsp +++ b/ansi-tests/divide.lsp @@ -45,164 +45,164 @@ (deftest /.3 (loop for i = (random-fixnum) - repeat 1000 - unless (or (zerop i) - (let ((q1 (/ i)) - (q2 (/ 1 i))) - (and (rationalp q1) - (eql (denominator q1) (abs i)) - (eql (numerator q1) (signum i)) - (eql q1 q2) - (eql (* q1 i) 1)))) - collect i) + repeat 1000 + unless (or (zerop i) + (let ((q1 (/ i)) + (q2 (/ 1 i))) + (and (rationalp q1) + (eql (denominator q1) (abs i)) + (eql (numerator q1) (signum i)) + (eql q1 q2) + (eql (* q1 i) 1)))) + collect i) nil) (deftest /.4 (loop for i = (random-from-interval 1000000 1) - for j = (random-from-interval 1000000 1) - for g = (gcd i j) - for q = (/ i j) - for q2 = (/ j) - repeat 1000 - unless (and (integerp g) - (zerop (mod i g)) - (zerop (mod j g)) - (eql (numerator q) (/ i g)) - (eql (denominator q) (/ j g)) - (eql (/ q) (/ j i)) - (eql q (* i q2))) - collect (list i j q)) + for j = (random-from-interval 1000000 1) + for g = (gcd i j) + for q = (/ i j) + for q2 = (/ j) + repeat 1000 + unless (and (integerp g) + (zerop (mod i g)) + (zerop (mod j g)) + (eql (numerator q) (/ i g)) + (eql (denominator q) (/ j g)) + (eql (/ q) (/ j i)) + (eql q (* i q2))) + collect (list i j q)) nil) (deftest /.5 (loop for bound in (list 1.0s5 1.0f10 1.0d20 1.0l20) - nconc - (loop for i = (1+ (random bound)) - for r1 = (/ i) - for r2 = (/ 1 i) - repeat 1000 - unless (eql r1 r2) - collect (list i r1 r2))) + nconc + (loop for i = (1+ (random bound)) + for r1 = (/ i) + for r2 = (/ 1 i) + repeat 1000 + unless (eql r1 r2) + collect (list i r1 r2))) nil) ;; Complex division (deftest /.6 (loop for i1 = (random-fixnum) - for i = (if (zerop i1) 1 i1) - for c = (complex 0 i) - for r = (/ c) - repeat 1000 - unless (eql r (complex 0 (- (/ i)))) - collect (list i c r)) + for i = (if (zerop i1) 1 i1) + for c = (complex 0 i) + for r = (/ c) + repeat 1000 + unless (eql r (complex 0 (- (/ i)))) + collect (list i c r)) nil) #| (deftest /.7 (loop for bound in (list 1.0s5 1.0f10 1.0d20 1.0l20) - nconc - (loop for i = (1+ (random bound)) - for c = (complex 0 i) - for r = (/ c) - repeat 1000 - unless (= r (complex 0 (- (/ i)))) - collect (list i c r (complex 0 (- (/ i)))))) + nconc + (loop for i = (1+ (random bound)) + for c = (complex 0 i) + for r = (/ c) + repeat 1000 + unless (= r (complex 0 (- (/ i)))) + collect (list i c r (complex 0 (- (/ i)))))) nil) |# (deftest /.8 (loop for bound in (list 1.0s5 1.0f10 1.0d20 1.0l20) - for one = (float 1.0 bound) - for zero = (float 0.0 bound) - nconc - (loop for i = (1+ (random bound)) - for c = (complex i zero) - for q = (/ c c) - repeat 100 - unless (eql q (complex one zero)) - collect (list i c q (complex one zero)))) + for one = (float 1.0 bound) + for zero = (float 0.0 bound) + nconc + (loop for i = (1+ (random bound)) + for c = (complex i zero) + for q = (/ c c) + repeat 100 + unless (eql q (complex one zero)) + collect (list i c q (complex one zero)))) nil) (deftest /.9 (loop for a = (random-fixnum) - for b = (random-fixnum) - for m = (+ (* a a) (* b b)) - repeat 1000 - unless - (or (zerop m) - (let* ((q (/ (complex a b))) - (c (/ a m)) - (d (/ (- b) m)) - (expected (complex c d))) - (eql q expected))) - collect (list a b (/ (complex a b)))) + for b = (random-fixnum) + for m = (+ (* a a) (* b b)) + repeat 1000 + unless + (or (zerop m) + (let* ((q (/ (complex a b))) + (c (/ a m)) + (d (/ (- b) m)) + (expected (complex c d))) + (eql q expected))) + collect (list a b (/ (complex a b)))) nil) (deftest /.10 (let ((bound 1000000000000000000)) (loop for a = (random-from-interval bound) - for b = (random-from-interval bound) - for m = (+ (* a a) (* b b)) - repeat 1000 - unless - (or (zerop m) - (let* ((q (/ (complex a b))) - (c (/ a m)) - (d (/ (- b) m)) - (expected (complex c d))) - (eql q expected))) - collect (list a b (/ (complex a b))))) + for b = (random-from-interval bound) + for m = (+ (* a a) (* b b)) + repeat 1000 + unless + (or (zerop m) + (let* ((q (/ (complex a b))) + (c (/ a m)) + (d (/ (- b) m)) + (expected (complex c d))) + (eql q expected))) + collect (list a b (/ (complex a b))))) nil) (deftest /.11 (loop for a = (random-fixnum) - for b = (random-fixnum) - for n = (complex (random-fixnum) (random-fixnum)) - for m = (+ (* a a) (* b b)) - repeat 1000 - unless - (or (zerop m) - (let* ((q (/ n (complex a b))) - (c (/ a m)) - (d (/ (- b) m)) - (expected (* n (complex c d)))) - (eql q expected))) - collect (list a b (/ n (complex a b)))) + for b = (random-fixnum) + for n = (complex (random-fixnum) (random-fixnum)) + for m = (+ (* a a) (* b b)) + repeat 1000 + unless + (or (zerop m) + (let* ((q (/ n (complex a b))) + (c (/ a m)) + (d (/ (- b) m)) + (expected (* n (complex c d)))) + (eql q expected))) + collect (list a b (/ n (complex a b)))) nil) ;;; More floating point tests (deftest /.12 (loop for type in '(short-float single-float double-float long-float) - for lower in (mapcar - #'rational-safely - (list - least-positive-short-float least-positive-single-float - least-positive-double-float least-positive-long-float)) - for upper in (mapcar - #'rational-safely - (list - most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float)) - for one = (coerce 1 type) - for radix = (float-radix one) - nconc - (loop - for i from 1 - for rpos = radix then (* rpos radix) - for rneg = (/ radix) then (/ rneg radix) - while (<= lower rneg rpos upper) - unless - (let ((frpos (float rpos one)) - (frneg (float rneg one))) - (and (eql (/ frpos) (/ one frpos)) - (eql (/ frpos) (/ 1.0s0 frpos)) - (eql (/ frpos) (/ 1 frpos)) - (eql (/ frpos) frneg) - (eql (/ frneg) (/ 1.0s0 frneg)) - (eql (/ frneg) (/ 1 frneg)) - (eql (/ frneg) frpos))) - collect (list i rpos rneg (float rpos one) (float rneg one)))) + for lower in (mapcar + #'rational-safely + (list + least-positive-short-float least-positive-single-float + least-positive-double-float least-positive-long-float)) + for upper in (mapcar + #'rational-safely + (list + most-positive-short-float most-positive-single-float + most-positive-double-float most-positive-long-float)) + for one = (coerce 1 type) + for radix = (float-radix one) + nconc + (loop + for i from 1 + for rpos = radix then (* rpos radix) + for rneg = (/ radix) then (/ rneg radix) + while (<= lower rneg rpos upper) + unless + (let ((frpos (float rpos one)) + (frneg (float rneg one))) + (and (eql (/ frpos) (/ one frpos)) + (eql (/ frpos) (/ 1.0s0 frpos)) + (eql (/ frpos) (/ 1 frpos)) + (eql (/ frpos) frneg) + (eql (/ frneg) (/ 1.0s0 frneg)) + (eql (/ frneg) (/ 1 frneg)) + (eql (/ frneg) frpos))) + collect (list i rpos rneg (float rpos one) (float rneg one)))) nil) ;;; Test that explicit calls to macroexpand in subforms @@ -210,8 +210,8 @@ (deftest /.13 (macrolet ((%m (z) z)) - (values - (/ (expand-in-current-env (%m 1/2))) - (/ (expand-in-current-env (%m 2)) 3) - (/ 5 (expand-in-current-env (%m 7))))) + (values + (/ (expand-in-current-env (%m 1/2))) + (/ (expand-in-current-env (%m 2)) 3) + (/ 5 (expand-in-current-env (%m 7))))) 2 2/3 5/7) diff --git a/ansi-tests/do-all-symbols.lsp b/ansi-tests/do-all-symbols.lsp index 25da273e..869bc38b 100644 --- a/ansi-tests/do-all-symbols.lsp +++ b/ansi-tests/do-all-symbols.lsp @@ -17,9 +17,9 @@ (with-package-iterator (f (list-all-packages) :internal :external :inherited) (loop - (multiple-value-bind (found sym) (f) - (unless found (return)) - (setf (gethash sym hash) t)))) + (multiple-value-bind (found sym) (f) + (unless found (return)) + (setf (gethash sym hash) t)))) ;; hash now contains all symbols accessible in any package ;; Check that all symbols from DO-ALL-SYMBOLS are in this ;; package @@ -33,8 +33,8 @@ (f (list-all-packages) :internal :external :inherited) (loop (multiple-value-bind (found sym) (f) - (unless found (return))` - (push sym symbols)))) + (unless found (return))` + (push sym symbols)))) (let ((hash (make-hash-table :test 'eq))) (do-all-symbols (s) (setf (gethash s hash) t)) (loop for s in symbols unless (gethash s hash) collect s))) @@ -86,7 +86,7 @@ (deftest do-all-symbols.9 (let ((x 0) - (y 1)) + (y 1)) (do-all-symbols (z nil) (declare (type (integer * 0) x)) (declare (type (integer 1 *) y)) @@ -108,7 +108,7 @@ (declare (special x)) (let ((x :bad)) (do-all-symbols (s x) - (declare (special x))))) + (declare (special x))))) :good) ;;; Executing a return actually terminates the loop @@ -117,10 +117,10 @@ (let ((should-have-returned nil)) (block done (do-all-symbols (s :bad1) - (when should-have-returned - (return-from done :bad2)) - (setq should-have-returned t) - (return :good)))) + (when should-have-returned + (return-from done :bad2)) + (setq should-have-returned t) + (return :good)))) :good) ;;; Test that explicit calls to macroexpand in subforms diff --git a/ansi-tests/do-external-symbols.lsp b/ansi-tests/do-external-symbols.lsp index 80ffc186..41f2c631 100644 --- a/ansi-tests/do-external-symbols.lsp +++ b/ansi-tests/do-external-symbols.lsp @@ -33,7 +33,7 @@ (deftest do-external-symbols.5 (equalt (collect-external-symbols "KEYWORD") - (collect-symbols "KEYWORD")) + (collect-symbols "KEYWORD")) t) ;; Test that do-external-symbols works without @@ -48,7 +48,7 @@ (deftest do-external-symbols.7 (let ((x nil) - (*package* (find-package "DS1"))) + (*package* (find-package "DS1"))) (list (do-external-symbols (s) (push s x)) (sort-symbols x))) @@ -85,31 +85,31 @@ (def-do-external-symbols-test do-external-symbols.10 (make-array 6 :element-type 'base-char :initial-contents "DS1XXX" - :fill-pointer 3)) + :fill-pointer 3)) (def-do-external-symbols-test do-external-symbols.11 (make-array 6 :element-type 'character :initial-contents "DS1XXX" - :fill-pointer 3)) + :fill-pointer 3)) (def-do-external-symbols-test do-external-symbols.12 (make-array 3 :element-type 'base-char :initial-contents "DS1" - :adjustable t)) + :adjustable t)) (def-do-external-symbols-test do-external-symbols.13 (make-array 3 :element-type 'character :initial-contents "DS1" - :adjustable t)) + :adjustable t)) (def-do-external-symbols-test do-external-symbols.14 (let* ((etype 'base-char) - (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX"))) + (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX"))) (make-array 3 :element-type etype - :displaced-to name0 :displaced-index-offset 1))) + :displaced-to name0 :displaced-index-offset 1))) (def-do-external-symbols-test do-external-symbols.15 (let* ((etype 'character) - (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX"))) + (name0 (make-array 6 :element-type etype :initial-contents "XDS1XX"))) (make-array 3 :element-type etype - :displaced-to name0 :displaced-index-offset 1))) + :displaced-to name0 :displaced-index-offset 1))) ;;; Free declaration scope tests @@ -118,8 +118,8 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (do-external-symbols (s (return-from done x)) - (declare (special x)))))) + (do-external-symbols (s (return-from done x)) + (declare (special x)))))) :good) (deftest do-external-symbols.17 @@ -127,7 +127,7 @@ (declare (special x)) (let ((x :bad)) (do-external-symbols (s "CL-TEST" x) - (declare (special x))))) + (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms @@ -148,4 +148,4 @@ ;;; Error tests (def-macro-test do-external-symbols.error.1 - (do-external-symbols (x "CL"))) \ No newline at end of file + (do-external-symbols (x "CL"))) diff --git a/ansi-tests/do-symbols.lsp b/ansi-tests/do-symbols.lsp index 53dcee2e..947cd496 100644 --- a/ansi-tests/do-symbols.lsp +++ b/ansi-tests/do-symbols.lsp @@ -15,9 +15,9 @@ (equalt (remove-duplicates (sort-symbols (let ((all nil)) - (do-symbols (x "B" all) (push x all))))) + (do-symbols (x "B" all) (push x all))))) (list (find-symbol "BAR" "B") - (find-symbol "FOO" "A")))) + (find-symbol "FOO" "A")))) t) ;; @@ -46,8 +46,8 @@ (remove-duplicates (collect-symbols "DS4") :test #'(lambda (x y) - (and (eqt x y) - (not (eqt x 'DS4::B))))) + (and (eqt x y) + (not (eqt x 'DS4::B))))) (DS1:A DS1:B DS2::F DS3:G DS3:I DS3:J DS3:K DS4::X DS4::Y DS4::Z)) @@ -62,7 +62,7 @@ (deftest do-symbols.7 (let ((x nil) - (*package* (find-package "DS1"))) + (*package* (find-package "DS1"))) (list (do-symbols (s) (push s x)) (sort-symbols x))) @@ -95,11 +95,11 @@ (assert (string= name "B")) (set-up-packages) (equalt - (remove-duplicates - (sort-symbols (let ((all nil)) - (do-symbols (x name all) (push x all))))) - (list (find-symbol "BAR" "B") - (find-symbol "FOO" "A")))) + (remove-duplicates + (sort-symbols (let ((all nil)) + (do-symbols (x name all) (push x all))))) + (list (find-symbol "BAR" "B") + (find-symbol "FOO" "A")))) t)) (def-do-symbols-test do-symbols.9 @@ -107,33 +107,33 @@ (def-do-symbols-test do-symbols.10 (make-array 5 :element-type 'character - :fill-pointer 1 - :initial-contents "BXXXX")) + :fill-pointer 1 + :initial-contents "BXXXX")) (def-do-symbols-test do-symbols.11 (make-array 5 :element-type 'base-char - :fill-pointer 1 - :initial-contents "BXXXX")) + :fill-pointer 1 + :initial-contents "BXXXX")) (def-do-symbols-test do-symbols.12 (make-array 1 :element-type 'base-char - :adjustable t :initial-contents "B")) + :adjustable t :initial-contents "B")) (def-do-symbols-test do-symbols.13 (make-array 1 :element-type 'character - :adjustable t :initial-contents "B")) + :adjustable t :initial-contents "B")) (def-do-symbols-test do-symbols.14 (let* ((etype 'base-char) - (name0 (make-array 4 :element-type etype :initial-contents "XBYZ"))) + (name0 (make-array 4 :element-type etype :initial-contents "XBYZ"))) (make-array 1 :element-type etype - :displaced-to name0 :displaced-index-offset 1))) + :displaced-to name0 :displaced-index-offset 1))) (def-do-symbols-test do-symbols.15 (let* ((etype 'character) - (name0 (make-array 4 :element-type etype :initial-contents "XBYZ"))) + (name0 (make-array 4 :element-type etype :initial-contents "XBYZ"))) (make-array 1 :element-type etype - :displaced-to name0 :displaced-index-offset 1))) + :displaced-to name0 :displaced-index-offset 1))) ;;; Free declaration scope tests @@ -142,8 +142,8 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (do-symbols (s (return-from done x)) - (declare (special x)))))) + (do-symbols (s (return-from done x)) + (declare (special x)))))) :good) (deftest do-symbols.17 @@ -151,7 +151,7 @@ (declare (special x)) (let ((x :bad)) (do-symbols (s "CL-TEST" x) - (declare (special x))))) + (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms diff --git a/ansi-tests/do.lsp b/ansi-tests/do.lsp index bafb0c23..54551641 100644 --- a/ansi-tests/do.lsp +++ b/ansi-tests/do.lsp @@ -20,14 +20,14 @@ (deftest do.3 (let ((x nil)) (do ((i 0 (1+ i))) - ((>= i 10) x) + ((>= i 10) x) (push i x))) (9 8 7 6 5 4 3 2 1 0)) (deftest do.4 (let ((x nil)) (do ((i 0 (1+ i))) - ((>= i 10) x) + ((>= i 10) x) (declare (fixnum i)) (push i x))) (9 8 7 6 5 4 3 2 1 0)) @@ -49,7 +49,7 @@ (deftest do.7 (let ((x nil)) (do ((i 0 (1+ i))) - ((>= i 10) x) + ((>= i 10) x) (go around) small (push 'a x) @@ -74,7 +74,7 @@ (deftest do.9 (let ((i 0)) (do () - ((>= i 10) i) + ((>= i 10) i) (incf i))) 10) @@ -104,21 +104,21 @@ (deftest do.14 (let ((x 0)) (flet ((%f () (locally (declare (special i)) - (incf x i)))) + (incf x i)))) (do ((i 0 (1+ i))) - ((>= i 10) x) - (declare (special i)) - (%f)))) + ((>= i 10) x) + (declare (special i)) + (%f)))) 45) ;;; Confirm that the variables in succesive iterations are ;;; identical (deftest do.15 (mapcar #'funcall - (let ((x nil)) - (do ((i 0 (1+ i))) - ((= i 5) x) - (push #'(lambda () i) x)))) + (let ((x nil)) + (do ((i 0 (1+ i))) + ((= i 5) x) + (push #'(lambda () i) x)))) (5 5 5 5 5)) ;;; Scope of free declarations @@ -128,9 +128,9 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (do ((i (return-from done x) 0)) - (t nil) - (declare (special x)))))) + (do ((i (return-from done x) 0)) + (t nil) + (declare (special x)))))) :good) (deftest do.17 @@ -138,9 +138,9 @@ (let ((x :good)) (declare (special x)) (let ((x :bad)) - (do ((i 0 (return-from done x))) - (nil nil) - (declare (special x)))))) + (do ((i 0 (return-from done x))) + (nil nil) + (declare (special x)))))) :good) (deftest do.18 @@ -148,9 +148,9 @@ (let ((x :good)) (declare (special x)) (let ((x :bad)) - (do ((i 0 0)) - ((return-from done x) nil) - (declare (special x)))))) + (do ((i 0 0)) + ((return-from done x) nil) + (declare (special x)))))) :good) (deftest do.19 @@ -158,7 +158,7 @@ (declare (special x)) (let ((x :bad)) (do () (t x) - (declare (special x))))) + (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms @@ -169,8 +169,8 @@ (macrolet ((%m (z) z)) (do ((x (expand-in-current-env (%m 0)) (+ x 2))) - ((> x 10) result) - (push x result)))) + ((> x 10) result) + (push x result)))) (10 8 6 4 2 0)) (deftest do.21 @@ -178,8 +178,8 @@ (macrolet ((%m (z) z)) (do ((x 0 (expand-in-current-env (%m (+ x 2))))) - ((> x 10) result) - (push x result)))) + ((> x 10) result) + (push x result)))) (10 8 6 4 2 0)) (deftest do.22 @@ -187,8 +187,8 @@ (macrolet ((%m (z) z)) (do ((x 0 (+ x 2))) - ((expand-in-current-env (%m (> x 10))) result) - (push x result)))) + ((expand-in-current-env (%m (> x 10))) result) + (push x result)))) (10 8 6 4 2 0)) (deftest do.23 @@ -196,8 +196,8 @@ (macrolet ((%m (z) z)) (do ((x 0 (+ x 2))) - ((> x 10) (expand-in-current-env (%m result))) - (push x result)))) + ((> x 10) (expand-in-current-env (%m result))) + (push x result)))) (10 8 6 4 2 0)) (def-macro-test do.error.1 diff --git a/ansi-tests/documentation.lsp b/ansi-tests/documentation.lsp index cc4cd658..5918a6e8 100644 --- a/ansi-tests/documentation.lsp +++ b/ansi-tests/documentation.lsp @@ -17,11 +17,11 @@ (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (let ((fn (symbol-function sym)) - (doc "FOO1")) + (doc "FOO1")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) - (equal doc (documentation fn t))))))) + (equal doc (documentation fn t))))))) "FOO1") (deftest documentation.function.t.3 @@ -34,93 +34,93 @@ (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (let ((fn (macro-function sym)) - (doc "FOO2")) + (doc "FOO2")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) - (equal doc (documentation fn t))))))) + (equal doc (documentation fn t))))))) "FOO2") (deftest documentation.function.t.6 (let* ((sym (gensym)) - (fn (eval `#'(lambda () ',sym))) - (doc "FOO3")) + (fn (eval `#'(lambda () ',sym))) + (doc "FOO3")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) - (equal doc (documentation fn t)))))) + (equal doc (documentation fn t)))))) "FOO3") (deftest documentation.function.t.6a (let* ((sym (gensym)) - (fn (compile nil `(lambda () ',sym))) - (doc "FOO3A")) + (fn (compile nil `(lambda () ',sym))) + (doc "FOO3A")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) - (equal doc (documentation fn t)))))) + (equal doc (documentation fn t)))))) "FOO3A") ;; Reorder 5, 5a and 6, 6a to expose possible interaction bug (deftest documentation.function.t.5 (let* ((sym (gensym)) - (fn (eval `#'(lambda () ',sym)))) + (fn (eval `#'(lambda () ',sym)))) (documentation fn t)) nil) (deftest documentation.function.t.5a (let* ((sym (gensym)) - (fn (compile nil `(lambda () ',sym)))) + (fn (compile nil `(lambda () ',sym)))) (documentation fn t)) nil) (deftest documentation.function.t.7 (let* ((sym (gensym)) - (fn (eval `(defgeneric ,sym (x))))) + (fn (eval `(defgeneric ,sym (x))))) (documentation fn t)) nil) - + (deftest documentation.function.t.8 (let* ((sym (gensym)) - (fn (eval `(defgeneric ,sym (x)))) - (doc "FOO4")) + (fn (eval `(defgeneric ,sym (x)))) + (doc "FOO4")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn t)) - (equal doc (documentation fn t)))))) + (equal doc (documentation fn t)))))) "FOO4") (deftest documentation.function.t.9 (loop for s in *cl-function-symbols* - for fn = (symbol-function s) - for doc = (documentation fn t) - unless (or (null doc) (string doc)) - collect (list s doc)) + for fn = (symbol-function s) + for doc = (documentation fn t) + unless (or (null doc) (string doc)) + collect (list s doc)) nil) (deftest documentation.function.t.10 (loop for s in *cl-accessor-symbols* - for fn = (symbol-function s) - for doc = (documentation fn t) - unless (or (null doc) (string doc)) - collect (list s doc)) + for fn = (symbol-function s) + for doc = (documentation fn t) + unless (or (null doc) (string doc)) + collect (list s doc)) nil) (deftest documentation.function.t.11 (loop for s in *cl-macro-symbols* - for fn = (macro-function s) - for doc = (documentation fn t) - unless (or (null doc) (string doc)) - collect (list s doc)) + for fn = (macro-function s) + for doc = (documentation fn t) + unless (or (null doc) (string doc)) + collect (list s doc)) nil) (deftest documentation.function.t.12 (loop for s in *cl-standard-generic-function-symbols* - for fn = (symbol-function s) - for doc = (documentation fn t) - unless (or (null doc) (string doc)) - collect (list s doc)) + for fn = (symbol-function s) + for doc = (documentation fn t) + unless (or (null doc) (string doc)) + collect (list s doc)) nil) ;;; documentation (x function) (doc-type (eql 'function)) @@ -135,11 +135,11 @@ (let* ((sym (gensym))) (eval `(defun ,sym () nil)) (let ((fn (symbol-function sym)) - (doc "FOO5")) + (doc "FOO5")) (multiple-value-prog1 (setf (documentation fn 'function) (copy-seq doc)) (assert (or (null (documentation fn 'function)) - (equal doc (documentation fn 'function))))))) + (equal doc (documentation fn 'function))))))) "FOO5") (deftest documentation.function.function.3 @@ -152,27 +152,27 @@ (let* ((sym (gensym))) (eval `(defmacro ,sym () nil)) (let ((fn (macro-function sym)) - (doc "FOO6")) + (doc "FOO6")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn 'function)) - (equal doc (documentation fn 'function))))))) + (equal doc (documentation fn 'function))))))) "FOO6") (deftest documentation.function.function.5 (let* ((sym (gensym)) - (fn (eval `(defgeneric ,sym (x))))) + (fn (eval `(defgeneric ,sym (x))))) (documentation fn 'function)) nil) - + (deftest documentation.function.function.8 (let* ((sym (gensym)) - (fn (eval `(defgeneric ,sym (x)))) - (doc "FOO4A")) + (fn (eval `(defgeneric ,sym (x)))) + (doc "FOO4A")) (multiple-value-prog1 (setf (documentation fn t) (copy-seq doc)) (assert (or (null (documentation fn 'function)) - (equal doc (documentation fn 'function)))))) + (equal doc (documentation fn 'function)))))) "FOO4A") ;;; documentation (x list) (doc-type (eql 'function)) @@ -187,11 +187,11 @@ (let* ((sym (gensym))) (eval `(defun (setf ,sym) (&rest args) (declare (ignore args)) nil)) (let ((fn `(setf ,sym)) - (doc "FOO7")) + (doc "FOO7")) (multiple-value-prog1 (setf (documentation fn 'function) (copy-seq doc)) (assert (or (null (documentation fn 'function)) - (equal doc (documentation fn 'function))))))) + (equal doc (documentation fn 'function))))))) "FOO7") ;;; documentation (x list) (doc-type (eql 'compiler-macro)) @@ -206,11 +206,11 @@ (let* ((sym (gensym))) (eval `(define-compiler-macro (setf ,sym) (&rest args) (declare (ignore args)) nil)) (let ((fn `(setf ,sym)) - (doc "FOO8")) + (doc "FOO8")) (multiple-value-prog1 (setf (documentation fn 'compiler-macro) (copy-seq doc)) (assert (or (null (documentation fn 'function)) - (equal doc (documentation fn 'compiler-macro))))))) + (equal doc (documentation fn 'compiler-macro))))))) "FOO8") ;;; documentation (x symbol) (doc-type (eql 'function)) @@ -228,7 +228,7 @@ (multiple-value-prog1 (setf (documentation sym 'function) (copy-seq doc)) (assert (or (null (documentation sym 'function)) - (equal doc (documentation sym 'function))))))) + (equal doc (documentation sym 'function))))))) "FOO9") (deftest documentation.symbol.function.3 @@ -244,7 +244,7 @@ (multiple-value-prog1 (setf (documentation sym 'function) (copy-seq doc)) (assert (or (null (documentation sym 'function)) - (equal doc (documentation sym 'function))))))) + (equal doc (documentation sym 'function))))))) "FOO9A") (deftest documentation.symbol.function.5 @@ -260,28 +260,28 @@ (multiple-value-prog1 (setf (documentation sym 'function) (copy-seq doc)) (assert (or (null (documentation sym 'function)) - (equal doc (documentation sym 'function))))))) + (equal doc (documentation sym 'function))))))) "FOO9B") (deftest documentation.symbol.function.7 (loop for s in *cl-special-operator-symbols* - for doc = (documentation s 'function) - unless (or (null doc) (stringp doc)) - collect (list s doc)) + for doc = (documentation s 'function) + unless (or (null doc) (stringp doc)) + collect (list s doc)) nil) (deftest documentation.symbol.function.8 (loop for s in *cl-function-or-accessor-symbols* - for doc = (documentation s 'function) - unless (or (null doc) (stringp doc)) - collect (list s doc)) + for doc = (documentation s 'function) + unless (or (null doc) (stringp doc)) + collect (list s doc)) nil) (deftest documentation.symbol.function.9 (loop for s in *cl-macro-symbols* - for doc = (documentation s 'function) - unless (or (null doc) (stringp doc)) - collect (list s doc)) + for doc = (documentation s 'function) + unless (or (null doc) (stringp doc)) + collect (list s doc)) nil) ;;; documentation (x symbol) (doc-type (eql 'compiler-macro)) @@ -299,41 +299,41 @@ (multiple-value-prog1 (setf (documentation sym 'compiler-macro) (copy-seq doc)) (assert (or (null (documentation sym 'compiler-macro)) - (equal doc (documentation sym 'compiler-macro))))))) + (equal doc (documentation sym 'compiler-macro))))))) "FOO10") - + ;;; documentation (x symbol) (doc-type (eql 'setf)) (deftest documentation.symbol.setf.1 (let* ((sym (gensym)) - (doc "FOO11")) + (doc "FOO11")) (eval `(defun ,sym () (declare (special *x*)) *x*)) (eval `(define-setf-expander ,sym () - (let ((g (gemsym))) - (values nil nil (list g) `(locally (declare (special *x*)) (setf *x* ,g)) - '(locally (declare (special *x*)) *x*))))) + (let ((g (gemsym))) + (values nil nil (list g) `(locally (declare (special *x*)) (setf *x* ,g)) + '(locally (declare (special *x*)) *x*))))) (multiple-value-prog1 (values (documentation sym 'setf) (setf (documentation sym 'setf) (copy-seq doc))) (assert (or (null (documentation sym 'setf)) - (equal doc (documentation sym 'setf)))))) + (equal doc (documentation sym 'setf)))))) nil "FOO11") (deftest documentation.symbol.setf.2 (let* ((sym (gensym)) - (doc "FOO12")) + (doc "FOO12")) (eval `(defmacro ,sym () `(locally (declare (special *x*)) *x*))) (eval `(define-setf-expander ,sym () - (let ((g (gemsym))) - (values nil nil (list g) `(locally (declare (special *x*)) (setf *x* ,g)) - '(locally (declare (special *x*)) *x*))))) + (let ((g (gemsym))) + (values nil nil (list g) `(locally (declare (special *x*)) (setf *x* ,g)) + '(locally (declare (special *x*)) *x*))))) (multiple-value-prog1 (values (documentation sym 'setf) (setf (documentation sym 'setf) (copy-seq doc))) (assert (or (null (documentation sym 'setf)) - (equal doc (documentation sym 'setf)))))) + (equal doc (documentation sym 'setf)))))) nil "FOO12") ;;; documentation (x method-combination) (doc-type (eql 't)) @@ -345,29 +345,29 @@ (deftest documentation.symbol.method-combination.1 (let* ((sym (gensym)) - (doc "FOO13")) + (doc "FOO13")) (eval `(define-method-combination ,sym :identity-with-one-argument t)) (multiple-value-prog1 (values (documentation sym 'method-combination) (setf (documentation sym 'method-combination) (copy-seq doc))) (assert (or (null (documentation sym 'method-combination)) - (equal doc (documentation sym 'method-combination)))))) + (equal doc (documentation sym 'method-combination)))))) nil "FOO13") ;;; documentation (x standard-method) (doc-type (eql 't)) (deftest documentation.standard-method.t.1 (let* ((sym (gensym)) - (doc "FOO14")) + (doc "FOO14")) (eval `(defgeneric ,sym (x))) (let ((method (eval `(defmethod ,sym ((x t)) nil)))) (multiple-value-prog1 (values - (documentation method t) - (setf (documentation method t) (copy-seq doc))) + (documentation method t) + (setf (documentation method t) (copy-seq doc))) (assert (or (null (documentation method 't)) - (equal doc (documentation method 't))))))) + (equal doc (documentation method 't))))))) nil "FOO14") ;;; documentation (x package) (doc-type (eql 't)) @@ -375,17 +375,17 @@ (deftest documentation.package.t.1 (let ((package-name "PACKAGE-NAME-FOR-DOCUMENATION-TESTS-1")) (unwind-protect - (progn - (eval `(defpackage ,package-name (:use))) - (let ((pkg (find-package package-name)) - (doc "FOO15")) - (assert pkg) - (multiple-value-prog1 - (values - (documentation pkg t) - (setf (documentation pkg t) (copy-seq doc))) - (assert (or (null (documentation pkg t)) - (equal doc (documentation pkg t))))))) + (progn + (eval `(defpackage ,package-name (:use))) + (let ((pkg (find-package package-name)) + (doc "FOO15")) + (assert pkg) + (multiple-value-prog1 + (values + (documentation pkg t) + (setf (documentation pkg t) (copy-seq doc))) + (assert (or (null (documentation pkg t)) + (equal doc (documentation pkg t))))))) (delete-package package-name))) nil "FOO15") @@ -393,113 +393,113 @@ (deftest documentation.standard-class.t.1 (let* ((sym (gensym)) - (class-form `(defclass ,sym () ()))) + (class-form `(defclass ,sym () ()))) (eval class-form) (let ((class (find-class sym)) - (doc "FOO16")) + (doc "FOO16")) (multiple-value-prog1 (values - (documentation class t) - (setf (documentation class t) (copy-seq doc))) + (documentation class t) + (setf (documentation class t) (copy-seq doc))) (assert (or (null (documentation class t)) - (equal doc (documentation class t))))))) + (equal doc (documentation class t))))))) nil "FOO16") ;;; documentation (x standard-class) (doc-type (eql 'type)) (deftest documentation.standard-class.type.1 (let* ((sym (gensym)) - (class-form `(defclass ,sym () ()))) + (class-form `(defclass ,sym () ()))) (eval class-form) (let ((class (find-class sym)) - (doc "FOO17")) + (doc "FOO17")) (multiple-value-prog1 (values - (documentation class 'type) - (setf (documentation class 'type) (copy-seq doc))) + (documentation class 'type) + (setf (documentation class 'type) (copy-seq doc))) (assert (or (null (documentation class 'type)) - (equal doc (documentation class 'type))))))) + (equal doc (documentation class 'type))))))) nil "FOO17") ;;; documentation (x structure-class) (doc-type (eql 't)) - + (deftest documentation.struct-class.t.1 (let* ((sym (gensym)) - (class-form `(defstruct ,sym a b c))) + (class-form `(defstruct ,sym a b c))) (eval class-form) (let ((class (find-class sym)) - (doc "FOO18")) + (doc "FOO18")) (multiple-value-prog1 (values - (documentation class t) - (setf (documentation class t) (copy-seq doc))) + (documentation class t) + (setf (documentation class t) (copy-seq doc))) (assert (or (null (documentation class t)) - (equal doc (documentation class t))))))) + (equal doc (documentation class t))))))) nil "FOO18") ;;; documentation (x structure-class) (doc-type (eql 'type)) (deftest documentation.struct-class.type.1 (let* ((sym (gensym)) - (class-form `(defstruct ,sym a b c))) + (class-form `(defstruct ,sym a b c))) (eval class-form) (let ((class (find-class sym)) - (doc "FOO19")) + (doc "FOO19")) (multiple-value-prog1 (values - (documentation class 'type) - (setf (documentation class 'type) (copy-seq doc))) + (documentation class 'type) + (setf (documentation class 'type) (copy-seq doc))) (assert (or (null (documentation class 'type)) - (equal doc (documentation class 'type))))))) + (equal doc (documentation class 'type))))))) nil "FOO19") ;;; documentation (x symbol) (doc-type (eql 'type)) (deftest documentation.symbol.type.1 (let* ((sym (gensym)) - (class-form `(defclass ,sym () ())) - (doc "FOO20")) + (class-form `(defclass ,sym () ())) + (doc "FOO20")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'type) (setf (documentation sym 'type) (copy-seq doc))) (assert (or (null (documentation sym 'type)) - (equal doc (documentation sym 'type)))))) + (equal doc (documentation sym 'type)))))) nil "FOO20") (deftest documentation.symbol.type.2 (let* ((sym (gensym)) - (class-form `(defstruct ,sym a b c)) - (doc "FOO21")) + (class-form `(defstruct ,sym a b c)) + (doc "FOO21")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'type) (setf (documentation sym 'type) (copy-seq doc))) (assert (or (null (documentation sym 'type)) - (equal doc (documentation sym 'type)))))) + (equal doc (documentation sym 'type)))))) nil "FOO21") (deftest documentation.symbol.type.3 (let* ((sym (gensym)) - (type-form `(deftype ,sym () t)) - (doc "FOO21A")) + (type-form `(deftype ,sym () t)) + (doc "FOO21A")) (eval type-form) (multiple-value-prog1 (values (documentation sym 'type) (setf (documentation sym 'type) (copy-seq doc))) (assert (or (null (documentation sym 'type)) - (equal doc (documentation sym 'type)))))) + (equal doc (documentation sym 'type)))))) nil "FOO21A") (deftest documentation.symbol.type.4 (loop for s in *cl-all-type-symbols* - for doc = (documentation s 'type) - unless (or (null doc) (stringp doc)) - collect (list doc)) + for doc = (documentation s 'type) + unless (or (null doc) (stringp doc)) + collect (list doc)) nil) @@ -507,109 +507,109 @@ (deftest documentation.symbol.structure.1 (let* ((sym (gensym)) - (class-form `(defstruct ,sym a b c)) - (doc "FOO22")) + (class-form `(defstruct ,sym a b c)) + (doc "FOO22")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'structure) (setf (documentation sym 'structure) (copy-seq doc))) (assert (or (null (documentation sym 'structure)) - (equal doc (documentation sym 'structure)))))) + (equal doc (documentation sym 'structure)))))) nil "FOO22") (deftest documentation.symbol.structure.2 (let* ((sym (gensym)) - (class-form `(defstruct (,sym (:type list)) a b c)) - (doc "FOO23")) + (class-form `(defstruct (,sym (:type list)) a b c)) + (doc "FOO23")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'structure) (setf (documentation sym 'structure) (copy-seq doc))) (assert (or (null (documentation sym 'structure)) - (equal doc (documentation sym 'structure)))))) + (equal doc (documentation sym 'structure)))))) nil "FOO23") (deftest documentation.symbol.structure.3 (let* ((sym (gensym)) - (class-form `(defstruct (,sym (:type vector)) a b c)) - (doc "FOO24")) + (class-form `(defstruct (,sym (:type vector)) a b c)) + (doc "FOO24")) (eval class-form) (multiple-value-prog1 (values (documentation sym 'structure) (setf (documentation sym 'structure) (copy-seq doc))) (assert (or (null (documentation sym 'structure)) - (equal doc (documentation sym 'structure)))))) + (equal doc (documentation sym 'structure)))))) nil "FOO24") ;;; documentation (x symbol) (doc-type (eql 'variable)) (deftest documentation.symbol.variable.1 (let* ((sym (gensym)) - (form `(defvar ,sym)) - (doc "FOO25")) + (form `(defvar ,sym)) + (doc "FOO25")) (eval form) (multiple-value-prog1 (values (documentation sym 'variable) (setf (documentation sym 'variable) (copy-seq doc))) (assert (or (null (documentation sym 'variable)) - (equal doc (documentation sym 'variable)))))) + (equal doc (documentation sym 'variable)))))) nil "FOO25") (deftest documentation.symbol.variable.2 (let* ((sym (gensym)) - (form `(defvar ,sym t)) - (doc "FOO26")) + (form `(defvar ,sym t)) + (doc "FOO26")) (eval form) (multiple-value-prog1 (values (documentation sym 'variable) (setf (documentation sym 'variable) (copy-seq doc))) (assert (or (null (documentation sym 'variable)) - (equal doc (documentation sym 'variable)))))) + (equal doc (documentation sym 'variable)))))) nil "FOO26") (deftest documentation.symbol.variable.3 (let* ((sym (gensym)) - (form `(defparameter ,sym t)) - (doc "FOO27")) + (form `(defparameter ,sym t)) + (doc "FOO27")) (eval form) (multiple-value-prog1 (values (documentation sym 'variable) (setf (documentation sym 'variable) (copy-seq doc))) (assert (or (null (documentation sym 'variable)) - (equal doc (documentation sym 'variable)))))) + (equal doc (documentation sym 'variable)))))) nil "FOO27") (deftest documentation.symbol.variable.4 (let* ((sym (gensym)) - (form `(defconstant ,sym t)) - (doc "FOO27")) + (form `(defconstant ,sym t)) + (doc "FOO27")) (eval form) (multiple-value-prog1 (values (documentation sym 'variable) (setf (documentation sym 'variable) (copy-seq doc))) (assert (or (null (documentation sym 'variable)) - (equal doc (documentation sym 'variable)))))) + (equal doc (documentation sym 'variable)))))) nil "FOO27") (deftest documentation.symbol.variable.5 (loop for s in *cl-variable-symbols* - for doc = (documentation s 'variable) - unless (or (null doc) (stringp doc)) - collect (list s doc)) + for doc = (documentation s 'variable) + unless (or (null doc) (stringp doc)) + collect (list s doc)) nil) (deftest documentation.symbol.variable.6 (loop for s in *cl-constant-symbols* - for doc = (documentation s 'variable) - unless (or (null doc) (stringp doc)) - collect (list s doc)) + for doc = (documentation s 'variable) + unless (or (null doc) (stringp doc)) + collect (list s doc)) nil) ;;; Defining new methods for DOCUMENTATION @@ -619,14 +619,14 @@ (defgeneric (setf documentation-test-class-1-doc-accessor) (newdoc obj)) (defclass documentation-test-class-1 () ((my-doc :accessor documentation-test-class-1-doc-accessor - :type (or null string) - :initform nil))) - + :type (or null string) + :initform nil))) + (defmethod documentation-test-class-1-doc-accessor ((obj documentation-test-class-1) ) (slot-value obj 'my-doc)) (defmethod (setf documentation-test-class-1-doc-accessor) ((newdoc string) (obj documentation-test-class-1)) (setf (slot-value obj 'my-doc) newdoc)) - + (defmethod documentation ((obj documentation-test-class-1) (doctype (eql t))) (documentation-test-class-1-doc-accessor obj)) diff --git a/ansi-tests/dolist.lsp b/ansi-tests/dolist.lsp index 269d2f7b..9d152862 100644 --- a/ansi-tests/dolist.lsp +++ b/ansi-tests/dolist.lsp @@ -24,18 +24,18 @@ (deftest dolist.4 (let ((y nil)) (flet ((%f () (locally (declare (special e)) - (push e y)))) + (push e y)))) (dolist (e '(a b c) (reverse y)) - (declare (special e)) - (%f)))) + (declare (special e)) + (%f)))) (a b c)) ;;; Tests that it's a tagbody (deftest dolist.5 (let ((even nil) - (odd nil)) + (odd nil)) (dolist (i '(1 2 3 4 5 6 7 8) (values (reverse even) - (reverse odd))) + (reverse odd))) (when (evenp i) (go even)) (push i odd) (go done) @@ -51,7 +51,7 @@ (declare (special i)) (flet ((%f () i)) (dolist (i '(1 2 3 4)) - (push (%f) y))) + (push (%f) y))) y) (0 0 0 0)) @@ -71,15 +71,15 @@ (deftest dolist.9 (block nil (eqlt (dolist (x '(a b c)) - (return 1)) - 1)) + (return 1)) + 1)) t) (deftest dolist.10 (block nil (eqlt (dolist (x '(a b c)) - (return-from nil 1)) - 1)) + (return-from nil 1)) + 1)) t) (deftest dolist.11 @@ -119,8 +119,8 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (dolist (e (return-from done x)) - (declare (special x)))))) + (dolist (e (return-from done x)) + (declare (special x)))))) :good) (deftest dolist.17 @@ -128,7 +128,7 @@ (declare (special x)) (let ((x :bad)) (dolist (e nil x) - (declare (special x))))) + (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms diff --git a/ansi-tests/dostar.lsp b/ansi-tests/dostar.lsp index 221799da..883cf56a 100644 --- a/ansi-tests/dostar.lsp +++ b/ansi-tests/dostar.lsp @@ -20,14 +20,14 @@ (deftest do*.3 (let ((x nil)) (do* ((i 0 (1+ i))) - ((>= i 10) x) + ((>= i 10) x) (push i x))) (9 8 7 6 5 4 3 2 1 0)) (deftest do*.4 (let ((x nil)) (do* ((i 0 (1+ i))) - ((>= i 10) x) + ((>= i 10) x) (declare (fixnum i)) (push i x))) (9 8 7 6 5 4 3 2 1 0)) @@ -49,7 +49,7 @@ (deftest do*.7 (let ((x nil)) (do* ((i 0 (1+ i))) - ((>= i 10) x) + ((>= i 10) x) (go around) small (push 'a x) @@ -74,7 +74,7 @@ (deftest do*.9 (let ((i 0)) (do* () - ((>= i 10) i) + ((>= i 10) i) (incf i))) 10) @@ -104,21 +104,21 @@ (deftest do*.14 (let ((x 0)) (flet ((%f () (locally (declare (special i)) - (incf x i)))) + (incf x i)))) (do* ((i 0 (1+ i))) - ((>= i 10) x) - (declare (special i)) - (%f)))) + ((>= i 10) x) + (declare (special i)) + (%f)))) 45) ;;; Confirm that the variables in succesive iterations are ;;; identical (deftest do*.15 (mapcar #'funcall - (let ((x nil)) - (do* ((i 0 (1+ i))) - ((= i 5) x) - (push #'(lambda () i) x)))) + (let ((x nil)) + (do* ((i 0 (1+ i))) + ((= i 5) x) + (push #'(lambda () i) x)))) (5 5 5 5 5)) ;;; Scope of free declarations @@ -128,9 +128,9 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (do* ((i (return-from done x) 0)) - (t nil) - (declare (special x)))))) + (do* ((i (return-from done x) 0)) + (t nil) + (declare (special x)))))) :good) (deftest do*.17 @@ -138,9 +138,9 @@ (let ((x :good)) (declare (special x)) (let ((x :bad)) - (do* ((i 0 (return-from done x))) - (nil nil) - (declare (special x)))))) + (do* ((i 0 (return-from done x))) + (nil nil) + (declare (special x)))))) :good) (deftest do*.18 @@ -148,9 +148,9 @@ (let ((x :good)) (declare (special x)) (let ((x :bad)) - (do* ((i 0 0)) - ((return-from done x) nil) - (declare (special x)))))) + (do* ((i 0 0)) + ((return-from done x) nil) + (declare (special x)))))) :good) (deftest do*.19 @@ -158,7 +158,7 @@ (declare (special x)) (let ((x :bad)) (do* () (t x) - (declare (special x))))) + (declare (special x))))) :good) ;;; Test that explicit calls to macroexpand in subforms @@ -169,8 +169,8 @@ (macrolet ((%m (z) z)) (do* ((x (expand-in-current-env (%m 1)) (1+ x))) - ((> x 10) result) - (incf result x)))) + ((> x 10) result) + (incf result x)))) 55) (deftest do*.21 @@ -178,8 +178,8 @@ (macrolet ((%m (z) z)) (do* ((x 1 (expand-in-current-env (%m (1+ x))))) - ((> x 10) result) - (incf result x)))) + ((> x 10) result) + (incf result x)))) 55) (deftest do*.22 @@ -187,8 +187,8 @@ (macrolet ((%m (z) z)) (do* ((x 1 (1+ x))) - ((expand-in-current-env (%m (> x 10))) result) - (incf result x)))) + ((expand-in-current-env (%m (> x 10))) result) + (incf result x)))) 55) (deftest do*.23 @@ -196,8 +196,8 @@ (macrolet ((%m (z) z)) (do* ((x 1 (1+ x))) - ((> x 10) (expand-in-current-env (%m result))) - (incf result x)))) + ((> x 10) (expand-in-current-env (%m result))) + (incf result x)))) 55) (def-macro-test do*.error.1 diff --git a/ansi-tests/dotimes.lsp b/ansi-tests/dotimes.lsp index c6d9c703..8d606a5a 100644 --- a/ansi-tests/dotimes.lsp +++ b/ansi-tests/dotimes.lsp @@ -72,9 +72,9 @@ ;;; Check there's an implicit tagbody (deftest dotimes.12 (let ((even nil) - (odd nil)) + (odd nil)) (dotimes (i 8 (values (reverse even) - (reverse odd))) + (reverse odd))) (when (evenp i) (go even)) (push i odd) (go done) @@ -118,7 +118,7 @@ (declare (special i)) (flet ((%f () i)) (dotimes (i 4) - (push (%f) y))) + (push (%f) y))) y) (0 0 0 0)) @@ -127,7 +127,7 @@ (declare (special i)) (flet ((%f () i)) (dotimes (i bound) - (push (%f) y))) + (push (%f) y))) y) (0 0 0 0)) @@ -136,8 +136,8 @@ (declare (special i)) (flet ((%f () i)) (dotimes (i 4) - (declare (special i)) - (push (%f) y))) + (declare (special i)) + (push (%f) y))) y) (3 2 1 0)) @@ -146,8 +146,8 @@ (declare (special i)) (flet ((%f () i)) (dotimes (i bound) - (declare (special i)) - (push (%f) y))) + (declare (special i)) + (push (%f) y))) y) (3 2 1 0)) @@ -173,8 +173,8 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (dotimes (i (return-from done x)) - (declare (special x)))))) + (dotimes (i (return-from done x)) + (declare (special x)))))) :good) (deftest dotimes.23 @@ -182,7 +182,7 @@ (declare (special x)) (let ((x :bad)) (dotimes (i 10 x) - (declare (special x))))) + (declare (special x))))) :good) (deftest dotimes.23a @@ -190,7 +190,7 @@ (declare (special x)) (let ((x :bad)) (dotimes (i bound x) - (declare (special x))))) + (declare (special x))))) :good) (deftest dotimes.24 diff --git a/ansi-tests/dpb.lsp b/ansi-tests/dpb.lsp index b0b31f5e..432af380 100644 --- a/ansi-tests/dpb.lsp +++ b/ansi-tests/dpb.lsp @@ -27,58 +27,58 @@ (deftest dpb.1 (loop for pos = (random 32) - for size = (random 32) - for newbyte = (random (ash 1 (+ pos size))) - for val = (random (1+ (random (ash 1 (+ pos size))))) - for result = (dpb newbyte (byte size pos) val) - repeat 100 - unless - (loop for i from 0 to (+ pos size) - always (if (or (< i pos) - (>= i (+ pos size))) - (if (logbitp i val) (logbitp i result) - (not (logbitp i result))) - (if (logbitp (- i pos) newbyte) (logbitp i result) - (not (logbitp i result))))) - collect (list pos size newbyte val result)) + for size = (random 32) + for newbyte = (random (ash 1 (+ pos size))) + for val = (random (1+ (random (ash 1 (+ pos size))))) + for result = (dpb newbyte (byte size pos) val) + repeat 100 + unless + (loop for i from 0 to (+ pos size) + always (if (or (< i pos) + (>= i (+ pos size))) + (if (logbitp i val) (logbitp i result) + (not (logbitp i result))) + (if (logbitp (- i pos) newbyte) (logbitp i result) + (not (logbitp i result))))) + collect (list pos size newbyte val result)) nil) (deftest dpb.2 (loop for pos = (random 1000) - for size = (random 1000) - for newbyte = (random (ash 1 (+ pos size))) - for val = (random (1+ (random (ash 1 (+ pos size))))) - for result = (dpb newbyte (byte size pos) val) - repeat 100 - unless - (loop for i from 0 to (+ pos size) - always (if (or (< i pos) - (>= i (+ pos size))) - (if (logbitp i val) (logbitp i result) - (not (logbitp i result))) - (if (logbitp (- i pos) newbyte) (logbitp i result) - (not (logbitp i result))))) - collect (list pos size newbyte val result)) + for size = (random 1000) + for newbyte = (random (ash 1 (+ pos size))) + for val = (random (1+ (random (ash 1 (+ pos size))))) + for result = (dpb newbyte (byte size pos) val) + repeat 100 + unless + (loop for i from 0 to (+ pos size) + always (if (or (< i pos) + (>= i (+ pos size))) + (if (logbitp i val) (logbitp i result) + (not (logbitp i result))) + (if (logbitp (- i pos) newbyte) (logbitp i result) + (not (logbitp i result))))) + collect (list pos size newbyte val result)) nil) (deftest dpb.3 (loop for x = (random-fixnum) - for y = (random-fixnum) - for pos = (random 32) - repeat 100 - always (= (dpb x (byte 0 pos) y) y)) + for y = (random-fixnum) + for pos = (random 32) + repeat 100 + always (= (dpb x (byte 0 pos) y) y)) t) (deftest dpb.4 (let ((bound (ash 1 200))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for pos = (random 200) - repeat 100 - always (= (dpb x (byte 0 pos) y) y))) + for y = (random-from-interval bound) + for pos = (random 200) + repeat 100 + always (= (dpb x (byte 0 pos) y) y))) t) (deftest dpb.5 (loop for i of-type fixnum from -1000 to 1000 - always (eql (dpb -1 (byte 0 0) i) i)) + always (eql (dpb -1 (byte 0 0) i) i)) t) diff --git a/ansi-tests/dynamic-extent.lsp b/ansi-tests/dynamic-extent.lsp index 147dd307..9bfc507a 100644 --- a/ansi-tests/dynamic-extent.lsp +++ b/ansi-tests/dynamic-extent.lsp @@ -30,30 +30,30 @@ (deftest dynamic-extent.5 (flet ((%f (x) (list 'a x))) (declare (dynamic-extent (function %f)) - (optimize speed (safety 0))) + (optimize speed (safety 0))) (mapcar #'%f '(1 2 3))) ((a 1) (a 2) (a 3))) (deftest dynamic-extent.6 (labels ((%f (x) (list 'a x))) (declare (dynamic-extent (function %f)) - (optimize speed (safety 0))) + (optimize speed (safety 0))) (mapcar #'%f '(1 2 3))) ((a 1) (a 2) (a 3))) (deftest dynamic-extent.7 (labels ((%f (x) (if (consp x) - (cons (%f (car x)) (%f (cdr x))) - '*))) + (cons (%f (car x)) (%f (cdr x))) + '*))) (declare (dynamic-extent (function %f)) - (optimize speed (safety 0))) + (optimize speed (safety 0))) (mapcar #'%f '((1) 2 (3 4 5)))) ((* . *) * (* * * . *))) (deftest dynamic-extent.8 (let ((x (+ most-positive-fixnum 2))) (declare (dynamic-extent x) - (optimize speed (safety 0))) + (optimize speed (safety 0))) (1- x)) #.(1+ most-positive-fixnum)) @@ -61,7 +61,7 @@ (flet ((f () (list 'a 'b))) (let ((f (list 'c 'd))) (declare (dynamic-extent (function f)) - (optimize speed (safety 0))) + (optimize speed (safety 0))) f)) (c d)) @@ -70,35 +70,35 @@ (values x (locally (declare (dynamic-extent x) (notinline length) - (optimize speed (safety 0))) - (setq x (list 'a 'b 'c 'd 'e)) - (prog1 (length x) (setq x t))) + (optimize speed (safety 0))) + (setq x (list 'a 'b 'c 'd 'e)) + (prog1 (length x) (setq x t))) x)) nil 5 t) (deftest dynamic-extent.11 (let* ((x (list 'a 'b)) - (y (cons 'c x))) + (y (cons 'c x))) (declare (dynamic-extent y) - (optimize speed (safety 0))) + (optimize speed (safety 0))) (cdr y)) (a b)) (deftest dynamic-extent.12 (let* ((contents '(1 0 0 1 1 0 1 1 0 1)) - (n (length contents))) + (n (length contents))) (loop for i from 1 to 32 - for type = `(unsigned-byte ,i) - for form1 = `(make-array '(,n) :initial-contents ',contents - :element-type ',type) - for form2 = `(let ((a ,form1)) - (declare (dynamic-extent a)) - (declare (type (simple-array ,type (,n)))) - (declare (notinline coerce)) - (declare (optimize speed (safety 0))) - (equal (coerce a 'list) ',contents)) - unless (funcall (compile nil `(lambda () ,form2))) - collect i)) + for type = `(unsigned-byte ,i) + for form1 = `(make-array '(,n) :initial-contents ',contents + :element-type ',type) + for form2 = `(let ((a ,form1)) + (declare (dynamic-extent a)) + (declare (type (simple-array ,type (,n)))) + (declare (notinline coerce)) + (declare (optimize speed (safety 0))) + (equal (coerce a 'list) ',contents)) + unless (funcall (compile nil `(lambda () ,form2))) + collect i)) nil) (deftest dynamic-extent.13 @@ -109,21 +109,21 @@ (deftest dynamic-extent.14 (let ((s (make-string 10 :initial-element #\a - :element-type 'base-char))) + :element-type 'base-char))) (declare (dynamic-extent s) (notinline every) (optimize speed (safety 0))) (notnot (every #'(lambda (c) (eql c #\a)) s))) t) (deftest dynamic-extent.15 (flet (((setf %f) (x y) (setf (car y) x))) - (declare (dynamic-extent #'(setf %f))) - :good) + (declare (dynamic-extent #'(setf %f))) + :good) :good) (deftest dynamic-extent.16 (labels (((setf %f) (x y) (setf (car y) x))) - (declare (dynamic-extent #'(setf %f))) - :good) + (declare (dynamic-extent #'(setf %f))) + :good) :good) diff --git a/ansi-tests/ecase.lsp b/ansi-tests/ecase.lsp index 26759162..8b7ed260 100644 --- a/ansi-tests/ecase.lsp +++ b/ansi-tests/ecase.lsp @@ -153,8 +153,8 @@ (block done (tagbody (ecase 'a (a (go 10) - 10 - (return-from done 'bad))) + 10 + (return-from done 'bad))) 10 (return-from done 'good))) good) @@ -166,9 +166,9 @@ (macrolet ((%m (z) z)) (ecase (expand-in-current-env (%m :b)) - (:a :bad1) - (:b :good) - (:c :bad2))) + (:a :bad1) + (:b :good) + (:c :bad2))) :good) (deftest ecase.error.1 @@ -177,10 +177,10 @@ (deftest ecase.error.2 (signals-error (funcall (macro-function 'ecase) '(ecase t)) - program-error) + program-error) t) (deftest ecase.error.3 (signals-error (funcall (macro-function 'ecase) '(ecase t) nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/echo-stream-input-stream.lsp b/ansi-tests/echo-stream-input-stream.lsp index d654cc15..bda84814 100644 --- a/ansi-tests/echo-stream-input-stream.lsp +++ b/ansi-tests/echo-stream-input-stream.lsp @@ -7,10 +7,10 @@ (deftest echo-stream-input-stream.1 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (equalt (multiple-value-list (echo-stream-input-stream s)) - (list is))) + (list is))) t) (deftest echo-stream-input-stream.error.1 @@ -19,9 +19,9 @@ (deftest echo-stream-input-stream.error.2 (signals-error (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (echo-stream-input-stream s nil)) - program-error) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) + (echo-stream-input-stream s nil)) + program-error) t) diff --git a/ansi-tests/echo-stream-output-stream.lsp b/ansi-tests/echo-stream-output-stream.lsp index 769bfc39..f8dee381 100644 --- a/ansi-tests/echo-stream-output-stream.lsp +++ b/ansi-tests/echo-stream-output-stream.lsp @@ -7,10 +7,10 @@ (deftest echo-stream-output-stream.1 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (equalt (multiple-value-list (echo-stream-output-stream s)) - (list os))) + (list os))) t) (deftest echo-stream-output-stream.error.1 @@ -19,8 +19,8 @@ (deftest echo-stream-output-stream.error.2 (signals-error (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) - (echo-stream-output-stream s nil)) - program-error) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) + (echo-stream-output-stream s nil)) + program-error) t) diff --git a/ansi-tests/elt.lsp b/ansi-tests/elt.lsp index c9f1df76..173a53d2 100644 --- a/ansi-tests/elt.lsp +++ b/ansi-tests/elt.lsp @@ -28,7 +28,7 @@ (deftest elt.3 (elt '(a b c d e) 0) a) (deftest elt.4 (elt '(a b c d e) 2) c) (deftest elt.5 (elt '(a b c d e) 4) e) -(deftest elt.5a +(deftest elt.5a (signals-error (elt '(a b c d e) -4) type-error) t) @@ -42,19 +42,19 @@ (deftest elt.7 (let* ((x (list 'a 'b 'c 'd)) - (y (setf (elt x 0) 'e))) + (y (setf (elt x 0) 'e))) (list x y)) ((e b c d) e)) (deftest elt.8 (let* ((x (list 'a 'b 'c 'd)) - (y (setf (elt x 1) 'e))) + (y (setf (elt x 1) 'e))) (list x y)) ((a e c d) e)) (deftest elt.9 (let* ((x (list 'a 'b 'c 'd)) - (y (setf (elt x 3) 'e))) + (y (setf (elt x 3) 'e))) (list x y)) ((a b c e) e)) @@ -71,8 +71,8 @@ (setf (elt x 2) 'f) (notnot-mv (every #'eq - y - (loop for c on x collect c))))) + y + (loop for c on x collect c))))) t) (deftest elt.12 @@ -84,8 +84,8 @@ (let ((x (make-int-list 100000))) (setf (elt x 80000) 'foo) (list (elt x 79999) - (elt x 80000) - (elt x 80001))) + (elt x 80000) + (elt x 80001))) (79999 foo 80001)) (deftest elt.14 @@ -134,7 +134,7 @@ (let ((i 0) x y) (values (elt (progn (setf x (incf i)) '(a b c d e)) - (progn (setf y (incf i)) 3)) + (progn (setf y (incf i)) 3)) i x y)) d 2 1 2) @@ -143,8 +143,8 @@ (let ((a (make-array 1 :initial-element (list 'a 'b 'c 'd 'e)))) (values (setf (elt (aref a (progn (setf x (incf i)) 0)) - (progn (setf y (incf i)) 3)) - (progn (setf z (incf i)) 'k)) + (progn (setf y (incf i)) 3)) + (progn (setf z (incf i)) 'k)) (aref a 0) i x y z))) k (a b c k e) 3 1 2 3) @@ -172,19 +172,19 @@ (deftest elt-v.7 (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) - (y (setf (elt x 0) 'e))) + (y (setf (elt x 0) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (e b c d e)) (deftest elt-v.8 (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) - (y (setf (elt x 1) 'e))) + (y (setf (elt x 1) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (a e c d e)) (deftest elt-v.9 (let* ((x (make-array '(4) :initial-contents (list 'a 'b 'c 'd))) - (y (setf (elt x 3) 'e))) + (y (setf (elt x 3) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (a b c e e)) @@ -211,8 +211,8 @@ (let ((x (make-int-array 100000))) (setf (elt x 80000) 'foo) (list (elt x 79999) - (elt x 80000) - (elt x 80001))) + (elt x 80000) + (elt x 80001))) (79999 foo 80001)) ;;; Adjustable arrays @@ -221,7 +221,7 @@ (signals-error (elt (make-adj-array '(0)) 0) type-error) t) -;;; (deftest elt-adj-array.2 (elt (make-adj-array '(1)) 0) nil) ;; actually undefined +;;; (deftest elt-adj-array.2 (elt (make-adj-array '(1)) 0) nil) ;; actually undefined (deftest elt-adj-array.3 (elt (make-adj-array '(5) :initial-contents '(a b c d e)) 0) @@ -241,19 +241,19 @@ (deftest elt-adj-array.7 (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) - (y (setf (elt x 0) 'e))) + (y (setf (elt x 0) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (e b c d e)) (deftest elt-adj-array.8 (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) - (y (setf (elt x 1) 'e))) + (y (setf (elt x 1) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (a e c d e)) (deftest elt-adj-array.9 (let* ((x (make-adj-array '(4) :initial-contents (list 'a 'b 'c 'd))) - (y (setf (elt x 3) 'e))) + (y (setf (elt x 3) 'e))) (list (elt x 0) (elt x 1) (elt x 2) (elt x 3) y)) (a b c e e)) @@ -280,13 +280,13 @@ (let ((x (make-int-array 100000 #'make-adj-array))) (setf (elt x 80000) 'foo) (list (elt x 79999) - (elt x 80000) - (elt x 80001))) + (elt x 80000) + (elt x 80001))) (79999 foo 80001)) ;; displaced arrays -(deftest elt-displaced-array.1 +(deftest elt-displaced-array.1 (signals-error (elt (make-displaced-array '(0) 100) 0) type-error) t) @@ -302,23 +302,23 @@ (deftest elt-fill-pointer.1 (let ((a (make-array '(5) :initial-contents '(a b c d e) - :fill-pointer 3))) + :fill-pointer 3))) (values (elt a 0) (elt a 1) (elt a 2))) a b c) (deftest elt-fill-pointer.2 (let ((a (make-array '(5) - :initial-contents '(0 0 1 0 0) - :element-type 'bit - :fill-pointer 3))) + :initial-contents '(0 0 1 0 0) + :element-type 'bit + :fill-pointer 3))) (values (elt a 0) (elt a 1) (elt a 2))) 0 0 1) (deftest elt-fill-pointer.3 (signals-error (let ((a (make-array '(5) - :initial-contents '(0 0 1 0 0) - :fill-pointer 3))) + :initial-contents '(0 0 1 0 0) + :fill-pointer 3))) (elt a 4)) type-error) t) @@ -326,45 +326,45 @@ (deftest elt-fill-pointer.4 (signals-error (let ((a (make-array '(5) - :initial-contents '(0 0 1 0 0) - :element-type 'bit - :fill-pointer 3))) + :initial-contents '(0 0 1 0 0) + :element-type 'bit + :fill-pointer 3))) (elt a 4)) type-error) t) (deftest elt-fill-pointer.5 (let ((a (make-array '(5) - :initial-contents '(#\a #\b #\c #\d #\e) - :element-type 'character - :fill-pointer 3))) + :initial-contents '(#\a #\b #\c #\d #\e) + :element-type 'character + :fill-pointer 3))) (values (elt a 0) (elt a 1) (elt a 2))) #\a #\b #\c) (deftest elt-fill-pointer.6 (signals-error (let ((a (make-array '(5) - :initial-contents '(#\a #\b #\c #\d #\e) - :element-type 'character - :fill-pointer 3))) + :initial-contents '(#\a #\b #\c #\d #\e) + :element-type 'character + :fill-pointer 3))) (elt a 4)) type-error) t) (deftest elt-fill-pointer.7 (let ((a (make-array '(5) - :initial-contents '(#\a #\b #\c #\d #\e) - :element-type 'base-char - :fill-pointer 3))) + :initial-contents '(#\a #\b #\c #\d #\e) + :element-type 'base-char + :fill-pointer 3))) (values (elt a 0) (elt a 1) (elt a 2))) #\a #\b #\c) (deftest elt-fill-pointer.8 (signals-error (let ((a (make-array '(5) - :initial-contents '(#\a #\b #\c #\d #\e) - :element-type 'base-char - :fill-pointer 3))) + :initial-contents '(#\a #\b #\c #\d #\e) + :element-type 'base-char + :fill-pointer 3))) (elt a 4)) type-error) t) @@ -405,25 +405,25 @@ (deftest elt.special-vectors.3 (loop for type in '(short-float single-float long-float double-float) - for len = 10 - for vals = (loop for i from 1 to len collect (coerce i type)) - for vec = (make-array len :element-type type :initial-contents vals) - unless (loop for i below len always (eql (elt vec i) - (coerce (1+ i) type))) - collect (list type vals vec)) + for len = 10 + for vals = (loop for i from 1 to len collect (coerce i type)) + for vec = (make-array len :element-type type :initial-contents vals) + unless (loop for i below len always (eql (elt vec i) + (coerce (1+ i) type))) + collect (list type vals vec)) nil) (deftest elt.special-vectors.4 (loop for etype in '(short-float single-float long-float double-float - integer rational) - for type = `(complex ,etype) - for len = 10 - for vals = (loop for i from 1 to len collect (complex (coerce i etype) - (coerce (- i) etype))) - for vec = (make-array len :element-type type :initial-contents vals) - unless (loop for i below len always (eql (elt vec i) - (elt vals i))) - collect (list type vals vec)) + integer rational) + for type = `(complex ,etype) + for len = 10 + for vals = (loop for i from 1 to len collect (complex (coerce i etype) + (coerce (- i) etype))) + for vec = (make-array len :element-type type :initial-contents vals) + unless (loop for i below len always (eql (elt vec i) + (elt vals i))) + collect (list type vals vec)) nil) diff --git a/ansi-tests/encode-universal-time.lsp b/ansi-tests/encode-universal-time.lsp index 1d1678b7..f290db12 100644 --- a/ansi-tests/encode-universal-time.lsp +++ b/ansi-tests/encode-universal-time.lsp @@ -9,86 +9,86 @@ (deftest encode-universal-time.1 (loop with count = 0 - for year = (+ 1900 (random 1000)) - ;; Gregorian leap year algorithm - for leap? = (and (= (mod year 4) 0) - (or (/= (mod year 100) 0) - (= (mod year 400) 0))) - for month = (1+ (random 12)) - for date = (1+ (random (elt (if leap? - #(0 31 29 31 30 31 30 31 31 30 31 30 31) - #(0 31 28 31 30 31 30 31 31 30 31 30 31)) - month))) - for hour = (random 24) - for minute = (random 60) - for second = (random 60) - for tz = (if (and (= year 1900) (= date 0) (= month 0)) - (random 25) - (- (random 49) 24)) - for time = (encode-universal-time second minute hour date month year tz) - for decoded-vals = (multiple-value-list (decode-universal-time time tz)) - for vals = (list second minute hour date month year (elt decoded-vals 6) - nil tz) - repeat 20000 - unless (equal vals decoded-vals) - collect (progn (incf count) (list vals time decoded-vals)) - until (>= count 100)) + for year = (+ 1900 (random 1000)) + ;; Gregorian leap year algorithm + for leap? = (and (= (mod year 4) 0) + (or (/= (mod year 100) 0) + (= (mod year 400) 0))) + for month = (1+ (random 12)) + for date = (1+ (random (elt (if leap? + #(0 31 29 31 30 31 30 31 31 30 31 30 31) + #(0 31 28 31 30 31 30 31 31 30 31 30 31)) + month))) + for hour = (random 24) + for minute = (random 60) + for second = (random 60) + for tz = (if (and (= year 1900) (= date 0) (= month 0)) + (random 25) + (- (random 49) 24)) + for time = (encode-universal-time second minute hour date month year tz) + for decoded-vals = (multiple-value-list (decode-universal-time time tz)) + for vals = (list second minute hour date month year (elt decoded-vals 6) + nil tz) + repeat 20000 + unless (equal vals decoded-vals) + collect (progn (incf count) (list vals time decoded-vals)) + until (>= count 100)) nil) #| (deftest encode-universal-time.2 (loop with count = 0 - for year = (+ 1901 (random 1000)) - ;; Gregorian leap year algorithm - for leap? = (and (= (mod year 4) 0) - (or (/= (mod year 100) 0) - (= (mod year 400) 0))) - for month = (1+ (random 12)) - for date = (1+ (random (elt (if leap? - #(0 31 29 31 30 31 30 31 31 30 31 30 31) - #(0 31 28 31 30 31 30 31 31 30 31 30 31)) - month))) - for hour = (random 24) - for minute = (random 60) - for second = (random 60) - for time = (encode-universal-time second minute hour date month year) - for decoded-vals = (multiple-value-list (decode-universal-time time)) - for vals = (list second minute hour date month year (elt decoded-vals 6) - (elt decoded-vals 7) (elt decoded-vals 8)) - repeat 20000 - unless (equal vals decoded-vals) - collect (progn (incf count) (list vals time decoded-vals)) - until (>= count 100)) + for year = (+ 1901 (random 1000)) + ;; Gregorian leap year algorithm + for leap? = (and (= (mod year 4) 0) + (or (/= (mod year 100) 0) + (= (mod year 400) 0))) + for month = (1+ (random 12)) + for date = (1+ (random (elt (if leap? + #(0 31 29 31 30 31 30 31 31 30 31 30 31) + #(0 31 28 31 30 31 30 31 31 30 31 30 31)) + month))) + for hour = (random 24) + for minute = (random 60) + for second = (random 60) + for time = (encode-universal-time second minute hour date month year) + for decoded-vals = (multiple-value-list (decode-universal-time time)) + for vals = (list second minute hour date month year (elt decoded-vals 6) + (elt decoded-vals 7) (elt decoded-vals 8)) + repeat 20000 + unless (equal vals decoded-vals) + collect (progn (incf count) (list vals time decoded-vals)) + until (>= count 100)) nil) |# (deftest encode-universal-time.3 (loop with count = 0 - for year = (+ 1900 (random 1000)) - ;; Gregorian leap year algorithm - for leap? = (and (= (mod year 4) 0) - (or (/= (mod year 100) 0) - (= (mod year 400) 0))) - for month = (1+ (random 12)) - for date = (1+ (random (elt (if leap? - #(0 31 29 31 30 31 30 31 31 30 31 30 31) - #(0 31 28 31 30 31 30 31 31 30 31 30 31)) - month))) - for hour = (random 24) - for minute = (random 60) - for second = (random 60) - for tz = (/ (if (and (= year 1900) (= date 0) (= month 0)) - (random (1+ (* 24 3600))) - (- (random (1+ (* 48 3600))) (* 24 3600))) - 3600) - for time = (encode-universal-time second minute hour date month year tz) - for decoded-vals = (multiple-value-list (decode-universal-time time tz)) - for vals = (list second minute hour date month year (elt decoded-vals 6) - nil tz) - repeat 20000 - unless (equal vals decoded-vals) - collect (progn (incf count) (list vals time decoded-vals)) - until (>= count 100)) + for year = (+ 1900 (random 1000)) + ;; Gregorian leap year algorithm + for leap? = (and (= (mod year 4) 0) + (or (/= (mod year 100) 0) + (= (mod year 400) 0))) + for month = (1+ (random 12)) + for date = (1+ (random (elt (if leap? + #(0 31 29 31 30 31 30 31 31 30 31 30 31) + #(0 31 28 31 30 31 30 31 31 30 31 30 31)) + month))) + for hour = (random 24) + for minute = (random 60) + for second = (random 60) + for tz = (/ (if (and (= year 1900) (= date 0) (= month 0)) + (random (1+ (* 24 3600))) + (- (random (1+ (* 48 3600))) (* 24 3600))) + 3600) + for time = (encode-universal-time second minute hour date month year tz) + for decoded-vals = (multiple-value-list (decode-universal-time time tz)) + for vals = (list second minute hour date month year (elt decoded-vals 6) + nil tz) + repeat 20000 + unless (equal vals decoded-vals) + collect (progn (incf count) (list vals time decoded-vals)) + until (>= count 100)) nil) ;;; Error cases diff --git a/ansi-tests/enough-namestring.lsp b/ansi-tests/enough-namestring.lsp index 33825b88..885b1dcb 100644 --- a/ansi-tests/enough-namestring.lsp +++ b/ansi-tests/enough-namestring.lsp @@ -7,11 +7,11 @@ (deftest enough-namestring.1 (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp"))) - (s (first vals))) + (s (first vals))) (if (and (null (cdr vals)) - (stringp s) - (equal (enough-namestring s) s)) - :good + (stringp s) + (equal (enough-namestring s) s)) + :good vals)) :good) @@ -25,39 +25,39 @@ (deftest enough-namestring.3 (let* ((name "enough-namestring.lsp") - (pn (merge-pathnames (pathname name))) - (name2 (enough-namestring pn)) - (name3 (enough-namestring name))) + (pn (merge-pathnames (pathname name))) + (name2 (enough-namestring pn)) + (name3 (enough-namestring name))) (or (equalt name2 name3) (list name2 name3))) t) (deftest enough-namestring.4 (let* ((name "enough-namestring.lsp") - (pn (merge-pathnames (pathname name))) - (name2 (with-open-file (s pn :direction :input) (enough-namestring s))) - (name3 (enough-namestring name))) + (pn (merge-pathnames (pathname name))) + (name2 (with-open-file (s pn :direction :input) (enough-namestring s))) + (name3 (enough-namestring name))) (or (equalt name2 name3) (list name2 name3))) t) (deftest enough-namestring.5 (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp" - *default-pathname-defaults*))) - (s (first vals))) + *default-pathname-defaults*))) + (s (first vals))) (if (and (null (cdr vals)) - (stringp s) - (equal (enough-namestring s) s)) - :good + (stringp s) + (equal (enough-namestring s) s)) + :good vals)) :good) (deftest enough-namestring.6 (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp" - (namestring *default-pathname-defaults*)))) - (s (first vals))) + (namestring *default-pathname-defaults*)))) + (s (first vals))) (if (and (null (cdr vals)) - (stringp s) - (equal (enough-namestring s) s)) - :good + (stringp s) + (equal (enough-namestring s) s)) + :good vals)) :good) @@ -65,7 +65,7 @@ (do-special-strings (s (namestring *default-pathname-defaults*) nil) (let* ((vals (multiple-value-list (enough-namestring "enough-namestring.lsp" s))) - (s2 (first vals))) + (s2 (first vals))) (assert (null (cdr vals))) (assert (stringp s2)) (assert (equal (enough-namestring s2) s2)))) diff --git a/ansi-tests/ensure-directories-exist.lsp b/ansi-tests/ensure-directories-exist.lsp index 73ab50c8..5ed7dc78 100644 --- a/ansi-tests/ensure-directories-exist.lsp +++ b/ansi-tests/ensure-directories-exist.lsp @@ -7,12 +7,12 @@ (deftest ensure-directories-exist.1 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" - :defaults *default-pathname-defaults*)) - (results nil) - (verbosity - (with-output-to-string - (*standard-output*) - (setq results (multiple-value-list (ensure-directories-exist pn)))))) + :defaults *default-pathname-defaults*)) + (results nil) + (verbosity + (with-output-to-string + (*standard-output*) + (setq results (multiple-value-list (ensure-directories-exist pn)))))) (values (length results) (equalt (truename pn) (truename (first results))) @@ -42,13 +42,13 @@ (deftest ensure-directories-exist.4 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" - :defaults *default-pathname-defaults*)) - (results nil) - (verbosity - (with-output-to-string - (*standard-output*) - (setq results (multiple-value-list - (ensure-directories-exist pn :verbose nil)))))) + :defaults *default-pathname-defaults*)) + (results nil) + (verbosity + (with-output-to-string + (*standard-output*) + (setq results (multiple-value-list + (ensure-directories-exist pn :verbose nil)))))) (values (length results) (equalt (truename pn) (truename (first results))) @@ -58,13 +58,13 @@ (deftest ensure-directories-exist.5 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" - :defaults *default-pathname-defaults*)) - (results nil) - (verbosity - (with-output-to-string - (*standard-output*) - (setq results (multiple-value-list - (ensure-directories-exist pn :verbose t)))))) + :defaults *default-pathname-defaults*)) + (results nil) + (verbosity + (with-output-to-string + (*standard-output*) + (setq results (multiple-value-list + (ensure-directories-exist pn :verbose t)))))) (values (length results) (equalt (truename pn) (truename (first results))) @@ -74,14 +74,14 @@ (deftest ensure-directories-exist.6 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" - :defaults *default-pathname-defaults*)) - (results nil) - (verbosity - (with-output-to-string - (*standard-output*) - (setq results (multiple-value-list - (ensure-directories-exist - pn :allow-other-keys nil)))))) + :defaults *default-pathname-defaults*)) + (results nil) + (verbosity + (with-output-to-string + (*standard-output*) + (setq results (multiple-value-list + (ensure-directories-exist + pn :allow-other-keys nil)))))) (values (length results) (equalt (truename pn) (truename (first results))) @@ -91,14 +91,14 @@ (deftest ensure-directories-exist.7 (let* ((pn (make-pathname :name "ensure-directories-exist.lsp" - :defaults *default-pathname-defaults*)) - (results nil) - (verbosity - (with-output-to-string - (*standard-output*) - (setq results (multiple-value-list - (ensure-directories-exist - pn :allow-other-keys t :nonsense t)))))) + :defaults *default-pathname-defaults*)) + (results nil) + (verbosity + (with-output-to-string + (*standard-output*) + (setq results (multiple-value-list + (ensure-directories-exist + pn :allow-other-keys t :nonsense t)))))) (values (length results) (equalt (truename pn) (truename (first results))) @@ -112,23 +112,23 @@ ;; test is run (deftest ensure-directories-exist.8 (let* ((subdir (make-pathname :directory '(:relative "scratch") - :defaults *default-pathname-defaults*)) - (pn (make-pathname :name "foo" :type "txt" - :defaults subdir))) + :defaults *default-pathname-defaults*)) + (pn (make-pathname :name "foo" :type "txt" + :defaults subdir))) (assert (not (probe-file pn)) () - "Delete subdirectory scratch and its contents!") + "Delete subdirectory scratch and its contents!") (let* ((results nil) - (verbosity - (with-output-to-string - (*standard-output*) - (setq results (multiple-value-list (ensure-directories-exist pn))))) - (result-pn (first results)) - (created (second results))) + (verbosity + (with-output-to-string + (*standard-output*) + (setq results (multiple-value-list (ensure-directories-exist pn))))) + (result-pn (first results)) + (created (second results))) ;; Create the file and write to it (with-open-file (*standard-output* - pn :direction :output :if-exists :error - :if-does-not-exist :create) - (print nil)) + pn :direction :output :if-exists :error + :if-does-not-exist :create) + (print nil)) (values (length results) (notnot created) @@ -156,7 +156,7 @@ (signals-error-always (ensure-directories-exist (make-pathname :directory '(:relative :wild) - :defaults *default-pathname-defaults*)) + :defaults *default-pathname-defaults*)) file-error) t t) diff --git a/ansi-tests/ensure-generic-function.lsp b/ansi-tests/ensure-generic-function.lsp index 0fa7304e..d1c06617 100644 --- a/ansi-tests/ensure-generic-function.lsp +++ b/ansi-tests/ensure-generic-function.lsp @@ -35,11 +35,11 @@ (values (fboundp f) (notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c)) - 'generic-function)) + 'generic-function)) ;; Test of incongruent generic function lambda list when no ;; methods exist (notnot-mv (typep (ensure-generic-function f :lambda-list '(x y)) - 'generic-function)) + 'generic-function)) (notnot-mv (typep (symbol-function f) 'generic-function)))) nil t t t) @@ -49,22 +49,22 @@ (values (fboundp f) (notnot-mv (typep (ensure-generic-function f :lambda-list '(a b c)) - 'generic-function)) + 'generic-function)) (notnot-mv (eval `(defmethod ,f ((a t)(b t)(c t)) (list a b c)))) ;; Test of incongruent generic function lambda list when no ;; methods exist (eval `(signals-error (ensure-generic-function ',f :lambda-list '(x y)) - error)))) + error)))) nil t t t) (deftest ensure-generic-function.7 (let ((f 'egf-fun-7)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) - (:method ((x symbol)) (list x :a)) - (:method ((x integer)) (list x :b)) - (:method ((x t)) (list x :c)))))) + (:method ((x symbol)) (list x :a)) + (:method ((x integer)) (list x :b)) + (:method ((x t)) (list x :c)))))) (values (mapcar fn '(x 2 3/2)) (eqlt fn (ensure-generic-function f :lambda-list '(x))) @@ -77,12 +77,12 @@ (let ((f 'egf-fun-8)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x y) - (:method ((x t) (y symbol)) 1) - (:method ((x symbol) (y t)) 2))))) + (:method ((x t) (y symbol)) 1) + (:method ((x symbol) (y t)) 2))))) (values (mapcar fn '(a a 3) '(b 4 b)) (eqlt fn (ensure-generic-function f :lambda-list '(x y) - :argument-precedence-order '(y x))) + :argument-precedence-order '(y x))) (mapcar fn '(a a 3) '(b 4 b))))) (2 2 1) t @@ -92,21 +92,21 @@ (let ((f 'egf-fun-9)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) - (:method-combination +) - (:method + ((x t)) 1) - (:method + ((x symbol)) 2) - (:method + ((x (eql nil))) 4))))) + (:method-combination +) + (:method + ((x t)) 1) + (:method + ((x symbol)) 2) + (:method + ((x (eql nil))) 4))))) (values (mapcar fn '(3/2 a nil)) (eqlt fn (ensure-generic-function f :lambda-list '(x) - :method-class 'standard-method)) + :method-class 'standard-method)) (mapcar fn '(3/2 a nil)) (eqlt fn (ensure-generic-function f :lambda-list '(x) - :method-class - (find-class 'standard-method))) + :method-class + (find-class 'standard-method))) (mapcar fn '(3/2 a nil))))) - - + + (1 3 7) t (1 3 7) @@ -117,16 +117,16 @@ (let ((f 'egf-fun-10)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) - (:method ((x t)) 1))))) + (:method ((x t)) 1))))) (values (funcall fn 'a) (eqlt fn (ensure-generic-function f :lambda-list '(x) - :generic-function-class - 'standard-generic-function)) + :generic-function-class + 'standard-generic-function)) (funcall fn 'a) (eqlt fn (ensure-generic-function f :lambda-list '(x) - :generic-function-class - (find-class 'standard-generic-function))) + :generic-function-class + (find-class 'standard-generic-function))) (funcall fn 'a)))) 1 t 1 t 1) @@ -134,13 +134,13 @@ (let ((f 'egf-fun-11)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) - (:method ((x t)) 1))))) + (:method ((x t)) 1))))) (values (funcall fn 'a) (eqlt fn (eval `(macrolet ((%m (&environment env) - (ensure-generic-function ',f :lambda-list '(x) - :environment env))) - (%m)))) + (ensure-generic-function ',f :lambda-list '(x) + :environment env))) + (%m)))) (funcall fn 'a)))) 1 t 1) @@ -148,8 +148,8 @@ (let ((f 'egf-fun-12)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x) - (:documentation "foo") - (:method ((x t)) 1))))) + (:documentation "foo") + (:method ((x t)) 1))))) (values (funcall fn 'a) (or (documentation f 'function) "foo") @@ -162,12 +162,12 @@ (let ((f 'egf-fun-13)) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (x y) - (declare (optimize safety (speed 0) (debug 0) (space 0))) - (:method ((x t) (y t)) (list x y)))))) + (declare (optimize safety (speed 0) (debug 0) (space 0))) + (:method ((x t) (y t)) (list x y)))))) (values (funcall fn 'a 'b) (eqlt fn (ensure-generic-function f :lambda-list '(x y) - :declare '((optimize (safety 0) (debug 2) speed (space 1))))) + :declare '((optimize (safety 0) (debug 2) speed (space 1))))) (funcall fn 'a 1)))) (a b) t (a 1)) @@ -175,15 +175,15 @@ (let ((f '(setf egf-fun-14))) (when (fboundp f) (fmakunbound f)) (let ((fn (eval `(defgeneric ,f (val x) - (:method ((val t) (x cons)) (setf (car x) val)))))) + (:method ((val t) (x cons)) (setf (car x) val)))))) (values (let ((z (cons 'a 'b))) - (list (setf (egf-fun-14 z) 'c) z)) + (list (setf (egf-fun-14 z) 'c) z)) (eqlt fn (ensure-generic-function f :lambda-list '(val x))) (let ((z (cons 'a 'b))) - (list (setf (egf-fun-14 z) 'c) z))))) - (c (c . b)) t (c (c . b))) - + (list (setf (egf-fun-14 z) 'c) z))))) + (c (c . b)) t (c (c . b))) + ;;; Many more tests are needed for other combinations of keyword parameters (deftest ensure-generic-function.error.1 diff --git a/ansi-tests/environment-functions.lsp b/ansi-tests/environment-functions.lsp index 6ac73648..4958fab3 100644 --- a/ansi-tests/environment-functions.lsp +++ b/ansi-tests/environment-functions.lsp @@ -7,16 +7,16 @@ (defmacro def-env-tests (fn-name) (flet ((%name (suffix) (intern (concatenate 'string (symbol-name fn-name) suffix) - (find-package :cl-test)))) + (find-package :cl-test)))) `(progn (deftest ,(%name ".1") - (let ((x (,fn-name))) - (or (not x) - (notnot (stringp x)))) - t) + (let ((x (,fn-name))) + (or (not x) + (notnot (stringp x)))) + t) (deftest ,(%name ".ERROR.1") - (signals-error (,fn-name nil) program-error) - t)))) + (signals-error (,fn-name nil) program-error) + t)))) (def-env-tests lisp-implementation-type) (def-env-tests lisp-implementation-version) diff --git a/ansi-tests/epsilons.lsp b/ansi-tests/epsilons.lsp index 4d497ad1..143dab83 100644 --- a/ansi-tests/epsilons.lsp +++ b/ansi-tests/epsilons.lsp @@ -9,118 +9,118 @@ (deftest epsilons.1 (loop for e in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - when (= (float 1 e) (+ (float 1 e) e)) - collect e) + double-float-epsilon long-float-epsilon) + when (= (float 1 e) (+ (float 1 e) e)) + collect e) nil) (deftest epsilons.2 (loop for e in (list short-float-negative-epsilon - single-float-negative-epsilon - double-float-negative-epsilon - long-float-negative-epsilon) - when (= (float 1 e) (- (float 1 e) e)) - collect e) + single-float-negative-epsilon + double-float-negative-epsilon + long-float-negative-epsilon) + when (= (float 1 e) (- (float 1 e) e)) + collect e) nil) (deftest epsilons.3 (loop for e in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - unless (= (float 1 e) (+ (float 1 e) (/ e 2))) - collect e) + double-float-epsilon long-float-epsilon) + unless (= (float 1 e) (+ (float 1 e) (/ e 2))) + collect e) nil) (deftest epsilons.4 (loop for e in (list short-float-negative-epsilon - single-float-negative-epsilon - double-float-negative-epsilon - long-float-negative-epsilon) - unless (= (float 1 e) (- (float 1 e) (/ e 2))) - collect e) + single-float-negative-epsilon + double-float-negative-epsilon + long-float-negative-epsilon) + unless (= (float 1 e) (- (float 1 e) (/ e 2))) + collect e) nil) (deftest epsilons.5 (loop for (type var) in - '( - (short-float short-float-epsilon) - (short-float short-float-negative-epsilon) - (single-float single-float-epsilon) - (single-float single-float-negative-epsilon) - (double-float double-float-epsilon) - (double-float double-float-negative-epsilon) - (long-float long-float-epsilon) - (long-float long-float-negative-epsilon)) - for val = (symbol-value var) - unless (typep val type) - collect (list type var val)) + '( + (short-float short-float-epsilon) + (short-float short-float-negative-epsilon) + (single-float single-float-epsilon) + (single-float single-float-negative-epsilon) + (double-float double-float-epsilon) + (double-float double-float-negative-epsilon) + (long-float long-float-epsilon) + (long-float long-float-negative-epsilon)) + for val = (symbol-value var) + unless (typep val type) + collect (list type var val)) nil) (deftest epsilons.6 (flet ((%check (x) (/= 1.0s0 (+ 1.0s0 x)))) (let ((eps (float-binary-search #'%check 0.0s0 1.0s0))) (if (= eps short-float-epsilon) - :good - (list eps short-float-epsilon)))) + :good + (list eps short-float-epsilon)))) :good) (deftest epsilons.7 (flet ((%check (x) (/= 1.0f0 (+ 1.0f0 x)))) (let ((eps (float-binary-search #'%check 0.0f0 1.0f0))) (if (= eps single-float-epsilon) - :good - (list eps single-float-epsilon)))) + :good + (list eps single-float-epsilon)))) :good) (deftest epsilons.8 (flet ((%check (x) (/= 1.0d0 (+ 1.0d0 x)))) (let ((eps (float-binary-search #'%check 0.0d0 1.0d0))) (if (= eps double-float-epsilon) - :good - (list eps double-float-epsilon)))) + :good + (list eps double-float-epsilon)))) :good) (deftest epsilons.9 (flet ((%check (x) (/= 1.0l0 (+ 1.0l0 x)))) (let ((eps (float-binary-search #'%check 0.0l0 1.0l0))) (if (= eps long-float-epsilon) - :good - (list eps long-float-epsilon)))) + :good + (list eps long-float-epsilon)))) :good) (deftest epsilons.10 (flet ((%check (x) (/= 1.0s0 (- 1.0s0 x)))) (let ((eps (float-binary-search #'%check 0.0s0 1.0s0))) (if (= eps short-float-negative-epsilon) - :good - (list eps short-float-negative-epsilon)))) + :good + (list eps short-float-negative-epsilon)))) :good) (deftest epsilons.11 (flet ((%check (x) (/= 1.0f0 (- 1.0f0 x)))) (let ((eps (float-binary-search #'%check 0.0f0 1.0f0))) (if (= eps single-float-negative-epsilon) - :good - (list eps single-float-negative-epsilon)))) + :good + (list eps single-float-negative-epsilon)))) :good) (deftest epsilons.12 (flet ((%check (x) (/= 1.0d0 (- 1.0d0 x)))) (let ((eps (float-binary-search #'%check 0.0d0 1.0d0))) (if (= eps double-float-negative-epsilon) - :good - (list eps double-float-negative-epsilon)))) + :good + (list eps double-float-negative-epsilon)))) :good) (deftest epsilons.13 (flet ((%check (x) (/= 1.0l0 (- 1.0l0 x)))) (let ((eps (float-binary-search #'%check 0.0l0 1.0l0))) (if (= eps long-float-negative-epsilon) - :good - (list eps long-float-negative-epsilon)))) + :good + (list eps long-float-negative-epsilon)))) :good) - \ No newline at end of file + diff --git a/ansi-tests/equal.lsp b/ansi-tests/equal.lsp index d5cded3f..4d8bf8a1 100644 --- a/ansi-tests/equal.lsp +++ b/ansi-tests/equal.lsp @@ -7,9 +7,9 @@ (deftest equal.1 (loop for x in *symbols* - always (loop for y in *symbols* - always (if (eq x y) (equal x y) - (not (equal x y))))) + always (loop for y in *symbols* + always (if (eq x y) (equal x y) + (not (equal x y))))) t) (deftest equal.2 @@ -26,19 +26,19 @@ (deftest equal.5 (loop for c in *characters* - always (loop for d in *characters* - always (if (eql c d) (equalt c d) - (not (equalt c d))))) + always (loop for d in *characters* + always (if (eql c d) (equalt c d) + (not (equalt c d))))) t) (deftest equal.6 (equalt (make-pathname :name (copy-seq "foo")) - (make-pathname :name (copy-seq "foo"))) + (make-pathname :name (copy-seq "foo"))) t) (deftest equal.7 (equalt (make-pathname :name (copy-seq "foo")) - (make-pathname :name (copy-seq "bar"))) + (make-pathname :name (copy-seq "bar"))) nil) (deftest equal.8 @@ -64,7 +64,7 @@ (deftest equal.13 :notes (:nil-vectors-are-strings) (let ((x (make-array '(0) :element-type nil)) - (y (make-array '(0) :element-type nil))) + (y (make-array '(0) :element-type nil))) (equalt x y)) t) @@ -77,32 +77,32 @@ (deftest equal.15 (equalt (make-array '(0) :element-type 'character) - (make-array '(0) :element-type 'base-char)) + (make-array '(0) :element-type 'base-char)) t) (deftest equal.16 (equalt "abc" (make-array '(3) :element-type 'base-char - :initial-contents '(#\a #\b #\c))) + :initial-contents '(#\a #\b #\c))) t) (deftest equal.17 (let ((s (make-array '(10) :element-type 'character - :initial-contents "0123456789" - :fill-pointer 3))) + :initial-contents "0123456789" + :fill-pointer 3))) (values (equalt s "012") (equalt "012" s))) t t) (deftest equal.18 (let ((b (make-array '(10) :element-type 'bit - :initial-contents #*0110001110 - :fill-pointer 5))) + :initial-contents #*0110001110 + :fill-pointer 5))) (values (equalt #*01100 b) (equalt #*01100 b))) t t) (deftest equal.19 (let ((s (make-array '(10) :element-type 'base-char - :initial-contents "0123456789" - :fill-pointer 3))) + :initial-contents "0123456789" + :fill-pointer 3))) (values (equalt s "012") (equalt "012" s))) t t) diff --git a/ansi-tests/equalp.lsp b/ansi-tests/equalp.lsp index 9a24b4f3..4dc77596 100644 --- a/ansi-tests/equalp.lsp +++ b/ansi-tests/equalp.lsp @@ -9,16 +9,16 @@ (deftest equalp.1 (loop for c across +base-chars+ - always (loop for d across +base-chars+ - always (if (char-equal c d) (equalpt c d) - (not (equalpt c d))))) + always (loop for d across +base-chars+ + always (if (char-equal c d) (equalpt c d) + (not (equalpt c d))))) t) (deftest equalp.2 (loop for i from 1 to 100 - always (loop for j from 1 to 100 - always (if (eqlt i j) (equalpt i j) - (not (equalpt i j))))) + always (loop for j from 1 to 100 + always (if (eqlt i j) (equalpt i j) + (not (equalpt i j))))) t) (deftest equalp.3 @@ -41,37 +41,37 @@ (deftest equalp.7 (loop for nbits from 1 to 100 - for type = `(unsigned-byte ,nbits) - for bound = (ash 1 nbits) - for val = (random bound) - for a1 = (make-array nil :initial-element val :element-type type) - for a2 = (make-array nil :initial-element val) - unless (equalp a1 a2) - collect (list nbits type val)) + for type = `(unsigned-byte ,nbits) + for bound = (ash 1 nbits) + for val = (random bound) + for a1 = (make-array nil :initial-element val :element-type type) + for a2 = (make-array nil :initial-element val) + unless (equalp a1 a2) + collect (list nbits type val)) nil) (deftest equalp.8 (loop for nbits from 1 to 100 - for type = `(unsigned-byte ,nbits) - for bound = (ash 1 nbits) - for n = (1+ (random 20)) - for vals = (loop repeat n collect (random bound)) - for a1 = (make-array n :initial-contents vals :element-type type) - for a2 = (make-array n :initial-contents vals) - unless (equalp a1 a2) - collect (list nbits type vals)) + for type = `(unsigned-byte ,nbits) + for bound = (ash 1 nbits) + for n = (1+ (random 20)) + for vals = (loop repeat n collect (random bound)) + for a1 = (make-array n :initial-contents vals :element-type type) + for a2 = (make-array n :initial-contents vals) + unless (equalp a1 a2) + collect (list nbits type vals)) nil) (deftest equalp.9 (loop for nbits from 1 to 100 - for type = `(signed-byte ,nbits) - for bound = (ash 1 nbits) - for n = (1+ (random 20)) - for vals = (loop repeat n collect (- (random bound) (/ bound 2))) - for a1 = (make-array n :initial-contents vals :element-type type) - for a2 = (make-array n :initial-contents vals) - unless (equalp a1 a2) - collect (list nbits type vals)) + for type = `(signed-byte ,nbits) + for bound = (ash 1 nbits) + for n = (1+ (random 20)) + for vals = (loop repeat n collect (- (random bound) (/ bound 2))) + for a1 = (make-array n :initial-contents vals :element-type type) + for a2 = (make-array n :initial-contents vals) + unless (equalp a1 a2) + collect (list nbits type vals)) nil) (deftest equalp.10 @@ -80,8 +80,8 @@ (deftest equalp.11 (let ((v1 #(1 2 3)) - (v2 (make-array 8 :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 3))) + (v2 (make-array 8 :initial-contents '(1 2 3 4 5 6 7 8) + :fill-pointer 3))) (equalpt v1 v2)) t) @@ -95,16 +95,16 @@ (deftest equalp.14 (let ((s1 (make-array '(4) :initial-contents '(#\a #\b #\c #\d) - :element-type 'base-char)) - (s2 (make-array '(4) :initial-contents '(#\a #\b #\c #\d) - :element-type 'character))) + :element-type 'base-char)) + (s2 (make-array '(4) :initial-contents '(#\a #\b #\c #\d) + :element-type 'character))) (equalpt s1 s2)) t) (deftest equalp.15 (let ((bv (make-array '(4) :initial-contents '(0 0 1 0) - :element-type 'bit)) - (v #(0 0 1 0))) + :element-type 'bit)) + (v #(0 0 1 0))) (equalpt bv v)) t) @@ -116,81 +116,81 @@ (deftest equalp.16 (let ((s1 (make-equalp-struct-16 :a 1 :b 2 :c #\a)) - (s2 (make-equalp-struct-16 :a 1.0 :b 2.0 :c #\A)) - (s3 (make-equalp-struct-16-alt :a 1.0 :b 2.0 :c #\A))) + (s2 (make-equalp-struct-16 :a 1.0 :b 2.0 :c #\A)) + (s3 (make-equalp-struct-16-alt :a 1.0 :b 2.0 :c #\A))) (values (equalpt s1 s2) - (equalpt s1 s3) - (equalpt s2 s3))) + (equalpt s1 s3) + (equalpt s2 s3))) t nil nil) (deftest equalp.17 (loop for i below 8192 - for f = (float i 1.0s0) - repeat 1000 - unless (equalp i f) - collect (list i f)) + for f = (float i 1.0s0) + repeat 1000 + unless (equalp i f) + collect (list i f)) nil) (deftest equalp.18 (loop for i = (- (random 10000000) 5000000) - for f = (float i 1.0f0) - repeat 1000 - unless (equalp i f) - collect (list i f)) + for f = (float i 1.0f0) + repeat 1000 + unless (equalp i f) + collect (list i f)) nil) (deftest equalp.19 (loop for i = (- (random 10000000) 5000000) - for f = (float i 1.0d0) - repeat 1000 - unless (equalp i f) - collect (list i f)) + for f = (float i 1.0d0) + repeat 1000 + unless (equalp i f) + collect (list i f)) nil) (deftest equalp.20 (loop for i = (- (random 10000000) 5000000) - for f = (float i 1.0l0) - repeat 1000 - unless (equalp i f) - collect (list i f)) + for f = (float i 1.0l0) + repeat 1000 + unless (equalp i f) + collect (list i f)) nil) (deftest equalp.21 (let ((ht1 (make-hash-table :test #'eq)) - (ht2 (make-hash-table :test #'eql)) - (ht3 (make-hash-table :test #'equal)) - (ht4 (make-hash-table :test #'equalp))) + (ht2 (make-hash-table :test #'eql)) + (ht3 (make-hash-table :test #'equal)) + (ht4 (make-hash-table :test #'equalp))) (values (equalpt ht1 ht2) - (equalpt ht1 ht3) - (equalpt ht1 ht4) - (equalpt ht2 ht3) - (equalpt ht2 ht4) - (equalpt ht3 ht4))) + (equalpt ht1 ht3) + (equalpt ht1 ht4) + (equalpt ht2 ht3) + (equalpt ht2 ht4) + (equalpt ht3 ht4))) nil nil nil nil nil nil) (deftest equalp.22 (equalpt (make-hash-table :test 'eq) - (make-hash-table :test #'eq)) + (make-hash-table :test #'eq)) t) (deftest equalp.23 (equalpt (make-hash-table :test 'eql) - (make-hash-table :test #'eql)) + (make-hash-table :test #'eql)) t) (deftest equalp.24 (equalpt (make-hash-table :test 'equal) - (make-hash-table :test #'equal)) + (make-hash-table :test #'equal)) t) (deftest equalp.25 (equalpt (make-hash-table :test 'equalp) - (make-hash-table :test #'equalp)) + (make-hash-table :test #'equalp)) t) (deftest equalp.26 (let ((ht1 (make-hash-table :test #'eq)) - (ht2 (make-hash-table :test #'eq))) + (ht2 (make-hash-table :test #'eq))) (setf (gethash #\a ht1) t) (setf (gethash #\A ht2) t) (equalpt ht1 ht2)) @@ -198,7 +198,7 @@ (deftest equalp.27 (let ((ht1 (make-hash-table :test #'eq)) - (ht2 (make-hash-table :test #'eq))) + (ht2 (make-hash-table :test #'eq))) (setf (gethash 'a ht1) #\a) (setf (gethash 'a ht2) #\A) (equalpt ht1 ht2)) @@ -206,7 +206,7 @@ (deftest equalp.28 (let ((ht1 (make-hash-table :test #'eql)) - (ht2 (make-hash-table :test #'eql))) + (ht2 (make-hash-table :test #'eql))) (setf (gethash #\a ht1) t) (setf (gethash #\A ht2) t) (equalpt ht1 ht2)) @@ -214,7 +214,7 @@ (deftest equalp.29 (let ((ht1 (make-hash-table :test #'eql)) - (ht2 (make-hash-table :test #'eql))) + (ht2 (make-hash-table :test #'eql))) (setf (gethash #\a ht1) "a") (setf (gethash #\a ht2) "A") (equalpt ht1 ht2)) @@ -222,7 +222,7 @@ (deftest equalp.30 (let ((ht1 (make-hash-table :test #'equal)) - (ht2 (make-hash-table :test #'equal))) + (ht2 (make-hash-table :test #'equal))) (setf (gethash #\a ht1) t) (setf (gethash #\A ht2) t) (equalpt ht1 ht2)) @@ -230,7 +230,7 @@ (deftest equalp.31 (let ((ht1 (make-hash-table :test #'equal)) - (ht2 (make-hash-table :test #'equal))) + (ht2 (make-hash-table :test #'equal))) (setf (gethash #\a ht1) "a") (setf (gethash #\a ht2) "A") (equalpt ht1 ht2)) @@ -238,7 +238,7 @@ (deftest equalp.32 (let ((ht1 (make-hash-table :test #'equalp)) - (ht2 (make-hash-table :test #'equalp))) + (ht2 (make-hash-table :test #'equalp))) (setf (gethash #\a ht1) t) (setf (gethash #\A ht2) t) (equalpt ht1 ht2)) @@ -246,7 +246,7 @@ (deftest equalp.33 (let ((ht1 (make-hash-table :test #'equalp)) - (ht2 (make-hash-table :test #'equalp))) + (ht2 (make-hash-table :test #'equalp))) (setf (gethash #\a ht1) "a") (setf (gethash #\a ht2) "A") (equalpt ht1 ht2)) @@ -254,7 +254,7 @@ (deftest equalp.34 (let ((ht1 (make-hash-table :test #'equalp)) - (ht2 (make-hash-table :test #'equalp))) + (ht2 (make-hash-table :test #'equalp))) (setf (gethash '#:a ht1) t) (setf (gethash '#:a ht2) t) (equalpt ht1 ht2)) @@ -262,26 +262,26 @@ (deftest equalp.35 (loop for test in '(eq eql equal equalp) - collect - (flet ((%make-table - () - (apply #'make-hash-table - :test test - `(,@(when (coin) - (list :size (random 100))) - ,@(when (coin) - (list :rehash-size (1+ (random 50)))) - ,@(when (coin) - (list :rehash-threshold (random 1.0)) ))))) - (loop repeat 200 - count - (let ((ht1 (%make-table)) - (ht2 (%make-table)) - (pairs (loop for i below (random 100) collect (cons (gensym) i)))) - (loop for (k . v) in pairs do (setf (gethash k ht1) v)) - (setf pairs (random-permute pairs)) - (loop for (k . v) in pairs do (setf (gethash k ht2) v)) - (not (equalp ht1 ht2)))))) + collect + (flet ((%make-table + () + (apply #'make-hash-table + :test test + `(,@(when (coin) + (list :size (random 100))) + ,@(when (coin) + (list :rehash-size (1+ (random 50)))) + ,@(when (coin) + (list :rehash-threshold (random 1.0)) ))))) + (loop repeat 200 + count + (let ((ht1 (%make-table)) + (ht2 (%make-table)) + (pairs (loop for i below (random 100) collect (cons (gensym) i)))) + (loop for (k . v) in pairs do (setf (gethash k ht1) v)) + (setf pairs (random-permute pairs)) + (loop for (k . v) in pairs do (setf (gethash k ht2) v)) + (not (equalp ht1 ht2)))))) (0 0 0 0)) (deftest equalp.order.1 diff --git a/ansi-tests/error.lsp b/ansi-tests/error.lsp index dd3e357e..970424b6 100644 --- a/ansi-tests/error.lsp +++ b/ansi-tests/error.lsp @@ -14,7 +14,7 @@ (deftest error.2 (let* ((fmt "Error") - (cnd (make-condition 'simple-error :format-control fmt))) + (cnd (make-condition 'simple-error :format-control fmt))) (handler-case (error cnd) (simple-error (c) (frob-simple-error c fmt)))) @@ -86,7 +86,7 @@ (deftest error.12 (let* ((fmt (formatter "Error")) - (cnd (make-condition 'simple-error :format-control fmt))) + (cnd (make-condition 'simple-error :format-control fmt))) (handler-case (error cnd) (simple-error (c) (frob-simple-error c fmt)))) diff --git a/ansi-tests/etypecase.lsp b/ansi-tests/etypecase.lsp index 2b7bea5e..ceef833b 100644 --- a/ansi-tests/etypecase.lsp +++ b/ansi-tests/etypecase.lsp @@ -66,8 +66,8 @@ (tagbody (let ((x 'a)) (etypecase x (symbol (go 10) - 10 - (return 'bad)))) + 10 + (return 'bad)))) 10 (return 'good))) good) @@ -77,31 +77,31 @@ for x in '(1 a 1.3 "") collect (etypecase x (t :good) (integer :bad) (symbol :bad) - (float :bad) (string :bad))) + (float :bad) (string :bad))) (:good :good :good :good)) (deftest etypecase.15 (let* ((u (coerce *universe* 'vector)) - (len1 (length u)) - (types (coerce *cl-all-type-symbols* 'vector)) - (len2 (length types))) + (len1 (length u)) + (types (coerce *cl-all-type-symbols* 'vector)) + (len2 (length types))) (loop for n = (random 10) for my-types = (loop repeat n collect (elt types (random len2))) for val = (elt u (random len1)) for i = (position val my-types :test #'typep) for form = `(function - (lambda (x) - (handler-case - (etypecase x - ,@(loop for i from 0 for type in my-types collect `(,type ,i))) - (type-error (c) - (assert (eql x (type-error-datum c))) - (let* ((expected (type-error-expected-type c))) - (let ((equiv (check-equivalence expected - ',(cons 'or my-types)))) - (assert (null equiv) () "EQUIV = ~A" EQUIV))) - nil)))) + (lambda (x) + (handler-case + (etypecase x + ,@(loop for i from 0 for type in my-types collect `(,type ,i))) + (type-error (c) + (assert (eql x (type-error-datum c))) + (let* ((expected (type-error-expected-type c))) + (let ((equiv (check-equivalence expected + ',(cons 'or my-types)))) + (assert (null equiv) () "EQUIV = ~A" EQUIV))) + nil)))) for j = (funcall (eval form) val) repeat 200 unless (eql i j) @@ -134,17 +134,17 @@ (deftest etypecase.error.1 (signals-error (funcall (macro-function 'etypecase)) - program-error) + program-error) t) (deftest etypecase.error.2 (signals-error (funcall (macro-function 'etypecase) - '(etypecase t)) - program-error) + '(etypecase t)) + program-error) t) (deftest etypecase.error.3 (signals-error (funcall (macro-function 'etypecase) - '(etypecase t) nil nil) - program-error) + '(etypecase t) nil nil) + program-error) t) diff --git a/ansi-tests/eval-and-compile.lsp b/ansi-tests/eval-and-compile.lsp index 4580c55f..265a5425 100644 --- a/ansi-tests/eval-and-compile.lsp +++ b/ansi-tests/eval-and-compile.lsp @@ -7,7 +7,7 @@ (defparameter *eval-and-compile-fns* '(compile eval macroexpand macroexpand-1 proclaim special-operator-p - constantp)) + constantp)) (deftest eval-and-compile-fns (remove-if #'fboundp *eval-and-compile-fns*) diff --git a/ansi-tests/eval-when.lsp b/ansi-tests/eval-when.lsp index dd3d7e1c..cd347694 100644 --- a/ansi-tests/eval-when.lsp +++ b/ansi-tests/eval-when.lsp @@ -11,24 +11,24 @@ (defvar *eval-when.1-collector*) (deftest eval-when.1 - + (let ((forms nil) all (ff "generated-eval-when-test-file.lisp")) (dolist (c '(nil (:compile-toplevel))) (dolist (l '(nil (:load-toplevel))) - (dolist (x '(nil (:execute))) - (push `(eval-when (,@c ,@l ,@x) - (push '(,@c ,@l ,@x) *eval-when.1-collector*)) - forms)))) + (dolist (x '(nil (:execute))) + (push `(eval-when (,@c ,@l ,@x) + (push '(,@c ,@l ,@x) *eval-when.1-collector*)) + forms)))) (dolist (c '(nil (:compile-toplevel))) (dolist (l '(nil (:load-toplevel))) - (dolist (x '(nil (:execute))) - (push `(let () (eval-when (,@c ,@l ,@x) - (push '(let ,@c ,@l ,@x) *eval-when.1-collector*))) - forms)))) + (dolist (x '(nil (:execute))) + (push `(let () (eval-when (,@c ,@l ,@x) + (push '(let ,@c ,@l ,@x) *eval-when.1-collector*))) + forms)))) (with-open-file (o ff :direction :output :if-exists :supersede) - (dolist (f forms) - (prin1 f o) - (terpri o))) + (dolist (f forms) + (prin1 f o) + (terpri o))) (let ((*eval-when.1-collector* nil)) (load ff) (push (cons "load source" *eval-when.1-collector*) all)) @@ -42,7 +42,7 @@ (delete-file (compile-file-pathname ff)) #+clisp (delete-file (make-pathname :type "lib" :defaults ff)) (nreverse all)) - + (("load source" (:execute) (:load-toplevel :execute) (:compile-toplevel :execute) (:compile-toplevel :load-toplevel :execute) @@ -137,5 +137,5 @@ (deftest eval-when.18 (macrolet ((%m (z) z)) - (eval-when (:execute) (expand-in-current-env (%m :good)))) + (eval-when (:execute) (expand-in-current-env (%m :good)))) :good) diff --git a/ansi-tests/eval.lsp b/ansi-tests/eval.lsp index 85a6282b..44d36c8b 100644 --- a/ansi-tests/eval.lsp +++ b/ansi-tests/eval.lsp @@ -11,7 +11,7 @@ (deftest eval.2 (loop for x being the symbols of "KEYWORD" - always (eq (eval x) x)) + always (eq (eval x) x)) t) (deftest eval.3 @@ -49,10 +49,10 @@ (deftest eval.error.3 (let ((v (gensym))) (eval `(signals-error (eval (list ',v)) undefined-function - :name ,v))) + :name ,v))) t) (deftest eval.error.4 (let ((v (gensym))) (eval `(signals-error (eval ',v) unbound-variable :name ,v))) - t) \ No newline at end of file + t) diff --git a/ansi-tests/evenp.lsp b/ansi-tests/evenp.lsp index 4d4d1158..3b75ca38 100644 --- a/ansi-tests/evenp.lsp +++ b/ansi-tests/evenp.lsp @@ -21,42 +21,42 @@ (deftest evenp.1 (loop for x in *numbers* - when (integerp x) - do (evenp x)) + when (integerp x) + do (evenp x)) nil) (deftest evenp.3 - (loop for x = (random-fixnum) - repeat 10000 - when (or - (not (evenp (+ x x))) - (evenp (+ x x 1)) - (if (evenp x) - (or (evenp (1+ x)) - (evenp (1- x)) - (/= (mod x 2) 0)) - (or (not (evenp (1+ x))) - (not (evenp (1- x))) - (= (mod x 2) 0)))) - collect x) + (loop for x = (random-fixnum) + repeat 10000 + when (or + (not (evenp (+ x x))) + (evenp (+ x x 1)) + (if (evenp x) + (or (evenp (1+ x)) + (evenp (1- x)) + (/= (mod x 2) 0)) + (or (not (evenp (1+ x))) + (not (evenp (1- x))) + (= (mod x 2) 0)))) + collect x) nil) (deftest evenp.4 (let ((upper-bound 1000000000000000) - (lower-bound -1000000000000000)) + (lower-bound -1000000000000000)) (loop for x = (random-from-interval upper-bound lower-bound) - repeat 10000 - when (or - (not (evenp (+ x x))) - (evenp (+ x x 1)) - (if (evenp x) - (or (evenp (1+ x)) - (evenp (1- x)) - (/= (mod x 2) 0)) - (or (not (evenp (1+ x))) - (not (evenp (1- x))) - (= (mod x 2) 0)))) - collect x)) + repeat 10000 + when (or + (not (evenp (+ x x))) + (evenp (+ x x 1)) + (if (evenp x) + (or (evenp (1+ x)) + (evenp (1- x)) + (/= (mod x 2) 0)) + (or (not (evenp (1+ x))) + (not (evenp (1- x))) + (= (mod x 2) 0)))) + collect x)) nil) (deftest evenp.5 diff --git a/ansi-tests/every.lsp b/ansi-tests/every.lsp index 9fed1415..93e9567b 100644 --- a/ansi-tests/every.lsp +++ b/ansi-tests/every.lsp @@ -17,7 +17,7 @@ (let ((count 0)) (values (every #'(lambda (x) (incf count) (< x 10)) - '(1 2 4 13 5 1)) + '(1 2 4 13 5 1)) count)) nil 4) @@ -35,15 +35,15 @@ (deftest every.7 (notnot-mv (every #'(lambda (x y) (or x y)) - '(nil t t nil t) #(t nil t t nil nil))) + '(nil t t nil t) #(t nil t t nil nil))) t) (deftest every.8 (let ((x '(1)) - (args nil)) + (args nil)) (loop for i from 1 below (1- (min 100 call-arguments-limit)) - do (push x args) - always (apply #'every #'= args))) + do (push x args) + always (apply #'every #'= args))) t) (deftest every.9 @@ -82,61 +82,61 @@ (deftest every.17 (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) - :fill-pointer 4))) + :fill-pointer 4))) (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (every #'zerop v)))) + do (setf (fill-pointer v) j) + collect (notnot (every #'zerop v)))) (t t t t t nil nil nil nil nil)) (deftest every.18 (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 1 1 1 1 1) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (every #'zerop v))) - '(t t t t t nil nil nil nil nil))) - collect i) + for type = `(unsigned-byte ,i) + unless + (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 1 1 1 1 1) + :element-type type + :fill-pointer 4))) + (equal (loop for j from 0 to 9 + do (setf (fill-pointer v) j) + collect (notnot (every #'zerop v))) + '(t t t t t nil nil nil nil nil))) + collect i) nil) (deftest every.19 (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (every #'zerop v))) - '(t t t t t nil nil nil nil nil))) - collect i) + for type = `(signed-byte ,i) + unless + (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) + :element-type type + :fill-pointer 4))) + (equal (loop for j from 0 to 9 + do (setf (fill-pointer v) j) + collect (notnot (every #'zerop v))) + '(t t t t t nil nil nil nil nil))) + collect i) nil) (deftest every.20 (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'character - :fill-pointer 4))) + :element-type 'character + :fill-pointer 4))) (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (every #'alpha-char-p v)))) + do (setf (fill-pointer v) j) + collect (notnot (every #'alpha-char-p v)))) (t t t t t nil nil nil nil nil)) (deftest every.21 (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'base-char - :fill-pointer 4))) + :element-type 'base-char + :fill-pointer 4))) (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (every #'alpha-char-p v)))) + do (setf (fill-pointer v) j) + collect (notnot (every #'alpha-char-p v)))) (t t t t t nil nil nil nil nil)) (deftest every.22 (let ((v (make-array '(5) :initial-contents "abcde" - :element-type 'base-char))) + :element-type 'base-char))) (values (notnot (every #'alpha-char-p v)) (setf (aref v 2) #\0) @@ -147,8 +147,8 @@ (deftest every.23 (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2))) + (v2 (make-array '(4) :displaced-to v1 + :displaced-index-offset 2))) (values (every #'evenp v1) (notnot (every 'evenp v2)))) @@ -156,55 +156,55 @@ (deftest every.24 (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (not (every 'evenp v1)) - (every #'evenp v2))) - collect i) + for type = `(unsigned-byte ,i) + unless + (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) + :element-type type)) + (v2 (make-array '(4) :displaced-to v1 + :displaced-index-offset 2 + :element-type type))) + (and (not (every 'evenp v1)) + (every #'evenp v2))) + collect i) nil) (deftest every.25 (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (not (every 'evenp v1)) - (every #'evenp v2))) - collect i) + for type = `(signed-byte ,i) + unless + (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) + :element-type type)) + (v2 (make-array '(4) :displaced-to v1 + :displaced-index-offset 2 + :element-type type))) + (and (not (every 'evenp v1)) + (every #'evenp v2))) + collect i) nil) (deftest every.26 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'character - :displaced-to s1 - :displaced-index-offset i) - collect (notnot (every 'alpha-char-p s2)))) + for s2 = (make-array '(2) :element-type 'character + :displaced-to s1 + :displaced-index-offset i) + collect (notnot (every 'alpha-char-p s2)))) (nil nil t t nil nil nil)) (deftest every.27 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'base-char - :displaced-to s1 - :displaced-index-offset i) - collect (notnot (every 'alpha-char-p s2)))) + for s2 = (make-array '(2) :element-type 'base-char + :displaced-to s1 + :displaced-index-offset i) + collect (notnot (every 'alpha-char-p s2)))) (nil nil t t nil nil nil)) ;;; adjustable vectors (deftest every.28 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :adjustable t))) + :adjustable t))) (values (notnot (every #'plusp v)) (progn @@ -214,8 +214,8 @@ (deftest every.29 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 10 - :adjustable t))) + :fill-pointer 10 + :adjustable t))) (values (notnot (every #'plusp v)) (progn @@ -227,34 +227,34 @@ (deftest every.30 (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(6) - :element-type type - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6))) - unless (every #'plusp v) - collect (list type v)) + for v = (make-array '(6) + :element-type type + :initial-contents + (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6))) + unless (every #'plusp v) + collect (list type v)) nil) (deftest every.31 (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(6) - :element-type type - :fill-pointer 5 - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 -1))) - unless (every #'plusp v) - collect (list type v)) + for v = (make-array '(6) + :element-type type + :fill-pointer 5 + :initial-contents + (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 -1))) + unless (every #'plusp v) + collect (list type v)) nil) (deftest every.32 (loop for type in '(short-float single-float double-float long-float) - for ctype = `(complex ,type) - for v = (make-array '(6) - :element-type ctype - :initial-contents - (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) - unless (every #'complexp v) - collect (list type v)) + for ctype = `(complex ,type) + for v = (make-array '(6) + :element-type ctype + :initial-contents + (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) + unless (every #'complexp v) + collect (list type v)) nil) ;;; Order of arguments @@ -263,7 +263,7 @@ (let ((i 0) x y) (values (every (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) '(nil nil a nil))) + (progn (setf y (incf i)) '(nil nil a nil))) i x y)) nil 2 1 2) @@ -271,8 +271,8 @@ (let ((i 0) x y z) (values (every (progn (setf x (incf i)) #'equal) - (progn (setf y (incf i)) '(nil nil a nil)) - (progn (setf z (incf i)) '(nil nil a b))) + (progn (setf y (incf i)) '(nil nil a nil)) + (progn (setf z (incf i)) '(nil nil a b))) i x y z)) nil 3 1 2 3) @@ -280,17 +280,17 @@ (deftest every.error.1 (check-type-error #'(lambda (x) (every x '(a b c))) - #'(lambda (x) (typep x '(or function symbol)))) + #'(lambda (x) (typep x '(or function symbol)))) nil) (deftest every.error.2 (check-type-error #'(lambda (x) (every #'null x)) - #'(lambda (x) (typep x 'sequence))) + #'(lambda (x) (typep x 'sequence))) nil) (deftest every.error.3 (check-type-error #'(lambda (x) (every #'eq () x)) - #'(lambda (x) (typep x 'sequence))) + #'(lambda (x) (typep x 'sequence))) nil) (deftest every.error.8 diff --git a/ansi-tests/exp-aux.lsp b/ansi-tests/exp-aux.lsp index 9d6b3ec5..2d43194a 100644 --- a/ansi-tests/exp-aux.lsp +++ b/ansi-tests/exp-aux.lsp @@ -10,7 +10,7 @@ the first n terms of the Taylor series." (assert (realp x)) (let ((result 1) - (xrat (rational x))) + (xrat (rational x))) (loop for i from (1- n) downto 1 do (setq result (+ 1 (/ (* xrat result) i)))) @@ -19,6 +19,6 @@ (float result 1.0f0)))) - + diff --git a/ansi-tests/exp.lsp b/ansi-tests/exp.lsp index 1f292c0c..d0510a34 100644 --- a/ansi-tests/exp.lsp +++ b/ansi-tests/exp.lsp @@ -27,7 +27,7 @@ (deftest exp.1 (let ((result (exp 0))) (or (eqlt result 1) - (eqlt result 1.0f0))) + (eqlt result 1.0f0))) t) (deftest exp.2 @@ -43,40 +43,40 @@ (deftest exp.error.4 (signals-error (exp (+ (log most-positive-short-float) 100)) - floating-point-overflow) + floating-point-overflow) t) (deftest exp.error.5 (signals-error (exp (+ (log most-positive-single-float) 100)) - floating-point-overflow) + floating-point-overflow) t) (deftest exp.error.6 (signals-error (exp (+ (log most-positive-double-float) 100)) - floating-point-overflow) + floating-point-overflow) t) (deftest exp.error.7 (signals-error (exp (+ (log most-positive-long-float) 100)) - floating-point-overflow) + floating-point-overflow) t) (deftest exp.error.8 (signals-error (exp (- (log least-positive-short-float) 100)) - floating-point-underflow) + floating-point-underflow) t) (deftest exp.error.9 (signals-error (exp (- (log least-positive-single-float) 100)) - floating-point-underflow) + floating-point-underflow) t) (deftest exp.error.10 (signals-error (exp (- (log least-positive-double-float) 100)) - floating-point-underflow) + floating-point-underflow) t) (deftest exp.error.11 (signals-error (exp (- (log least-positive-double-float) 100)) - floating-point-underflow) + floating-point-underflow) t) diff --git a/ansi-tests/export.lsp b/ansi-tests/export.lsp index 19b6b157..cfba7cfd 100644 --- a/ansi-tests/export.lsp +++ b/ansi-tests/export.lsp @@ -14,21 +14,21 @@ (safely-delete-package "TEST1") (let ((p (make-package "TEST1"))) (let ((sym (intern "FOO" p)) - (i 0) x y) - (setf return-value (export (progn (setf x (incf i)) sym) - (progn (setf y (incf i)) p))) - (multiple-value-bind* (sym2 status) - (find-symbol "FOO" p) - (prog1 - (and sym2 - (eql i 2) - (eql x 1) - (eql y 2) - (eqt (symbol-package sym2) p) - (string= (symbol-name sym2) "FOO") - (eqt sym sym2) - (eqt status :external)) - (delete-package p))))) + (i 0) x y) + (setf return-value (export (progn (setf x (incf i)) sym) + (progn (setf y (incf i)) p))) + (multiple-value-bind* (sym2 status) + (find-symbol "FOO" p) + (prog1 + (and sym2 + (eql i 2) + (eql x 1) + (eql y 2) + (eqt (symbol-package sym2) p) + (string= (symbol-name sym2) "FOO") + (eqt sym sym2) + (eqt status :external)) + (delete-package p))))) return-value) t) @@ -37,16 +37,16 @@ (safely-delete-package "TEST1") (let ((p (make-package "TEST1"))) (let ((sym (intern "FOO" p))) - (export (list sym) p) - (multiple-value-bind* (sym2 status) - (find-symbol "FOO" p) - (prog1 - (and sym2 - (eqt (symbol-package sym2) p) - (string= (symbol-name sym2) "FOO") - (eqt sym sym2) - (eqt status :external)) - (delete-package p)))))) + (export (list sym) p) + (multiple-value-bind* (sym2 status) + (find-symbol "FOO" p) + (prog1 + (and sym2 + (eqt (symbol-package sym2) p) + (string= (symbol-name sym2) "FOO") + (eqt sym sym2) + (eqt status :external)) + (delete-package p)))))) t) (deftest export.3 @@ -88,14 +88,14 @@ (make-package "TEST2" :use '("TEST1")) (export (intern "X" "TEST2") "TEST2") (prog1 - (handler-case - (let ((sym (intern "X" "TEST1"))) - (handler-case - (export sym "TEST1") - (error (c) - (format t "Caught error in EXPORT.5: ~A~%" c) - 'caught))) - (error (c) c)) + (handler-case + (let ((sym (intern "X" "TEST1"))) + (handler-case + (export sym "TEST1") + (error (c) + (format t "Caught error in EXPORT.5: ~A~%" c) + 'caught))) + (error (c) c)) (delete-package "TEST2") (delete-package "TEST1"))) caught) diff --git a/ansi-tests/expt.lsp b/ansi-tests/expt.lsp index 8546ecd1..e85b4ad9 100644 --- a/ansi-tests/expt.lsp +++ b/ansi-tests/expt.lsp @@ -62,80 +62,80 @@ (deftest expt.2 (loop for i from -1000 to 1000 - always (eql (expt i 0) 1)) + always (eql (expt i 0) 1)) t) (deftest expt.3 (loop for i = (random 1.0s3) - repeat 1000 - always (eql (expt i 0) 1.0s0)) + repeat 1000 + always (eql (expt i 0) 1.0s0)) t) (deftest expt.4 (loop for i = (random 1.0f6) - repeat 1000 - always (eql (expt i 0) 1.0f0)) + repeat 1000 + always (eql (expt i 0) 1.0f0)) t) (deftest expt.5 (loop for i = (random 1.0d10) - repeat 1000 - always (eql (expt i 0) 1.0d0)) + repeat 1000 + always (eql (expt i 0) 1.0d0)) t) (deftest expt.6 (loop for i = (random 1.0l10) - repeat 1000 - always (eql (expt i 0) 1.0l0)) + repeat 1000 + always (eql (expt i 0) 1.0l0)) t) (deftest expt.7 (loop for i from -1000 to 1000 - for c = (complex i i) - always (eql (expt c 0) 1)) + for c = (complex i i) + always (eql (expt c 0) 1)) t) (deftest expt.8 (loop for i = (random 1.0s3) - for c = (complex i i) - repeat 1000 - always (eql (expt c 0) #c(1.0s0 0.0s0))) + for c = (complex i i) + repeat 1000 + always (eql (expt c 0) #c(1.0s0 0.0s0))) t) (deftest expt.9 (loop for i = (random 1.0f6) - for c = (complex i i) - repeat 1000 - always (eql (expt c 0) #c(1.0f0 0.0f0))) + for c = (complex i i) + repeat 1000 + always (eql (expt c 0) #c(1.0f0 0.0f0))) t) (deftest expt.10 (loop for i = (random 1.0d10) - for c = (complex i i) - repeat 1000 - always (eql (expt c 0) #c(1.0d0 0.0d0))) + for c = (complex i i) + repeat 1000 + always (eql (expt c 0) #c(1.0d0 0.0d0))) t) (deftest expt.11 (loop for i = (random 1.0l10) - for c = (complex i i) - repeat 1000 - always (eql (expt c 0) #c(1.0l0 0.0l0))) + for c = (complex i i) + repeat 1000 + always (eql (expt c 0) #c(1.0l0 0.0l0))) t) (deftest expt.12 (loop for x in *numbers* - unless (or (floatp (realpart x)) - (eql (expt x 1) x)) - collect x) + unless (or (floatp (realpart x)) + (eql (expt x 1) x)) + collect x) nil) (deftest expt.13 (loop for x in *rationals* - unless (and (eql (expt x 2) (* x x)) - (or (zerop x) - (eql (expt x -1) (/ x)))) - collect x) + unless (and (eql (expt x 2) (* x x)) + (or (zerop x) + (eql (expt x -1) (/ x)))) + collect x) nil) (deftest expt.14 @@ -159,8 +159,8 @@ for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) always (loop for i from -1000 to 1000 - always (or (zerop i) - (eql (expt i zero) (float 1 zero))))) + always (or (zerop i) + (eql (expt i zero) (float 1 zero))))) t) (deftest expt.19 @@ -168,8 +168,8 @@ for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) always (loop for i from -1000 to 1000 - always (or (zerop i) - (eql (expt (float i 0.0s0) zero) (float 1 zero))))) + always (or (zerop i) + (eql (expt (float i 0.0s0) zero) (float 1 zero))))) t) (deftest expt.20 @@ -177,8 +177,8 @@ for zero in '(0.0f0 0.0d0 0.0l0) always (loop for i from -1000 to 1000 - always (or (zerop i) - (eql (expt (float i 0.0f0) zero) (float 1 zero))))) + always (or (zerop i) + (eql (expt (float i 0.0f0) zero) (float 1 zero))))) t) (deftest expt.21 @@ -186,8 +186,8 @@ for zero in '(0.0d0 0.0l0) always (loop for i from -1000 to 1000 - always (or (zerop i) - (eql (expt (float i 0.0d0) zero) (float 1 zero))))) + always (or (zerop i) + (eql (expt (float i 0.0d0) zero) (float 1 zero))))) t) (deftest expt.22 @@ -225,31 +225,31 @@ (deftest expt.29 (loop for bound in '(1.0s4 1.0f6 1.0d8 1.0l8) - for ebound in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for ebound2 = (max (* 2 ebound) (/ bound)) - nconc - (loop for x = (1+ (random 1.0f6)) - for s1 = (sqrt x) - for s2 = (expt x 1/2) - for error = (/ (abs (- s2 s2)) x) - repeat 1000 - unless (< error ebound2) - collect (list x s1 s2))) + for ebound in (list short-float-epsilon single-float-epsilon + double-float-epsilon long-float-epsilon) + for ebound2 = (max (* 2 ebound) (/ bound)) + nconc + (loop for x = (1+ (random 1.0f6)) + for s1 = (sqrt x) + for s2 = (expt x 1/2) + for error = (/ (abs (- s2 s2)) x) + repeat 1000 + unless (< error ebound2) + collect (list x s1 s2))) nil) (deftest expt.30 (loop for bound in '(1.0s4 1.0f6 1.0d8 1.0l8) - for ebound in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for ebound2 = (max (* 2 ebound) (/ bound)) - nconc - (loop for x = (- (1+ (random 1.0f6))) - for s1 = (sqrt x) - for s2 = (expt x 1/2) - for error = (/ (abs (- s2 s2)) x) - repeat 1000 - unless (< error ebound2) - collect (list x s1 s2))) + for ebound in (list short-float-epsilon single-float-epsilon + double-float-epsilon long-float-epsilon) + for ebound2 = (max (* 2 ebound) (/ bound)) + nconc + (loop for x = (- (1+ (random 1.0f6))) + for s1 = (sqrt x) + for s2 = (expt x 1/2) + for error = (/ (abs (- s2 s2)) x) + repeat 1000 + unless (< error ebound2) + collect (list x s1 s2))) nil) |# diff --git a/ansi-tests/fboundp.lsp b/ansi-tests/fboundp.lsp index b7811a41..2a7f84ef 100644 --- a/ansi-tests/fboundp.lsp +++ b/ansi-tests/fboundp.lsp @@ -41,8 +41,8 @@ ;;; See 11.1.2.1.1 (deftest fboundp.8 (loop for x in *cl-non-function-macro-special-operator-symbols* - when (and (fboundp x) (not (eq x 'ed))) - collect x) + when (and (fboundp x) (not (eq x 'ed))) + collect x) nil) (deftest fboundp.order.1 @@ -88,14 +88,14 @@ (deftest fboundp.error.10 (loop for x in *mini-universe* - unless (symbolp x) - nconc - (handler-case - (list x (fboundp `(setf ,x))) - (type-error (c) - (assert (not (typep (type-error-datum c) - (type-error-expected-type c)))) - nil) - (error (c) (list (list x c))))) + unless (symbolp x) + nconc + (handler-case + (list x (fboundp `(setf ,x))) + (type-error (c) + (assert (not (typep (type-error-datum c) + (type-error-expected-type c)))) + nil) + (error (c) (list (list x c))))) nil) diff --git a/ansi-tests/fceiling-aux.lsp b/ansi-tests/fceiling-aux.lsp index dd6581d8..a4542dfd 100644 --- a/ansi-tests/fceiling-aux.lsp +++ b/ansi-tests/fceiling-aux.lsp @@ -7,15 +7,15 @@ (defun fceiling.1-fn () (loop for n = (- (random 200000) - 100000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (fceiling n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 100 - unless (and (eql (length vals) 2) - (floatp q) - (= n n2) - (integerp r) - (< (- d) r 1)) - collect (list n d q r n2))) + 100000) + for d = (1+ (random 10000)) + for vals = (multiple-value-list (fceiling n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 100 + unless (and (eql (length vals) 2) + (floatp q) + (= n n2) + (integerp r) + (< (- d) r 1)) + collect (list n d q r n2))) diff --git a/ansi-tests/fceiling.lsp b/ansi-tests/fceiling.lsp index e82f1f99..9577e520 100644 --- a/ansi-tests/fceiling.lsp +++ b/ansi-tests/fceiling.lsp @@ -24,124 +24,124 @@ (deftest fceiling.10 (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (fceiling x x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float 1 x)) - (= q 1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) + for (q r) = (multiple-value-list (fceiling x x)) + unless (and (floatp q) + (if (floatp x) + (eql q (float 1 x)) + (= q 1)) + (zerop r) + (if (floatp x) + (eql r (float 0 x)) + (= r 0))) + collect x) nil) (deftest fceiling.11 (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) - for (q r) = (multiple-value-list (fceiling (- x) x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float -1 x)) - (= q -1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) + for (q r) = (multiple-value-list (fceiling (- x) x)) + unless (and (floatp q) + (if (floatp x) + (eql q (float -1 x)) + (= q -1)) + (zerop r) + (if (floatp x) + (eql r (float 0 x)) + (= r 0))) + collect x) nil) (deftest fceiling.12 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce (1+ i) 'short-float)) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (fceiling x)) + unless (and (eql q (coerce (1+ i) 'short-float)) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest fceiling.13 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce i 'short-float)) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (fceiling x)) + unless (and (eql q (coerce i 'short-float)) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest fceiling.14 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce (1+ i) 'single-float)) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (fceiling x)) + unless (and (eql q (coerce (1+ i) 'single-float)) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest fceiling.15 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce i 'single-float)) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (fceiling x)) + unless (and (eql q (coerce i 'single-float)) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest fceiling.16 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce (1+ i) 'double-float)) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (fceiling x)) + unless (and (eql q (coerce (1+ i) 'double-float)) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest fceiling.17 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce i 'double-float)) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (fceiling x)) + unless (and (eql q (coerce i 'double-float)) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest fceiling.18 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce (1+ i) 'long-float)) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (fceiling x)) + unless (and (eql q (coerce (1+ i) 'long-float)) + (eql r (- rrad 1))) + collect (list i x q r))) nil) (deftest fceiling.19 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fceiling x)) - unless (and (eql q (coerce i 'long-float)) - (eql r (- rrad 1))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (fceiling x)) + unless (and (eql q (coerce i 'long-float)) + (eql r (- rrad 1))) + collect (list i x q r))) nil) diff --git a/ansi-tests/fdefinition.lsp b/ansi-tests/fdefinition.lsp index fe2fcb58..3796bbda 100644 --- a/ansi-tests/fdefinition.lsp +++ b/ansi-tests/fdefinition.lsp @@ -18,7 +18,7 @@ (deftest fdefinition.error.3 (let ((v (gensym))) (eval `(signals-error (fdefinition ',v) undefined-function - :name ,v))) + :name ,v))) t) (deftest fdefinition.error.4 @@ -28,7 +28,7 @@ ;;; (deftest fdefinition.error.5 ;;; (let ((fn `(setf ,(gensym)))) ;;; (eval `(signals-error (fdefinition ',fn) undefined-function -;;; :name ,fn))) +;;; :name ,fn))) ;;; t) (deftest fdefinition.error.6 @@ -41,15 +41,15 @@ (deftest fdefinition.error.8 (loop for x in *mini-universe* - unless (symbolp x) - nconc - (handler-case - (list x (fdefinition `(setf ,x))) - (type-error (c) - (assert (not (typep (type-error-datum c) - (type-error-expected-type c)))) - nil) - (error (c) (list (list x c))))) + unless (symbolp x) + nconc + (handler-case + (list x (fdefinition `(setf ,x))) + (type-error (c) + (assert (not (typep (type-error-datum c) + (type-error-expected-type c)))) + nil) + (error (c) (list (list x c))))) nil) ;;; Non-error cases @@ -85,7 +85,7 @@ (deftest fdefinition.5 (let* ((sym (gensym)) - (fname (list 'setf sym))) + (fname (list 'setf sym))) (values (fboundp fname) (progn diff --git a/ansi-tests/features.lsp b/ansi-tests/features.lsp index f243fc86..2862afe0 100644 --- a/ansi-tests/features.lsp +++ b/ansi-tests/features.lsp @@ -8,13 +8,13 @@ (deftest features.1 (let ((f *features*)) (or (not (member :draft-ansi-cl f)) - (not (intersection '(:draft-ansi-cl-2 :ansi-cl) f)))) + (not (intersection '(:draft-ansi-cl-2 :ansi-cl) f)))) t) (deftest features.2 (let ((f *features*)) (or (not (intersection '(:x3j13 :draft-ansi-cl :ansi-cl) f)) - (notnot (member :common-lisp f)))) + (notnot (member :common-lisp f)))) t) (deftest features.3 diff --git a/ansi-tests/ffloor-aux.lsp b/ansi-tests/ffloor-aux.lsp index d6e9369a..af8ddb89 100644 --- a/ansi-tests/ffloor-aux.lsp +++ b/ansi-tests/ffloor-aux.lsp @@ -7,15 +7,15 @@ (defun ffloor.1-fn () (loop for n = (- (random 200000) - 100000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (ffloor n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 100 - unless (and (eql (length vals) 2) - (floatp q) - (= n n2) - (integerp r) - (< -1 r d)) - collect (list n d q r n2))) + 100000) + for d = (1+ (random 10000)) + for vals = (multiple-value-list (ffloor n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 100 + unless (and (eql (length vals) 2) + (floatp q) + (= n n2) + (integerp r) + (< -1 r d)) + collect (list n d q r n2))) diff --git a/ansi-tests/ffloor.lsp b/ansi-tests/ffloor.lsp index f19035fb..ccb1a945 100644 --- a/ansi-tests/ffloor.lsp +++ b/ansi-tests/ffloor.lsp @@ -24,126 +24,126 @@ (deftest ffloor.10 (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (ffloor x x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float 1 x)) - (= q 1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) + for (q r) = (multiple-value-list (ffloor x x)) + unless (and (floatp q) + (if (floatp x) + (eql q (float 1 x)) + (= q 1)) + (zerop r) + (if (floatp x) + (eql r (float 0 x)) + (= r 0))) + collect x) nil) (deftest ffloor.11 (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) - for (q r) = (multiple-value-list (ffloor (- x) x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float -1 x)) - (= q -1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) + for (q r) = (multiple-value-list (ffloor (- x) x)) + unless (and (floatp q) + (if (floatp x) + (eql q (float -1 x)) + (= q -1)) + (zerop r) + (if (floatp x) + (eql r (float 0 x)) + (= r 0))) + collect x) nil) (deftest ffloor.12 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce i 'short-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (ffloor x)) + unless (and (eql q (coerce i 'short-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ffloor.13 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce (1- i) 'short-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (ffloor x)) + unless (and (eql q (coerce (1- i) 'short-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ffloor.14 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce i 'single-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (ffloor x)) + unless (and (eql q (coerce i 'single-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ffloor.15 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce (1- i) 'single-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (ffloor x)) + unless (and (eql q (coerce (1- i) 'single-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ffloor.16 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce i 'double-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (ffloor x)) + unless (and (eql q (coerce i 'double-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ffloor.17 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce (1- i) 'double-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (ffloor x)) + unless (and (eql q (coerce (1- i) 'double-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ffloor.18 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce i 'long-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (ffloor x)) + unless (and (eql q (coerce i 'long-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ffloor.19 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ffloor x)) - unless (and (eql q (coerce (1- i) 'long-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (ffloor x)) + unless (and (eql q (coerce (1- i) 'long-float)) + (eql r rrad)) + collect (list i x q r))) nil) ;;; To add: tests that involve adding/subtracting EPSILON constants diff --git a/ansi-tests/file-author.lsp b/ansi-tests/file-author.lsp index 20cf87b9..2d33a1b9 100644 --- a/ansi-tests/file-author.lsp +++ b/ansi-tests/file-author.lsp @@ -7,48 +7,48 @@ (deftest file-author.1 (loop for pn in - (directory (make-pathname :name :wild :type :wild - :defaults *default-pathname-defaults*)) - for author = (file-author pn) - unless (or (null author) (stringp author)) - collect (list pn author)) + (directory (make-pathname :name :wild :type :wild + :defaults *default-pathname-defaults*)) + for author = (file-author pn) + unless (or (null author) (stringp author)) + collect (list pn author)) nil) (deftest file-author.2 (let ((author (file-author "file-author.lsp"))) (if (or (null author) (stringp author)) - nil + nil author)) nil) (deftest file-author.3 (let ((author (file-author #p"file-author.lsp"))) (if (or (null author) (stringp author)) - nil + nil author)) nil) (deftest file-author.4 (let ((author (file-author (truename "file-author.lsp")))) (if (or (null author) (stringp author)) - nil + nil author)) nil) (deftest file-author.5 (let ((author (with-open-file (s "file-author.lsp" :direction :input) - (file-author s)))) + (file-author s)))) (if (or (null author) (stringp author)) - nil + nil author)) nil) (deftest file-author.6 (let ((author (let ((s (open "file-author.lsp" :direction :input))) - (close s) - (file-author s)))) + (close s) + (file-author s)))) (if (or (null author) (stringp author)) - nil + nil author)) nil) @@ -76,13 +76,13 @@ (deftest file-author.error.3 (signals-error-always (file-author (make-pathname :name :wild :type "lsp" - :defaults *default-pathname-defaults*)) + :defaults *default-pathname-defaults*)) file-error) t t) (deftest file-author.error.4 (signals-error-always (file-author (make-pathname :name "file-author" :type :wild - :defaults *default-pathname-defaults*)) + :defaults *default-pathname-defaults*)) file-error) t t) diff --git a/ansi-tests/file-error.lsp b/ansi-tests/file-error.lsp index 7c9c32d8..50a25a26 100644 --- a/ansi-tests/file-error.lsp +++ b/ansi-tests/file-error.lsp @@ -7,17 +7,17 @@ (deftest file-error.1 (let ((pn (make-pathname :name :wild - :type "txt" - :version :newest - :defaults *default-pathname-defaults*))) + :type "txt" + :version :newest + :defaults *default-pathname-defaults*))) (handler-case (probe-file pn) (error (c) - (values - (notnot (typep c 'file-error)) - (if (equalp (file-error-pathname c) pn) - t - (list (file-error-pathname c) pn)))))) + (values + (notnot (typep c 'file-error)) + (if (equalp (file-error-pathname c) pn) + t + (list (file-error-pathname c) pn)))))) t t) (deftest file-error-pathname.1 @@ -42,7 +42,7 @@ (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (equalpt "CLTEST:foo.txt" - (file-error-pathname c)))) + (file-error-pathname c)))) t t t) (deftest file-error-pathname.4 @@ -51,16 +51,16 @@ (notnot (typep c 'file-error)) (eqlt (class-of c) (find-class 'file-error)) (equalpt (logical-pathname "CLTEST:foo.txt") - (file-error-pathname c)))) + (file-error-pathname c)))) t t t) (deftest file-error-pathname.5 (with-open-file (s "file-error.lsp" :direction :input) - (let ((c (make-condition 'file-error :pathname s))) - (values - (notnot (typep c 'file-error)) - (eqlt (class-of c) (find-class 'file-error)) - (equalpt s (file-error-pathname c))))) + (let ((c (make-condition 'file-error :pathname s))) + (values + (notnot (typep c 'file-error)) + (eqlt (class-of c) (find-class 'file-error)) + (equalpt s (file-error-pathname c))))) t t t) (deftest file-error-pathname.6 diff --git a/ansi-tests/file-length.lsp b/ansi-tests/file-length.lsp index cb0d422f..b3e2ba07 100644 --- a/ansi-tests/file-length.lsp +++ b/ansi-tests/file-length.lsp @@ -12,26 +12,26 @@ (deftest file-length.error.2 (signals-error (with-open-file (is "file-length.lsp" :direction :input) - (file-length is nil)) + (file-length is nil)) program-error) t) (deftest file-length.error.3 (loop for x in *mini-universe* - unless (or (typep x 'file-stream) - (typep x 'broadcast-stream) - (handler-case (progn (file-length x) nil) - (type-error (c) - (assert (not (typep x (type-error-expected-type c)))) - t) - (condition () nil))) - collect x) + unless (or (typep x 'file-stream) + (typep x 'broadcast-stream) + (handler-case (progn (file-length x) nil) + (type-error (c) + (assert (not (typep x (type-error-expected-type c)))) + t) + (condition () nil))) + collect x) nil) (deftest file-length.error.4 :notes (:assume-no-simple-streams :assume-no-gray-streams) (signals-error (with-input-from-string (s "abc") (file-length s)) - type-error) + type-error) t) (deftest file-length.error.5 @@ -65,7 +65,7 @@ (deftest file-length.error.9 (signals-type-error s (make-concatenated-stream) - (unwind-protect (file-length s) (close s))) + (unwind-protect (file-length s) (close s))) t) (deftest file-length.error.10 @@ -80,90 +80,90 @@ (deftest file-length.error.11 :notes (:assume-no-simple-streams :assume-no-gray-streams) (signals-type-error s (make-string-input-stream "abcde") - (unwind-protect (file-length s) (close s))) + (unwind-protect (file-length s) (close s))) t) (deftest file-length.error.12 :notes (:assume-no-simple-streams :assume-no-gray-streams) (signals-type-error s (make-string-output-stream) - (unwind-protect (file-length s) (close s))) + (unwind-protect (file-length s) (close s))) t) ;;; Non-error tests (deftest file-length.1 (let ((results (multiple-value-list - (with-open-file - (is "file-length.lsp" :direction :input) - (file-length is))))) + (with-open-file + (is "file-length.lsp" :direction :input) + (file-length is))))) (and (= (length results) 1) - (typep (car results) '(integer 1)) - t)) + (typep (car results) '(integer 1)) + t)) t) (deftest file-length.2 (loop for i from 1 to 32 - for etype = `(unsigned-byte ,i) - for e = (max 0 (- (ash 1 i) 5)) - for os = (open "tmp.dat" :direction :output - :if-exists :supersede - :element-type etype) - do (loop repeat 17 do (write-byte e os)) - do (finish-output os) - unless (= (file-length os) 17) - collect (list i (file-length os)) - do (close os)) + for etype = `(unsigned-byte ,i) + for e = (max 0 (- (ash 1 i) 5)) + for os = (open "tmp.dat" :direction :output + :if-exists :supersede + :element-type etype) + do (loop repeat 17 do (write-byte e os)) + do (finish-output os) + unless (= (file-length os) 17) + collect (list i (file-length os)) + do (close os)) nil) (deftest file-length.3 (loop for i from 1 to 32 - for etype = `(unsigned-byte ,i) - for e = (max 0 (- (ash 1 i) 5)) - for os = (open "tmp.dat" :direction :output - :if-exists :supersede - :element-type etype) - for len = 0 - do (loop repeat 17 do (write-byte e os)) - do (close os) - unless (let ((is (open "tmp.dat" :direction :input - :element-type etype))) - (prog1 - (= (file-length is) 17) - (close is))) - collect i) + for etype = `(unsigned-byte ,i) + for e = (max 0 (- (ash 1 i) 5)) + for os = (open "tmp.dat" :direction :output + :if-exists :supersede + :element-type etype) + for len = 0 + do (loop repeat 17 do (write-byte e os)) + do (close os) + unless (let ((is (open "tmp.dat" :direction :input + :element-type etype))) + (prog1 + (= (file-length is) 17) + (close is))) + collect i) nil) (deftest file-length.4 (loop for i from 33 to 100 - for etype = `(unsigned-byte ,i) - for e = (max 0 (- (ash 1 i) 5)) - for os = (open "tmp.dat" :direction :output - :if-exists :supersede - :element-type etype) - do (loop repeat 17 do (write-byte e os)) - do (finish-output os) - unless (= (file-length os) 17) - collect (list i (file-length os)) - do (close os)) + for etype = `(unsigned-byte ,i) + for e = (max 0 (- (ash 1 i) 5)) + for os = (open "tmp.dat" :direction :output + :if-exists :supersede + :element-type etype) + do (loop repeat 17 do (write-byte e os)) + do (finish-output os) + unless (= (file-length os) 17) + collect (list i (file-length os)) + do (close os)) nil) (deftest file-length.5 (loop for i from 33 to 100 - for etype = `(unsigned-byte ,i) - for e = (max 0 (- (ash 1 i) 5)) - for os = (open "tmp.dat" :direction :output - :if-exists :supersede - :element-type etype) - for len = 0 - do (loop repeat 17 do (write-byte e os)) - do (close os) - unless (let ((is (open "tmp.dat" :direction :input - :element-type etype))) - (prog1 - (= (file-length is) 17) - (close is))) - collect i) - nil) + for etype = `(unsigned-byte ,i) + for e = (max 0 (- (ash 1 i) 5)) + for os = (open "tmp.dat" :direction :output + :if-exists :supersede + :element-type etype) + for len = 0 + do (loop repeat 17 do (write-byte e os)) + do (close os) + unless (let ((is (open "tmp.dat" :direction :input + :element-type etype))) + (prog1 + (= (file-length is) 17) + (close is))) + collect i) + nil) (deftest file-length.6 (with-open-file @@ -171,6 +171,6 @@ (declare (special *foo*)) (let ((s (make-synonym-stream '*foo*))) (unwind-protect - (typep* (file-length s) '(integer 1)) - (close s)))) + (typep* (file-length s) '(integer 1)) + (close s)))) t) diff --git a/ansi-tests/file-namestring.lsp b/ansi-tests/file-namestring.lsp index f837c95a..cc68ecac 100644 --- a/ansi-tests/file-namestring.lsp +++ b/ansi-tests/file-namestring.lsp @@ -7,12 +7,12 @@ (deftest file-namestring.1 (let* ((vals (multiple-value-list - (file-namestring "file-namestring.lsp"))) - (s (first vals))) + (file-namestring "file-namestring.lsp"))) + (s (first vals))) (if (and (null (cdr vals)) - (stringp s) - (equal (file-namestring s) s)) - :good + (stringp s) + (equal (file-namestring s) s)) + :good vals)) :good) @@ -26,10 +26,10 @@ (deftest file-namestring.3 (let* ((name "file-namestring.lsp") - (pn (merge-pathnames (pathname name))) - (name2 (with-open-file (s pn :direction :input) - (file-namestring s))) - (name3 (file-namestring pn))) + (pn (merge-pathnames (pathname name))) + (name2 (with-open-file (s pn :direction :input) + (file-namestring s))) + (name3 (file-namestring pn))) (or (equalt name2 name3) (list name2 name3))) t) diff --git a/ansi-tests/file-position.lsp b/ansi-tests/file-position.lsp index c623014f..3aa3c87e 100644 --- a/ansi-tests/file-position.lsp +++ b/ansi-tests/file-position.lsp @@ -7,24 +7,24 @@ (deftest file-position.1 (with-open-file (is "file-position.lsp":direction :input) - (file-position is)) + (file-position is)) 0) (deftest file-position.2 (with-open-file (is "file-position.lsp":direction :input) - (values - (multiple-value-list - (notnot-mv (file-position is :start))) - (file-position is))) - + (values + (multiple-value-list + (notnot-mv (file-position is :start))) + (file-position is))) + (t) 0) (deftest file-position.3 (with-open-file (is "file-position.lsp":direction :input) - (values - (multiple-value-list - (notnot-mv (file-position is :end))) - (notnot (> (file-position is) 0)))) + (values + (multiple-value-list + (notnot-mv (file-position is :end))) + (notnot (> (file-position is) 0)))) (t) t) (deftest file-position.4 @@ -51,83 +51,83 @@ (os "tmp.dat":direction :output :if-exists :supersede) (let ((p1 (file-position os)) - (delta (file-string-length os #\x))) + (delta (file-string-length os #\x))) (write-char #\x os) (let ((p2 (file-position os))) (or (null p1) (null p2) (null delta) - (=t (+ p1 delta) p2))))) + (=t (+ p1 delta) p2))))) t) ;;; Byte streams (deftest file-position.7 (loop for len from 1 to 32 - for n = (ash 1 len) - do (with-open-file - (os "tmp.dat" :direction :output - :if-exists :supersede - :element-type `(unsigned-byte ,len)) - (loop for i from 0 below 100 - for r = (logand (1- n) i) - for pos = (file-position os) - do (assert (or (not pos) (eql pos i))) - do (write-byte r os))) - do (with-open-file - (is "tmp.dat" :direction :input - :element-type `(unsigned-byte ,len)) - (loop for i from 0 below 100 - for pos = (file-position is) - do (assert (or (not pos) (eql pos i))) - do (let ((byte (read-byte is))) - (assert (eql byte (logand (1- n) i))))))) + for n = (ash 1 len) + do (with-open-file + (os "tmp.dat" :direction :output + :if-exists :supersede + :element-type `(unsigned-byte ,len)) + (loop for i from 0 below 100 + for r = (logand (1- n) i) + for pos = (file-position os) + do (assert (or (not pos) (eql pos i))) + do (write-byte r os))) + do (with-open-file + (is "tmp.dat" :direction :input + :element-type `(unsigned-byte ,len)) + (loop for i from 0 below 100 + for pos = (file-position is) + do (assert (or (not pos) (eql pos i))) + do (let ((byte (read-byte is))) + (assert (eql byte (logand (1- n) i))))))) nil) (deftest file-position.8 (loop for len from 33 to 100 - for n = (ash 1 len) - do (with-open-file - (os "tmp.dat" :direction :output - :if-exists :supersede - :element-type `(unsigned-byte ,len)) - (loop for i from 0 below 100 - for r = (logand (1- n) i) - for pos = (file-position os) - do (assert (or (not pos) (eql pos i))) - do (write-byte r os))) - do (with-open-file - (is "tmp.dat" :direction :input - :element-type `(unsigned-byte ,len)) - (loop for i from 0 below 100 - for pos = (file-position is) - do (assert (or (not pos) (eql pos i))) - do (let ((byte (read-byte is))) - (assert (eql byte (logand (1- n) i))))))) + for n = (ash 1 len) + do (with-open-file + (os "tmp.dat" :direction :output + :if-exists :supersede + :element-type `(unsigned-byte ,len)) + (loop for i from 0 below 100 + for r = (logand (1- n) i) + for pos = (file-position os) + do (assert (or (not pos) (eql pos i))) + do (write-byte r os))) + do (with-open-file + (is "tmp.dat" :direction :input + :element-type `(unsigned-byte ,len)) + (loop for i from 0 below 100 + for pos = (file-position is) + do (assert (or (not pos) (eql pos i))) + do (let ((byte (read-byte is))) + (assert (eql byte (logand (1- n) i))))))) nil) (deftest file-position.9 (with-input-from-string (s "abcdefghijklmnopqrstuvwxyz") (loop repeat 26 - for p = (file-position s) - unless (or (not p) - (progn - (file-position s p) - (eql (file-position s) p))) - collect p - do (read-char s))) + for p = (file-position s) + unless (or (not p) + (progn + (file-position s p) + (eql (file-position s) p))) + collect p + do (read-char s))) nil) (deftest file-position.10 (with-output-to-string (s) (loop repeat 26 - for p = (file-position s) - unless (or (not p) - (progn - (file-position s p) - (eql (file-position s) p))) - collect p - do (write-char #\x s))) + for p = (file-position s) + unless (or (not p) + (progn + (file-position s p) + (eql (file-position s) p))) + collect p + do (write-char #\x s))) "xxxxxxxxxxxxxxxxxxxxxxxxxx") ;;; Error tests @@ -153,8 +153,8 @@ (flet ((%fail () (error 'type-error))) (unless (file-position is :end) (%fail)) (let ((fp (file-position is))) - (unless fp (%fail)) - (file-position is (+ 1000000 fp))))) + (unless fp (%fail)) + (file-position is (+ 1000000 fp))))) error) t) @@ -167,4 +167,4 @@ t) |# - \ No newline at end of file + diff --git a/ansi-tests/file-string-length.lsp b/ansi-tests/file-string-length.lsp index f8a8d785..a4d8c7cc 100644 --- a/ansi-tests/file-string-length.lsp +++ b/ansi-tests/file-string-length.lsp @@ -6,39 +6,39 @@ (in-package :cl-test) (deftest file-string-length.1 - (with-open-file + (with-open-file (s "tmp.dat" :direction :output :if-exists :supersede) (loop for x across +standard-chars+ - for len = (file-string-length s x) - do (assert (typep len '(or null (integer 0)))) - do (let ((pos1 (file-position s))) - (write-char x s) - (let ((pos2 (file-position s))) - (when (and pos1 pos2 len) - (assert (= (+ pos1 len) pos2))))))) + for len = (file-string-length s x) + do (assert (typep len '(or null (integer 0)))) + do (let ((pos1 (file-position s))) + (write-char x s) + (let ((pos2 (file-position s))) + (when (and pos1 pos2 len) + (assert (= (+ pos1 len) pos2))))))) nil) (deftest file-string-length.2 - (with-open-file + (with-open-file (s "tmp.dat" :direction :output :if-exists :supersede) (loop for x across +standard-chars+ - for len = (file-string-length s (string x)) - do (assert (typep len '(or null (integer 0)))) - do (let ((pos1 (file-position s))) - (write-sequence (string x) s) - (let ((pos2 (file-position s))) - (when (and pos1 pos2 len) - (assert (= (+ pos1 len) pos2))))))) + for len = (file-string-length s (string x)) + do (assert (typep len '(or null (integer 0)))) + do (let ((pos1 (file-position s))) + (write-sequence (string x) s) + (let ((pos2 (file-position s))) + (when (and pos1 pos2 len) + (assert (= (+ pos1 len) pos2))))))) nil) (deftest file-string-length.3 (with-open-file (stream "tmp.dat" :direction :output - :if-exists :supersede) + :if-exists :supersede) (let* ((s1 "abcde") - (n (file-string-length stream s1))) + (n (file-string-length stream s1))) (do-special-strings (s2 s1 nil) (assert (= (file-string-length stream s2) n))))) @@ -52,7 +52,7 @@ (deftest file-string-length.error.2 (signals-error - (with-open-file + (with-open-file (s "tmp.dat" :direction :output :if-exists :supersede) (file-string-length s)) @@ -61,7 +61,7 @@ (deftest file-string-length.error.3 (signals-error - (with-open-file + (with-open-file (s "tmp.dat" :direction :output :if-exists :supersede) (file-string-length s #\x nil)) @@ -69,5 +69,5 @@ t) - + diff --git a/ansi-tests/file-write-date.lsp b/ansi-tests/file-write-date.lsp index de48dac8..5c7fa126 100644 --- a/ansi-tests/file-write-date.lsp +++ b/ansi-tests/file-write-date.lsp @@ -7,43 +7,43 @@ (deftest file-write-date.1 (let* ((pn "file-write-date.lsp") - (date (file-write-date pn)) - (time (get-universal-time))) + (date (file-write-date pn)) + (time (get-universal-time))) (or (null date) - (and (integerp date) - (<= 0 date time) - t))) + (and (integerp date) + (<= 0 date time) + t))) t) (deftest file-write-date.2 (let* ((pn #p"file-write-date.lsp") - (date (file-write-date pn)) - (time (get-universal-time))) + (date (file-write-date pn)) + (time (get-universal-time))) (or (null date) - (and (integerp date) - (<= 0 date time) - t))) + (and (integerp date) + (<= 0 date time) + t))) t) - + (deftest file-write-date.3 (let* ((pn (truename "file-write-date.lsp")) - (date (file-write-date pn)) - (time (get-universal-time))) + (date (file-write-date pn)) + (time (get-universal-time))) (or (null date) - (and (integerp date) - (<= 0 date time) - t))) + (and (integerp date) + (<= 0 date time) + t))) t) (deftest file-write-date.4 (loop for pn in (directory - (make-pathname :name :wild :type :wild - :defaults *default-pathname-defaults*)) - for date = (file-write-date pn) - for time = (get-universal-time) - unless (or (null date) - (<= 0 date time)) - collect (list pn date time)) + (make-pathname :name :wild :type :wild + :defaults *default-pathname-defaults*)) + for date = (file-write-date pn) + for time = (get-universal-time) + unless (or (null date) + (<= 0 date time)) + collect (list pn date time)) nil) (deftest file-write-date.5 @@ -54,7 +54,7 @@ (deftest file-write-date.6 (let* ((str "file-write-date.lsp") - (date (file-write-date str))) + (date (file-write-date str))) (do-special-strings (s str nil) (assert (equal (file-write-date s) date)))) @@ -71,19 +71,19 @@ (deftest file-write-date.error.2 (signals-error (file-write-date "file-write-date.lsp" nil) - program-error) + program-error) t) (deftest file-write-date.error.3 (signals-error-always (file-write-date (make-pathname :name :wild :type "lsp" - :defaults *default-pathname-defaults*)) + :defaults *default-pathname-defaults*)) file-error) t t) (deftest file-write-date.error.4 (signals-error-always (file-write-date (make-pathname :name "file-write-date" :type :wild - :defaults *default-pathname-defaults*)) + :defaults *default-pathname-defaults*)) file-error) t t) diff --git a/ansi-tests/fill-pointer.lsp b/ansi-tests/fill-pointer.lsp index 4b084024..aa4b4daa 100644 --- a/ansi-tests/fill-pointer.lsp +++ b/ansi-tests/fill-pointer.lsp @@ -17,7 +17,7 @@ (deftest fill-pointer.3 (let ((a (make-array '(10) :fill-pointer 5 - :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) + :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) (values (fill-pointer a) (setf (fill-pointer a) 6) @@ -26,7 +26,7 @@ (deftest fill-pointer.order.1 (let ((i 0) - (a (make-array '(10) :fill-pointer 5))) + (a (make-array '(10) :fill-pointer 5))) (values (fill-pointer (progn (incf i) a)) i)) @@ -34,12 +34,12 @@ (deftest fill-pointer.order.2 (let ((i 0) x y - (a (make-array '(10) :fill-pointer 5 - :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) + (a (make-array '(10) :fill-pointer 5 + :initial-contents '(1 2 3 4 5 6 7 8 9 10)))) (values i (setf (fill-pointer (progn (setf x (incf i)) a)) - (progn (setf y (incf i)) 6)) + (progn (setf y (incf i)) 6)) a i x y)) 0 6 #(1 2 3 4 5 6) 2 1 2) @@ -52,13 +52,13 @@ (deftest fill-pointer.error.2 (signals-error (fill-pointer (make-array '(10) :fill-pointer 4) nil) - program-error) + program-error) t) (deftest fill-pointer.error.3 (let ((a (make-array '(10) :fill-pointer nil))) (if (array-has-fill-pointer-p a) - t + t (eval `(signals-error (fill-pointer ',a) type-error)))) t) @@ -72,10 +72,10 @@ (deftest fill-pointer.error.6 (check-type-error #'fill-pointer #'(lambda (x) (and (vectorp x) - (array-has-fill-pointer-p x)))) + (array-has-fill-pointer-p x)))) nil) (deftest fill-pointer.error.7 (signals-error (locally (fill-pointer #2a((a b c)(d e f))) t) - type-error) + type-error) t) diff --git a/ansi-tests/fill.lsp b/ansi-tests/fill.lsp index 5cf44097..cb2378f9 100644 --- a/ansi-tests/fill.lsp +++ b/ansi-tests/fill.lsp @@ -23,7 +23,7 @@ (deftest fill.error.5 (signals-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest fill.error.6 @@ -40,8 +40,8 @@ (deftest fill.error.10 (signals-error (fill (list 'a 'b) 'c :bad t :allow-other-keys nil - :allow-other-keys t) - program-error) + :allow-other-keys t) + program-error) t) (deftest fill.error.11 @@ -52,44 +52,44 @@ (deftest array-fill-1 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) - (b (fill a 'x))) + (b (fill a 'x))) (values (eqt a b) - (map 'list #'identity a))) + (map 'list #'identity a))) t (x x x x x)) (deftest array-fill-2 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) - (b (fill a 'x :start 2))) + (b (fill a 'x :start 2))) (values (eqt a b) - (map 'list #'identity a))) + (map 'list #'identity a))) t (a b x x x)) (deftest array-fill-3 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) - (b (fill a 'x :end 2))) + (b (fill a 'x :end 2))) (values (eqt a b) - (map 'list #'identity a))) + (map 'list #'identity a))) t (x x c d e)) (deftest array-fill-4 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) - (b (fill a 'x :start 1 :end 3))) + (b (fill a 'x :start 1 :end 3))) (values (eqt a b) - (map 'list #'identity a))) + (map 'list #'identity a))) t (a x x d e)) (deftest array-fill-5 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) - (b (fill a 'x :start 1 :end nil))) + (b (fill a 'x :start 1 :end nil))) (values (eqt a b) - (map 'list #'identity a))) + (map 'list #'identity a))) t (a x x x x)) (deftest array-fill-6 (let* ((a (make-array '(5) :initial-contents '(a b c d e))) - (b (fill a 'x :end nil))) + (b (fill a 'x :end nil))) (values (eqt a b) - (map 'list #'identity a))) + (map 'list #'identity a))) t (x x x x x)) (deftest array-fill-7 @@ -124,44 +124,44 @@ (deftest array-fixnum-fill-1 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) - (b (fill a 6))) + (b (fill a 6))) (values (eqt a b) - (map 'list #'identity a))) + (map 'list #'identity a))) t (6 6 6 6 6)) (deftest array-fixnum-fill-2 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) - (b (fill a 6 :start 2))) + (b (fill a 6 :start 2))) (values (eqt a b) - (map 'list #'identity a))) + (map 'list #'identity a))) t (1 2 6 6 6)) (deftest array-fixnum-fill-3 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) - (b (fill a 7 :end 2))) + (b (fill a 7 :end 2))) (values (eqt a b) - (map 'list #'identity a))) + (map 'list #'identity a))) t (7 7 3 4 5)) (deftest array-fixnum-fill-4 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) - (b (fill a 8 :start 1 :end 3))) + (b (fill a 8 :start 1 :end 3))) (values (eqt a b) - (map 'list #'identity a))) + (map 'list #'identity a))) t (1 8 8 4 5)) (deftest array-fixnum-fill-5 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) - (b (fill a 0 :start 1 :end nil))) + (b (fill a 0 :start 1 :end nil))) (values (eqt a b) - (map 'list #'identity a))) + (map 'list #'identity a))) t (1 0 0 0 0)) (deftest array-fixnum-fill-6 (let* ((a (make-array '(5) :element-type 'fixnum :initial-contents '(1 2 3 4 5))) - (b (fill a -1 :end nil))) + (b (fill a -1 :end nil))) (values (eqt a b) - (map 'list #'identity a))) + (map 'list #'identity a))) t (-1 -1 -1 -1 -1)) (deftest array-fixnum-fill-7 @@ -220,22 +220,22 @@ (deftest array-unsigned-byte8-fill-7 (signals-error (array-unsigned-byte-fill-test-fn 8 0 :start -1) - type-error) + type-error) t) (deftest array-unsigned-byte8-fill-8 (signals-error (array-unsigned-byte-fill-test-fn 8 100 :start 'a) - type-error) + type-error) t) (deftest array-unsigned-byte8-fill-9 (signals-error (array-unsigned-byte-fill-test-fn 8 19 :end -1) - type-error) + type-error) t) (deftest array-unsigned-byte8-fill-10 (signals-error (array-unsigned-byte-fill-test-fn 8 17 :end 'a) - type-error) + type-error) t) ;;; Tests on arrays with fill pointers @@ -256,206 +256,206 @@ (deftest fill.string.1 (let* ((s1 (copy-seq "abcde")) - (s2 (fill s1 #\z))) + (s2 (fill s1 #\z))) (values (eqt s1 s2) s2)) t "zzzzz") (deftest fill.string.2 (let* ((s1 (copy-seq "abcde")) - (s2 (fill s1 #\z :start 0 :end 1))) + (s2 (fill s1 #\z :start 0 :end 1))) (values (eqt s1 s2) s2)) t "zbcde") (deftest fill.string.3 (let* ((s1 (copy-seq "abcde")) - (s2 (fill s1 #\z :end 2))) + (s2 (fill s1 #\z :end 2))) (values (eqt s1 s2) s2)) t "zzcde") (deftest fill.string.4 (let* ((s1 (copy-seq "abcde")) - (s2 (fill s1 #\z :end nil))) + (s2 (fill s1 #\z :end nil))) (values (eqt s1 s2) s2)) t "zzzzz") (deftest fill.string.5 (let* ((s1 "aaaaaaaa") - (len (length s1))) + (len (length s1))) (loop for start from 0 to (1- len) - always - (loop for end from (1+ start) to len - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 #\z :start start :end end))) - (and (eqt s2 s3) - (string= s3 - (substitute-if #\z (constantly t) s1 - :start start :end end)) - t))))) + always + (loop for end from (1+ start) to len + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 #\z :start start :end end))) + (and (eqt s2 s3) + (string= s3 + (substitute-if #\z (constantly t) s1 + :start start :end end)) + t))))) t) (deftest fill.string.6 (let* ((s1 "aaaaaaaa") - (len (length s1))) + (len (length s1))) (loop for start from 0 to (1- len) - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 #\z :start start))) - (and (eqt s2 s3) - (string= s3 - (substitute-if #\z (constantly t) s1 - :start start)) - t)))) + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 #\z :start start))) + (and (eqt s2 s3) + (string= s3 + (substitute-if #\z (constantly t) s1 + :start start)) + t)))) t) (deftest fill.string.7 (let* ((s1 "aaaaaaaa") - (len (length s1))) + (len (length s1))) (loop for start from 0 to (1- len) - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 #\z :end nil :start start))) - (and (eqt s2 s3) - (string= s3 - (substitute-if #\z (constantly t) s1 - :end nil :start start)) - t)))) + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 #\z :end nil :start start))) + (and (eqt s2 s3) + (string= s3 + (substitute-if #\z (constantly t) s1 + :end nil :start start)) + t)))) t) (deftest fill.string.8 (let* ((s1 "aaaaaaaa") - (len (length s1))) + (len (length s1))) (loop for end from 1 to len - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 #\z :end end))) - (and (eqt s2 s3) - (string= s3 - (substitute-if #\z (constantly t) s1 - :end end)) - t)))) + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 #\z :end end))) + (and (eqt s2 s3) + (string= s3 + (substitute-if #\z (constantly t) s1 + :end end)) + t)))) t) (deftest fill.string.9 (let* ((s1 (make-array '(8) :element-type 'character - :initial-element #\z - :fill-pointer 4)) - (s2 (fill s1 #\a))) + :initial-element #\z + :fill-pointer 4)) + (s2 (fill s1 #\a))) (and (eqt s1 s2) - (coerce (loop for i from 0 to 7 collect (aref s2 i)) - 'string))) + (coerce (loop for i from 0 to 7 collect (aref s2 i)) + 'string))) "aaaazzzz") (deftest fill.string.10 (let* ((s1 (make-array '(8) :element-type 'base-char - :initial-element #\z - :fill-pointer 4)) - (s2 (fill s1 #\a))) + :initial-element #\z + :fill-pointer 4)) + (s2 (fill s1 #\a))) (and (eqt s1 s2) - (coerce (loop for i from 0 to 7 collect (aref s2 i)) - 'base-string))) + (coerce (loop for i from 0 to 7 collect (aref s2 i)) + 'base-string))) "aaaazzzz") ;;; Tests for bit vectors (deftest fill.bit-vector.1 (let* ((s1 (copy-seq #*01100)) - (s2 (fill s1 0))) + (s2 (fill s1 0))) (values (eqt s1 s2) s2)) t #*00000) (deftest fill.bit-vector.2 (let* ((s1 (copy-seq #*00100)) - (s2 (fill s1 1 :start 0 :end 1))) + (s2 (fill s1 1 :start 0 :end 1))) (values (eqt s1 s2) s2)) t #*10100) (deftest fill.bit-vector.3 (let* ((s1 (copy-seq #*00010)) - (s2 (fill s1 1 :end 2))) + (s2 (fill s1 1 :end 2))) (values (eqt s1 s2) s2)) t #*11010) (deftest fill.bit-vector.4 (let* ((s1 (copy-seq #*00111)) - (s2 (fill s1 0 :end nil))) + (s2 (fill s1 0 :end nil))) (values (eqt s1 s2) s2)) t #*00000) (deftest fill.bit-vector.5 (let* ((s1 #*00000000) - (len (length s1))) + (len (length s1))) (loop for start from 0 to (1- len) - always - (loop for end from (1+ start) to len - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 1 :start start :end end))) - (and (eqt s2 s3) - (equalp s3 - (substitute-if 1 (constantly t) s1 - :start start :end end)) - t))))) + always + (loop for end from (1+ start) to len + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 1 :start start :end end))) + (and (eqt s2 s3) + (equalp s3 + (substitute-if 1 (constantly t) s1 + :start start :end end)) + t))))) t) (deftest fill.bit-vector.6 (let* ((s1 #*11111111) - (len (length s1))) + (len (length s1))) (loop for start from 0 to (1- len) - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 0 :start start))) - (and (eqt s2 s3) - (equalp s3 - (substitute-if 0 (constantly t) s1 - :start start)) - t)))) + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 0 :start start))) + (and (eqt s2 s3) + (equalp s3 + (substitute-if 0 (constantly t) s1 + :start start)) + t)))) t) (deftest fill.bit-vector.7 (let* ((s1 #*00000000) - (len (length s1))) + (len (length s1))) (loop for start from 0 to (1- len) - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 1 :end nil :start start))) - (and (eqt s2 s3) - (equalp s3 - (substitute-if 1 (constantly t) s1 - :end nil :start start)) - t)))) + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 1 :end nil :start start))) + (and (eqt s2 s3) + (equalp s3 + (substitute-if 1 (constantly t) s1 + :end nil :start start)) + t)))) t) (deftest fill.bit-vector.8 (let* ((s1 #*11111111) - (len (length s1))) + (len (length s1))) (loop for end from 1 to len - always - (let* ((s2 (copy-seq s1)) - (s3 (fill s2 0 :end end))) - (and (eqt s2 s3) - (equalp s3 - (substitute-if 0 (constantly t) s1 - :end end)) - t)))) + always + (let* ((s2 (copy-seq s1)) + (s3 (fill s2 0 :end end))) + (and (eqt s2 s3) + (equalp s3 + (substitute-if 0 (constantly t) s1 + :end end)) + t)))) t) (deftest fill.bit-vector.9 (let* ((s1 (make-array '(8) :element-type 'bit - :initial-element 0 - :fill-pointer 4)) - (s2 (fill s1 1))) + :initial-element 0 + :fill-pointer 4)) + (s2 (fill s1 1))) (and (eqt s1 s2) - (coerce (loop for i from 0 to 7 collect (aref s2 i)) - 'bit-vector))) + (coerce (loop for i from 0 to 7 collect (aref s2 i)) + 'bit-vector))) #*11110000) ;;; Test of :allow-other-keys @@ -482,12 +482,12 @@ (deftest fill.allow-other-keys.6 (fill (list 'a 'b 'c 'd 'e) 'a :bad t :allow-other-keys t - :allow-other-keys nil) + :allow-other-keys nil) (a a a a a)) (deftest fill.allow-other-keys.7 (fill (list 'a 'b 'c 'd 'e) 'a :allow-other-keys t :allow-other-keys nil - :bad t) + :bad t) (a a a a a)) @@ -497,7 +497,7 @@ (let ((i 0) x y (a (copy-seq #(a a a a)))) (values (fill (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 'z)) + (progn (setf y (incf i)) 'z)) i x y)) #(z z z z) 2 1 2) @@ -505,9 +505,9 @@ (let ((i 0) x y z w (a (copy-seq #(a a a a)))) (values (fill (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 'z) - :start (progn (setf z (incf i)) 1) - :end (progn (setf w (incf i)) 3)) + (progn (setf y (incf i)) 'z) + :start (progn (setf z (incf i)) 1) + :end (progn (setf w (incf i)) 3)) i x y z w)) #(a z z a) 4 1 2 3 4) @@ -515,9 +515,9 @@ (let ((i 0) x y z w (a (copy-seq #(a a a a)))) (values (fill (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 'z) - :end (progn (setf z (incf i)) 3) - :start (progn (setf w (incf i)) 1)) + (progn (setf y (incf i)) 'z) + :end (progn (setf z (incf i)) 3) + :start (progn (setf w (incf i)) 1)) i x y z w)) #(a z z a) 4 1 2 3 4) @@ -525,13 +525,13 @@ (let ((i 0) x y z p q r s w (a (copy-seq #(a a a a)))) (values (fill (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 'z) - :end (progn (setf z (incf i)) 3) - :end (progn (setf p (incf i)) 1) - :end (progn (setf q (incf i)) 1) - :end (progn (setf r (incf i)) 1) - :start (progn (setf s (incf i)) 1) - :start (progn (setf w (incf i)) 0)) + (progn (setf y (incf i)) 'z) + :end (progn (setf z (incf i)) 3) + :end (progn (setf p (incf i)) 1) + :end (progn (setf q (incf i)) 1) + :end (progn (setf r (incf i)) 1) + :start (progn (setf s (incf i)) 1) + :start (progn (setf w (incf i)) 0)) i x y z p q r s w)) #(a z z a) 8 1 2 3 4 5 6 7 8) @@ -596,4 +596,4 @@ (assert (eq v (fill v 0 :start 1 :end 3))) (assert (equal (array-element-type v) etype))) (assert (equalp v #(1 0 0 1 0)))) - nil) \ No newline at end of file + nil) diff --git a/ansi-tests/find-all-symbols.lsp b/ansi-tests/find-all-symbols.lsp index a1310031..2ee5e136 100644 --- a/ansi-tests/find-all-symbols.lsp +++ b/ansi-tests/find-all-symbols.lsp @@ -12,36 +12,36 @@ append (let ((failures nil)) (do-symbols (sym package failures) - (when (eql (symbol-package sym) package) - (let* ((name (symbol-name sym)) - (similar (find-all-symbols name)) - (similar2 (find-all-symbols sym))) - (unless (and (member sym similar) - (subsetp similar similar2) - (subsetp similar2 similar) - (loop for sym2 in similar - always (string= name (symbol-name sym2)))) - (push sym failures)))))))) + (when (eql (symbol-package sym) package) + (let* ((name (symbol-name sym)) + (similar (find-all-symbols name)) + (similar2 (find-all-symbols sym))) + (unless (and (member sym similar) + (subsetp similar similar2) + (subsetp similar2 similar) + (loop for sym2 in similar + always (string= name (symbol-name sym2)))) + (push sym failures)))))))) nil) ;;; FIXME -- test that each symbol found is accessible in some package (deftest find-all-symbols.2 (loop for i from 0 to 255 - for c = (code-char i) - when (and (characterp c) - (loop for sym in (find-all-symbols c) - thereis (not (string= (symbol-name sym) - (string c))))) - collect c) + for c = (code-char i) + when (and (characterp c) + (loop for sym in (find-all-symbols c) + thereis (not (string= (symbol-name sym) + (string c))))) + collect c) nil) ;;; Unusual strings (deftest find-all-symbols.3 (let* ((name (make-array '(3) :initial-contents "NIL" - :element-type 'base-char)) - (symbols (find-all-symbols name))) + :element-type 'base-char)) + (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) @@ -49,9 +49,9 @@ (deftest find-all-symbols.4 (let* ((name (make-array '(5) :initial-contents "NILXY" - :fill-pointer 3 - :element-type 'character)) - (symbols (find-all-symbols name))) + :fill-pointer 3 + :element-type 'character)) + (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) @@ -59,9 +59,9 @@ (deftest find-all-symbols.5 (let* ((name (make-array '(5) :initial-contents "NILXY" - :fill-pointer 3 - :element-type 'base-char)) - (symbols (find-all-symbols name))) + :fill-pointer 3 + :element-type 'base-char)) + (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) @@ -69,9 +69,9 @@ (deftest find-all-symbols.6 (let* ((name (make-array '(3) :initial-contents "NIL" - :adjustable t - :element-type 'base-char)) - (symbols (find-all-symbols name))) + :adjustable t + :element-type 'base-char)) + (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) @@ -79,9 +79,9 @@ (deftest find-all-symbols.7 (let* ((name (make-array '(3) :initial-contents "NIL" - :adjustable t - :element-type 'character)) - (symbols (find-all-symbols name))) + :adjustable t + :element-type 'character)) + (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) @@ -89,12 +89,12 @@ (deftest find-all-symbols.8 (let* ((type 'character) - (name0 (make-array '(9) :initial-contents "XYZNILABC" - :element-type type)) - (name (make-array '(3) :element-type type - :displaced-to name0 - :displaced-index-offset 3)) - (symbols (find-all-symbols name))) + (name0 (make-array '(9) :initial-contents "XYZNILABC" + :element-type type)) + (name (make-array '(3) :element-type type + :displaced-to name0 + :displaced-index-offset 3)) + (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) @@ -102,16 +102,16 @@ (deftest find-all-symbols.9 (let* ((type 'base-char) - (name0 (make-array '(9) :initial-contents "XYZNILABC" - :element-type type)) - (name (make-array '(3) :element-type type - :displaced-to name0 - :displaced-index-offset 3)) - (symbols (find-all-symbols name))) + (name0 (make-array '(9) :initial-contents "XYZNILABC" + :element-type type)) + (name (make-array '(3) :element-type type + :displaced-to name0 + :displaced-index-offset 3)) + (symbols (find-all-symbols name))) (values (notnot (every #'(lambda (s) (string= (symbol-name s) "NIL")) symbols)) (some #'not symbols))) - t t) + t t) ;;; Error tests diff --git a/ansi-tests/find-class.lsp b/ansi-tests/find-class.lsp index b4d6e692..d897ed3a 100644 --- a/ansi-tests/find-class.lsp +++ b/ansi-tests/find-class.lsp @@ -9,20 +9,20 @@ (deftest find-class.1 (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name) (find-class name)) - collect name) + unless (eq (find-class name) (find-class name)) + collect name) nil) (deftest find-class.2 (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name t) (find-class name)) - collect name) + unless (eq (find-class name t) (find-class name)) + collect name) nil) (deftest find-class.3 (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name nil) (find-class name)) - collect name) + unless (eq (find-class name nil) (find-class name)) + collect name) nil) (deftest find-class.4 @@ -43,37 +43,37 @@ (deftest find-class.7 (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name t nil) (find-class name)) - collect name) + unless (eq (find-class name t nil) (find-class name)) + collect name) nil) (deftest find-class.8 (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name nil nil) (find-class name)) - collect name) + unless (eq (find-class name nil nil) (find-class name)) + collect name) nil) (deftest find-class.9 (macrolet ((%m (&environment env) - (let ((result - (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name nil env) - (find-class name)) - collect name))) - `',result))) + (let ((result + (loop for name in *cl-types-that-are-classes-symbols* + unless (eq (find-class name nil env) + (find-class name)) + collect name))) + `',result))) (%m)) nil) (deftest find-class.10 (macrolet ((%m (&environment env) - (let ((result - (loop for name in *cl-types-that-are-classes-symbols* - unless (eq (find-class name t env) - (find-class name)) - collect name))) - `',result))) + (let ((result + (loop for name in *cl-types-that-are-classes-symbols* + unless (eq (find-class name t env) + (find-class name)) + collect name))) + `',result))) (%m)) nil) @@ -90,7 +90,7 @@ (deftest find-class.13 (macrolet ((%m (&environment env) - `',(find-class (gensym) nil env))) + `',(find-class (gensym) nil env))) (%m)) nil) @@ -98,9 +98,9 @@ (handler-case (progn (eval '(macrolet - ((%m (&environment env) - `',(find-class (gensym) 17 env))) - (%m))) + ((%m (&environment env) + `',(find-class (gensym) 17 env))) + (%m))) :bad) (error () :good)) :good) @@ -117,8 +117,8 @@ (progn (setf (find-class 'find-class-class-01) nil) (let* ((class (eval '(defclass find-class-class-01 () ()))) - (class1 (find-class 'find-class-class-01)) - (class2 (setf (find-class 'find-class-class-01) class1))) + (class1 (find-class 'find-class-class-01)) + (class2 (setf (find-class 'find-class-class-01) class1))) (values (eqt class class1) (eqt class class2) @@ -131,9 +131,9 @@ (setf (find-class 'find-class-class-01 nil) nil) (setf (find-class 'find-class-class-01 t) nil) ;; should not throw error (let* ((i 0) - (class (eval '(defclass find-class-class-01 () ()))) - (class1 (find-class 'find-class-class-01)) - (class2 (setf (find-class 'find-class-class-01 (incf i)) class1))) + (class (eval '(defclass find-class-class-01 () ()))) + (class1 (find-class 'find-class-class-01)) + (class2 (setf (find-class 'find-class-class-01 (incf i)) class1))) (values i (eqt class class1) @@ -143,22 +143,22 @@ (deftest find-class.17 (macrolet ((%m (&environment env) - `',(progn - (setf (find-class 'find-class-class-01) nil) - (let* - ((i 0) - x y z - (class (eval '(defclass find-class-class-01 () ()))) - (class1 (find-class (progn (setf x (incf i)) - 'find-class-class-01) - (setf y (incf i)) - (progn (setf z (incf i)) env))) - (class2 (setf (find-class 'find-class-class-01) class1))) - (list - (eqt class class1) - (eqt class class2) - i x y z - ))))) + `',(progn + (setf (find-class 'find-class-class-01) nil) + (let* + ((i 0) + x y z + (class (eval '(defclass find-class-class-01 () ()))) + (class1 (find-class (progn (setf x (incf i)) + 'find-class-class-01) + (setf y (incf i)) + (progn (setf z (incf i)) env))) + (class2 (setf (find-class 'find-class-class-01) class1))) + (list + (eqt class class1) + (eqt class class2) + i x y z + ))))) (%m)) (t t 3 1 2 3)) @@ -166,9 +166,9 @@ (progn (setf (find-class 'find-class-class-01) nil) (let* ((class (eval '(defclass find-class-class-01 () ()))) - (class1 (find-class 'find-class-class-01)) - (class2 (setf (find-class 'find-class-class-01) nil)) - (class3 (find-class 'find-class-class-01 nil))) + (class1 (find-class 'find-class-class-01)) + (class2 (setf (find-class 'find-class-class-01) nil)) + (class3 (find-class 'find-class-class-01 nil))) (values (eqt class class1) (eqt class class2) @@ -182,9 +182,9 @@ (setf (find-class 'find-class-class-01 nil) nil) (setf (find-class 'find-class-class-01 t) nil) ;; should not throw error (let* ((class (eval '(defclass find-class-class-01 () ()))) - (class1 (find-class 'find-class-class-01)) - (class2 (setf (find-class 'find-class-class-01 t nil) - class1))) + (class1 (find-class 'find-class-class-01)) + (class2 (setf (find-class 'find-class-class-01 t nil) + class1))) (values (eqt class class1) (eqt class class2)))) @@ -197,15 +197,15 @@ (setf (find-class 'find-class-class-01) nil) (setf (find-class 'find-class-class-02) nil) (let* ((class1 (eval '(defclass find-class-class-01 () ()))) - (class2 (eval '(defclass find-class-class-02 () ())))) + (class2 (eval '(defclass find-class-class-02 () ())))) (setf (find-class 'find-class-class-01) class2) (let* ((new-class1 (find-class 'find-class-class-01 nil)) - (new-class2 (find-class 'find-class-class-02))) - (values - (eqt class1 class2) - (eqt class2 new-class1) - (eqt class2 new-class2) - (class-name class2))))) + (new-class2 (find-class 'find-class-class-02))) + (values + (eqt class1 class2) + (eqt class2 new-class1) + (eqt class2 new-class2) + (class-name class2))))) nil t t find-class-class-02) (deftest find-class.21 @@ -213,18 +213,18 @@ (setf (find-class 'find-class-class-01) nil) (setf (find-class 'find-class-class-02) nil) (let* ((class1 (eval '(defclass find-class-class-01 () ()))) - (class2 (eval '(defclass find-class-class-02 () ())))) + (class2 (eval '(defclass find-class-class-02 () ())))) (psetf (find-class 'find-class-class-01) class2 - (find-class 'find-class-class-02) class1) + (find-class 'find-class-class-02) class1) (let* ((new-class1 (find-class 'find-class-class-01 nil)) - (new-class2 (find-class 'find-class-class-02))) - (values - (eqt class1 class2) - (eqt class2 new-class1) - (eqt class1 new-class2) - (class-name new-class1) - (class-name new-class2) - )))) + (new-class2 (find-class 'find-class-class-02))) + (values + (eqt class1 class2) + (eqt class2 new-class1) + (eqt class1 new-class2) + (class-name new-class1) + (class-name new-class2) + )))) nil t t find-class-class-02 find-class-class-01) ;;; Effect on method dispatch @@ -233,20 +233,20 @@ (progn (setf (find-class 'find-class-class-01) nil) (let* ((class1 (eval - '(defclass find-class-class-01 () ()))) - (fn (eval '(defgeneric find-class-gf-01 (x) - (:method ((x find-class-class-01)) :good) - (:method ((x t)) nil)))) - (obj (make-instance class1))) + '(defclass find-class-class-01 () ()))) + (fn (eval '(defgeneric find-class-gf-01 (x) + (:method ((x find-class-class-01)) :good) + (:method ((x t)) nil)))) + (obj (make-instance class1))) (assert (typep fn 'function)) (locally (declare (type function fn)) (values - (funcall fn nil) - (funcall fn obj) - (setf (find-class 'find-class-class-01) nil) - (funcall fn nil) - (funcall fn obj))))) + (funcall fn nil) + (funcall fn obj) + (setf (find-class 'find-class-class-01) nil) + (funcall fn nil) + (funcall fn obj))))) nil :good nil nil :good) (deftest find-class.23 @@ -254,25 +254,25 @@ (setf (find-class 'find-class-class-01) nil) (setf (find-class 'find-class-class-02) nil) (let* ((class1 (eval '(defclass find-class-class-01 () ()))) - (class2 (eval '(defclass find-class-class-02 - (find-class-class-01) ()))) - (fn (eval '(defgeneric find-class-gf-02 (x) - (:method ((x find-class-class-01)) 1) - (:method ((x find-class-class-02)) 2) - (:method ((x t)) t)))) - (obj1 (make-instance class1)) - (obj2 (make-instance class2))) + (class2 (eval '(defclass find-class-class-02 + (find-class-class-01) ()))) + (fn (eval '(defgeneric find-class-gf-02 (x) + (:method ((x find-class-class-01)) 1) + (:method ((x find-class-class-02)) 2) + (:method ((x t)) t)))) + (obj1 (make-instance class1)) + (obj2 (make-instance class2))) (assert (typep fn 'function)) (locally (declare (type function fn)) (values - (funcall fn nil) - (funcall fn obj1) - (funcall fn obj2) - (setf (find-class 'find-class-class-01) nil) - (funcall fn nil) - (funcall fn obj1) - (funcall fn obj2))))) + (funcall fn nil) + (funcall fn obj1) + (funcall fn obj2) + (setf (find-class 'find-class-class-01) nil) + (funcall fn nil) + (funcall fn obj1) + (funcall fn obj2))))) t 1 2 nil t 1 2) ;;; Error tests diff --git a/ansi-tests/find-if-not.lsp b/ansi-tests/find-if-not.lsp index a657e5d8..cc6f0312 100644 --- a/ansi-tests/find-if-not.lsp +++ b/ansi-tests/find-if-not.lsp @@ -27,39 +27,39 @@ (deftest find-if-not-list.5 (loop for i from 0 to 7 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i)) + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i)) (2 2 4 8 6 6 6 nil)) (deftest find-if-not-list.6 (loop for i from 0 to 7 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil)) + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil)) (2 2 4 8 6 6 6 nil)) (deftest find-if-not-list.7 (loop for i from 0 to 7 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :from-end t)) + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-not-list.8 (loop for i from 0 to 7 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-not-list.9 (loop for i from 0 to 8 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i)) + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i)) (nil nil 2 2 2 2 2 2 2)) (deftest find-if-not-list.10 (loop for i from 0 to 8 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i :from-end t)) + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :end i :from-end t)) (nil nil 2 4 8 8 8 6 6)) (deftest find-if-not-list.11 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i))) + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) @@ -71,10 +71,10 @@ (deftest find-if-not-list.12 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i - :from-end t))) + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'oddp '(1 2 4 8 3 1 6 7) :start j :end i + :from-end t))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) @@ -86,33 +86,33 @@ (deftest find-if-not-list.13 (loop for i from 0 to 6 - collect - (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :start i)) + collect + (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :start i)) (1 11 11 45 45 71 nil)) (deftest find-if-not-list.14 (loop for i from 0 to 6 - collect - (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) + collect + (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) (71 71 71 71 71 71 nil)) (deftest find-if-not-list.15 (loop for i from 0 to 7 - collect - (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :end i)) + collect + (find-if-not #'oddp '(1 6 11 32 45 71 100) :key #'1+ :end i)) (nil 1 1 1 1 1 1 1)) (deftest find-if-not-list.16 (loop for i from 0 to 7 - collect - (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) + collect + (find-if-not #'oddp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) (nil 1 1 11 11 45 71 71)) (deftest find-if-not-list.17 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) @@ -124,10 +124,10 @@ (deftest find-if-not-list.18 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i - :from-end t :key #'1+))) + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'evenp '(1 2 4 8 3 1 6 7) :start j :end i + :from-end t :key #'1+))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) @@ -161,39 +161,39 @@ (deftest find-if-not-vector.5 (loop for i from 0 to 7 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i)) + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i)) (2 2 4 8 6 6 6 nil)) (deftest find-if-not-vector.6 (loop for i from 0 to 7 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil)) + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil)) (2 2 4 8 6 6 6 nil)) (deftest find-if-not-vector.7 (loop for i from 0 to 7 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :from-end t)) + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-not-vector.8 (loop for i from 0 to 7 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-not-vector.9 (loop for i from 0 to 8 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i)) + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i)) (nil nil 2 2 2 2 2 2 2)) (deftest find-if-not-vector.10 (loop for i from 0 to 8 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i :from-end t)) + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :end i :from-end t)) (nil nil 2 4 8 8 8 6 6)) (deftest find-if-not-vector.11 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i))) + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) @@ -205,10 +205,10 @@ (deftest find-if-not-vector.12 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i - :from-end t))) + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'oddp #(1 2 4 8 3 1 6 7) :start j :end i + :from-end t))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) @@ -220,33 +220,33 @@ (deftest find-if-not-vector.13 (loop for i from 0 to 6 - collect - (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :start i)) + collect + (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :start i)) (1 11 11 45 45 71 nil)) (deftest find-if-not-vector.14 (loop for i from 0 to 6 - collect - (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) + collect + (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) (71 71 71 71 71 71 nil)) (deftest find-if-not-vector.15 (loop for i from 0 to 7 - collect - (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :end i)) + collect + (find-if-not #'oddp #(1 6 11 32 45 71 100) :key #'1+ :end i)) (nil 1 1 1 1 1 1 1)) (deftest find-if-not-vector.16 (loop for i from 0 to 7 - collect - (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) + collect + (find-if-not #'oddp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) (nil 1 1 11 11 45 71 71)) (deftest find-if-not-vector.17 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) @@ -258,10 +258,10 @@ (deftest find-if-not-vector.18 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i - :from-end t :key #'1+))) + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'evenp #(1 2 4 8 3 1 6 7) :start j :end i + :from-end t :key #'1+))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) @@ -287,8 +287,8 @@ (deftest find-if-not-bit-vector.4 (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if-not #'oddp #*0110110 :start i :end j))) + collect (loop for j from i to 7 + collect (find-if-not #'oddp #*0110110 :start i :end j))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) @@ -299,9 +299,9 @@ (deftest find-if-not-bit-vector.5 (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if-not #'oddp #*0110110 :start i :end j - :from-end t))) + collect (loop for j from i to 7 + collect (find-if-not #'oddp #*0110110 :start i :end j + :from-end t))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) @@ -312,9 +312,9 @@ (deftest find-if-not-bit-vector.6 (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if-not #'evenp #*0110110 :start i :end j - :from-end t :key #'1+))) + collect (loop for j from i to 7 + collect (find-if-not #'evenp #*0110110 :start i :end j + :from-end t :key #'1+))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) @@ -325,9 +325,9 @@ (deftest find-if-not-bit-vector.7 (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if-not #'evenp #*0110110 :start i :end j - :key '1-))) + collect (loop for j from i to 7 + collect (find-if-not #'evenp #*0110110 :start i :end j + :key '1-))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) @@ -353,7 +353,7 @@ (deftest find-if-not-string.3 (find-if-not #'odddigitp "12483167") #\2) - + (deftest find-if-not-string.3a (find-if-not #'oddp "12483167" :key #'(lambda (c) (read-from-string (string c)))) #\2) @@ -364,39 +364,39 @@ (deftest find-if-not-string.5 (loop for i from 0 to 7 collect - (find-if-not #'odddigitp "12483167" :start i)) + (find-if-not #'odddigitp "12483167" :start i)) (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) (deftest find-if-not-string.6 (loop for i from 0 to 7 collect - (find-if-not #'odddigitp "12483167" :start i :end nil)) + (find-if-not #'odddigitp "12483167" :start i :end nil)) (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) (deftest find-if-not-string.7 (loop for i from 0 to 7 collect - (find-if-not #'odddigitp "12483167" :start i :from-end t)) + (find-if-not #'odddigitp "12483167" :start i :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) (deftest find-if-not-string.8 (loop for i from 0 to 7 collect - (find-if-not #'odddigitp "12483167" :start i :end nil :from-end t)) + (find-if-not #'odddigitp "12483167" :start i :end nil :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) (deftest find-if-not-string.9 (loop for i from 0 to 8 collect - (find-if-not #'odddigitp "12483167" :end i)) + (find-if-not #'odddigitp "12483167" :end i)) (nil nil #\2 #\2 #\2 #\2 #\2 #\2 #\2)) (deftest find-if-not-string.10 (loop for i from 0 to 8 collect - (find-if-not #'odddigitp "12483167" :end i :from-end t)) + (find-if-not #'odddigitp "12483167" :end i :from-end t)) (nil nil #\2 #\4 #\8 #\8 #\8 #\6 #\6)) (deftest find-if-not-string.11 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'odddigitp "12483167" :start j :end i))) + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'odddigitp "12483167" :start j :end i))) ((nil #\2 #\2 #\2 #\2 #\2 #\2 #\2) (#\2 #\2 #\2 #\2 #\2 #\2 #\2) (#\4 #\4 #\4 #\4 #\4 #\4) @@ -408,10 +408,10 @@ (deftest find-if-not-string.12 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if-not #'odddigitp "12483167" :start j :end i - :from-end t))) + collect + (loop for i from (1+ j) to 8 collect + (find-if-not #'odddigitp "12483167" :start j :end i + :from-end t))) ((nil #\2 #\4 #\8 #\8 #\8 #\6 #\6) (#\2 #\4 #\8 #\8 #\8 #\6 #\6) (#\4 #\8 #\8 #\8 #\6 #\6) @@ -423,59 +423,59 @@ (deftest find-if-not-string.13 (loop for i from 0 to 6 - collect - (find-if-not #'oddp "1473816" - :key (compose #'read-from-string #'string) - :start i)) + collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :start i)) (#\4 #\4 #\8 #\8 #\8 #\6 #\6)) (deftest find-if-not-string.14 (loop for i from 0 to 6 - collect - (find-if-not #'oddp "1473816" - :key (compose #'read-from-string #'string) - :start i :from-end t)) + collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :start i :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6)) (deftest find-if-not-string.15 (loop for i from 0 to 7 - collect - (find-if-not #'oddp "1473816" - :key (compose #'read-from-string #'string) - :end i)) + collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :end i)) (nil nil #\4 #\4 #\4 #\4 #\4 #\4)) (deftest find-if-not-string.16 (loop for i from 0 to 7 - collect - (find-if-not #'oddp "1473816" - :key (compose #'read-from-string #'string) - :end i :from-end t)) + collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :end i :from-end t)) (nil nil #\4 #\4 #\4 #\8 #\8 #\6)) (deftest find-if-not-string.17 (loop for j from 0 to 6 - collect - (loop for i from (1+ j) to 7 collect - (find-if-not #'oddp "1473816" - :key (compose #'read-from-string #'string) - :start j :end i))) + collect + (loop for i from (1+ j) to 7 collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :start j :end i))) ((nil #\4 #\4 #\4 #\4 #\4 #\4) (#\4 #\4 #\4 #\4 #\4 #\4) (nil nil #\8 #\8 #\8) (nil #\8 #\8 #\8) (#\8 #\8 #\8) (nil #\6) - (#\6))) + (#\6))) (deftest find-if-not-string.18 (loop for j from 0 to 6 - collect - (loop for i from (1+ j) to 7 collect - (find-if-not #'oddp "1473816" - :key (compose #'read-from-string #'string) - :start j :end i - :from-end t))) + collect + (loop for i from (1+ j) to 7 collect + (find-if-not #'oddp "1473816" + :key (compose #'read-from-string #'string) + :start j :end i + :from-end t))) ((nil #\4 #\4 #\4 #\8 #\8 #\6) (#\4 #\4 #\4 #\8 #\8 #\6) (nil nil #\8 #\8 #\6) @@ -503,9 +503,9 @@ ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest find-if-not.allow-other-keys.3 (find-if-not #'oddp '(1 2 3 4 5) - :allow-other-keys t - :allow-other-keys nil - :bad t) + :allow-other-keys t + :allow-other-keys nil + :bad t) 2) (deftest find-if-not.keywords.4 @@ -524,7 +524,7 @@ (deftest find-if-not.error.4 (signals-error (find-if-not 'identity '(a b c . d)) - type-error) + type-error) t) (deftest find-if-not.error.5 @@ -541,7 +541,7 @@ (deftest find-if-not.error.8 (signals-error (find-if-not #'null nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest find-if-not.error.9 @@ -566,12 +566,12 @@ (deftest find-if-not.error.14 (signals-error (find-if-not #'identity '(a b c) :key #'cons) - program-error) + program-error) t) (deftest find-if-not.error.15 (signals-error (find-if-not #'identity '(a b c) :key #'car) - type-error) + type-error) t) ;;; Order of evaluation tests @@ -580,7 +580,7 @@ (let ((i 0) x y) (values (find-if-not (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) '(nil nil nil a nil nil))) + (progn (setf y (incf i)) '(nil nil nil a nil nil))) i x y)) a 2 1 2) @@ -588,12 +588,12 @@ (let ((i 0) a b c d e f) (values (find-if-not (progn (setf a (incf i)) #'identity) - (progn (setf b (incf i)) '(nil nil nil a nil nil)) - :start (progn (setf c (incf i)) 1) - :end (progn (setf d (incf i)) 4) - :from-end (setf e (incf i)) - :key (progn (setf f (incf i)) #'null) - ) + (progn (setf b (incf i)) '(nil nil nil a nil nil)) + :start (progn (setf c (incf i)) 1) + :end (progn (setf d (incf i)) 4) + :from-end (setf e (incf i)) + :key (progn (setf f (incf i)) #'null) + ) i a b c d e f)) a 6 1 2 3 4 5 6) @@ -602,11 +602,11 @@ (let ((i 0) a b c d e f) (values (find-if-not (progn (setf a (incf i)) #'identity) - (progn (setf b (incf i)) '(nil nil nil a nil nil)) - :key (progn (setf c (incf i)) #'null) - :from-end (setf d (incf i)) - :end (progn (setf e (incf i)) 4) - :start (progn (setf f (incf i)) 1) - ) + (progn (setf b (incf i)) '(nil nil nil a nil nil)) + :key (progn (setf c (incf i)) #'null) + :from-end (setf d (incf i)) + :end (progn (setf e (incf i)) 4) + :start (progn (setf f (incf i)) 1) + ) i a b c d e f)) a 6 1 2 3 4 5 6) diff --git a/ansi-tests/find-if.lsp b/ansi-tests/find-if.lsp index 04c87069..9fd712da 100644 --- a/ansi-tests/find-if.lsp +++ b/ansi-tests/find-if.lsp @@ -27,39 +27,39 @@ (deftest find-if-list.5 (loop for i from 0 to 7 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i)) + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i)) (2 2 4 8 6 6 6 nil)) (deftest find-if-list.6 (loop for i from 0 to 7 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil)) + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil)) (2 2 4 8 6 6 6 nil)) (deftest find-if-list.7 (loop for i from 0 to 7 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :from-end t)) + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-list.8 (loop for i from 0 to 7 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-list.9 (loop for i from 0 to 8 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i)) + (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i)) (nil nil 2 2 2 2 2 2 2)) (deftest find-if-list.10 (loop for i from 0 to 8 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i :from-end t)) + (find-if #'evenp '(1 2 4 8 3 1 6 7) :end i :from-end t)) (nil nil 2 4 8 8 8 6 6)) (deftest find-if-list.11 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i))) + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) @@ -71,10 +71,10 @@ (deftest find-if-list.12 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i - :from-end t))) + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evenp '(1 2 4 8 3 1 6 7) :start j :end i + :from-end t))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) @@ -86,33 +86,33 @@ (deftest find-if-list.13 (loop for i from 0 to 6 - collect - (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :start i)) + collect + (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :start i)) (1 11 11 45 45 71 nil)) (deftest find-if-list.14 (loop for i from 0 to 6 - collect - (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) + collect + (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) (71 71 71 71 71 71 nil)) (deftest find-if-list.15 (loop for i from 0 to 7 - collect - (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :end i)) + collect + (find-if #'evenp '(1 6 11 32 45 71 100) :key #'1+ :end i)) (nil 1 1 1 1 1 1 1)) (deftest find-if-list.16 (loop for i from 0 to 7 - collect - (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) + collect + (find-if #'evenp '(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) (nil 1 1 11 11 45 71 71)) (deftest find-if-list.17 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) + collect + (loop for i from (1+ j) to 8 collect + (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) @@ -124,10 +124,10 @@ (deftest find-if-list.18 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i - :from-end t :key #'1+))) + collect + (loop for i from (1+ j) to 8 collect + (find-if #'oddp '(1 2 4 8 3 1 6 7) :start j :end i + :from-end t :key #'1+))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) @@ -161,39 +161,39 @@ (deftest find-if-vector.5 (loop for i from 0 to 7 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i)) + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i)) (2 2 4 8 6 6 6 nil)) (deftest find-if-vector.6 (loop for i from 0 to 7 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil)) + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil)) (2 2 4 8 6 6 6 nil)) (deftest find-if-vector.7 (loop for i from 0 to 7 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :from-end t)) + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-vector.8 (loop for i from 0 to 7 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start i :end nil :from-end t)) (6 6 6 6 6 6 6 nil)) (deftest find-if-vector.9 (loop for i from 0 to 8 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i)) + (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i)) (nil nil 2 2 2 2 2 2 2)) (deftest find-if-vector.10 (loop for i from 0 to 8 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i :from-end t)) + (find-if #'evenp #(1 2 4 8 3 1 6 7) :end i :from-end t)) (nil nil 2 4 8 8 8 6 6)) (deftest find-if-vector.11 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i))) + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) @@ -205,10 +205,10 @@ (deftest find-if-vector.12 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i - :from-end t))) + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evenp #(1 2 4 8 3 1 6 7) :start j :end i + :from-end t))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) @@ -220,33 +220,33 @@ (deftest find-if-vector.13 (loop for i from 0 to 6 - collect - (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :start i)) + collect + (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :start i)) (1 11 11 45 45 71 nil)) (deftest find-if-vector.14 (loop for i from 0 to 6 - collect - (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) + collect + (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :start i :from-end t)) (71 71 71 71 71 71 nil)) (deftest find-if-vector.15 (loop for i from 0 to 7 - collect - (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :end i)) + collect + (find-if #'evenp #(1 6 11 32 45 71 100) :key #'1+ :end i)) (nil 1 1 1 1 1 1 1)) (deftest find-if-vector.16 (loop for i from 0 to 7 - collect - (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) + collect + (find-if #'evenp #(1 6 11 32 45 71 100) :key '1+ :end i :from-end t)) (nil 1 1 11 11 45 71 71)) (deftest find-if-vector.17 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) + collect + (loop for i from (1+ j) to 8 collect + (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i :key #'1-))) ((nil 2 2 2 2 2 2 2) (2 2 2 2 2 2 2) (4 4 4 4 4 4) @@ -258,10 +258,10 @@ (deftest find-if-vector.18 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i - :from-end t :key #'1+))) + collect + (loop for i from (1+ j) to 8 collect + (find-if #'oddp #(1 2 4 8 3 1 6 7) :start j :end i + :from-end t :key #'1+))) ((nil 2 4 8 8 8 6 6) (2 4 8 8 8 6 6) (4 8 8 8 6 6) @@ -273,7 +273,7 @@ (deftest find-if-vector.19 (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 5))) + :fill-pointer 5))) (values (find-if #'evenp a) (find-if #'evenp a :from-end t) @@ -298,8 +298,8 @@ (deftest find-if-bit-vector.4 (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if #'evenp #*0110110 :start i :end j))) + collect (loop for j from i to 7 + collect (find-if #'evenp #*0110110 :start i :end j))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) @@ -310,9 +310,9 @@ (deftest find-if-bit-vector.5 (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if #'evenp #*0110110 :start i :end j - :from-end t))) + collect (loop for j from i to 7 + collect (find-if #'evenp #*0110110 :start i :end j + :from-end t))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) @@ -323,9 +323,9 @@ (deftest find-if-bit-vector.6 (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if #'oddp #*0110110 :start i :end j - :from-end t :key #'1+))) + collect (loop for j from i to 7 + collect (find-if #'oddp #*0110110 :start i :end j + :from-end t :key #'1+))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) @@ -336,9 +336,9 @@ (deftest find-if-bit-vector.7 (loop for i from 0 to 6 - collect (loop for j from i to 7 - collect (find-if #'oddp #*0110110 :start i :end j - :key '1-))) + collect (loop for j from i to 7 + collect (find-if #'oddp #*0110110 :start i :end j + :key '1-))) ((nil 0 0 0 0 0 0 0) (nil nil nil 0 0 0 0) (nil nil 0 0 0 0) @@ -364,7 +364,7 @@ (deftest find-if-string.3 (find-if #'evendigitp "12483167") #\2) - + (deftest find-if-string.3a (find-if #'evenp "12483167" :key #'(lambda (c) (read-from-string (string c)))) #\2) @@ -375,39 +375,39 @@ (deftest find-if-string.5 (loop for i from 0 to 7 collect - (find-if #'evendigitp "12483167" :start i)) + (find-if #'evendigitp "12483167" :start i)) (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) (deftest find-if-string.6 (loop for i from 0 to 7 collect - (find-if #'evendigitp "12483167" :start i :end nil)) + (find-if #'evendigitp "12483167" :start i :end nil)) (#\2 #\2 #\4 #\8 #\6 #\6 #\6 nil)) (deftest find-if-string.7 (loop for i from 0 to 7 collect - (find-if #'evendigitp "12483167" :start i :from-end t)) + (find-if #'evendigitp "12483167" :start i :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) (deftest find-if-string.8 (loop for i from 0 to 7 collect - (find-if #'evendigitp "12483167" :start i :end nil :from-end t)) + (find-if #'evendigitp "12483167" :start i :end nil :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6 nil)) (deftest find-if-string.9 (loop for i from 0 to 8 collect - (find-if #'evendigitp "12483167" :end i)) + (find-if #'evendigitp "12483167" :end i)) (nil nil #\2 #\2 #\2 #\2 #\2 #\2 #\2)) (deftest find-if-string.10 (loop for i from 0 to 8 collect - (find-if #'evendigitp "12483167" :end i :from-end t)) + (find-if #'evendigitp "12483167" :end i :from-end t)) (nil nil #\2 #\4 #\8 #\8 #\8 #\6 #\6)) (deftest find-if-string.11 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'evendigitp "12483167" :start j :end i))) + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evendigitp "12483167" :start j :end i))) ((nil #\2 #\2 #\2 #\2 #\2 #\2 #\2) (#\2 #\2 #\2 #\2 #\2 #\2 #\2) (#\4 #\4 #\4 #\4 #\4 #\4) @@ -419,10 +419,10 @@ (deftest find-if-string.12 (loop for j from 0 to 7 - collect - (loop for i from (1+ j) to 8 collect - (find-if #'evendigitp "12483167" :start j :end i - :from-end t))) + collect + (loop for i from (1+ j) to 8 collect + (find-if #'evendigitp "12483167" :start j :end i + :from-end t))) ((nil #\2 #\4 #\8 #\8 #\8 #\6 #\6) (#\2 #\4 #\8 #\8 #\8 #\6 #\6) (#\4 #\8 #\8 #\8 #\6 #\6) @@ -434,59 +434,59 @@ (deftest find-if-string.13 (loop for i from 0 to 6 - collect - (find-if #'evenp "1473816" - :key (compose #'read-from-string #'string) - :start i)) + collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :start i)) (#\4 #\4 #\8 #\8 #\8 #\6 #\6)) (deftest find-if-string.14 (loop for i from 0 to 6 - collect - (find-if #'evenp "1473816" - :key (compose #'read-from-string #'string) - :start i :from-end t)) + collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :start i :from-end t)) (#\6 #\6 #\6 #\6 #\6 #\6 #\6)) (deftest find-if-string.15 (loop for i from 0 to 7 - collect - (find-if #'evenp "1473816" - :key (compose #'read-from-string #'string) - :end i)) + collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :end i)) (nil nil #\4 #\4 #\4 #\4 #\4 #\4)) (deftest find-if-string.16 (loop for i from 0 to 7 - collect - (find-if #'evenp "1473816" - :key (compose #'read-from-string #'string) - :end i :from-end t)) + collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :end i :from-end t)) (nil nil #\4 #\4 #\4 #\8 #\8 #\6)) (deftest find-if-string.17 (loop for j from 0 to 6 - collect - (loop for i from (1+ j) to 7 collect - (find-if #'evenp "1473816" - :key (compose #'read-from-string #'string) - :start j :end i))) + collect + (loop for i from (1+ j) to 7 collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :start j :end i))) ((nil #\4 #\4 #\4 #\4 #\4 #\4) (#\4 #\4 #\4 #\4 #\4 #\4) (nil nil #\8 #\8 #\8) (nil #\8 #\8 #\8) (#\8 #\8 #\8) (nil #\6) - (#\6))) + (#\6))) (deftest find-if-string.18 (loop for j from 0 to 6 - collect - (loop for i from (1+ j) to 7 collect - (find-if #'evenp "1473816" - :key (compose #'read-from-string #'string) - :start j :end i - :from-end t))) + collect + (loop for i from (1+ j) to 7 collect + (find-if #'evenp "1473816" + :key (compose #'read-from-string #'string) + :start j :end i + :from-end t))) ((nil #\4 #\4 #\4 #\8 #\8 #\6) (#\4 #\4 #\4 #\8 #\8 #\6) (nil nil #\8 #\8 #\6) @@ -497,8 +497,8 @@ (deftest find-if-string.19 (let ((a (make-array '(10) :initial-contents "123456789a" - :fill-pointer 5 - :element-type 'character))) + :fill-pointer 5 + :element-type 'character))) (values (find-if #'evendigitp a) (find-if #'evendigitp a :from-end t) @@ -526,9 +526,9 @@ ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest find-if.allow-other-keys.3 (find-if #'evenp '(1 2 3 4 5) - :allow-other-keys t - :allow-other-keys nil - :bad t) + :allow-other-keys t + :allow-other-keys nil + :bad t) 2) (deftest find-if.keywords.4 @@ -564,7 +564,7 @@ (deftest find-if.error.8 (signals-error (find-if #'null nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest find-if.error.9 @@ -593,7 +593,7 @@ (deftest find-if.error.15 (signals-error (find-if #'identity '(a b c) :key #'car) - type-error) + type-error) t) ;;; Order of evaluation tests @@ -602,7 +602,7 @@ (let ((i 0) x y) (values (find-if (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) '(nil nil nil a nil nil))) + (progn (setf y (incf i)) '(nil nil nil a nil nil))) i x y)) a 2 1 2) @@ -610,12 +610,12 @@ (let ((i 0) a b c d e f) (values (find-if (progn (setf a (incf i)) #'null) - (progn (setf b (incf i)) '(nil nil nil a nil nil)) - :start (progn (setf c (incf i)) 1) - :end (progn (setf d (incf i)) 4) - :from-end (setf e (incf i)) - :key (progn (setf f (incf i)) #'null) - ) + (progn (setf b (incf i)) '(nil nil nil a nil nil)) + :start (progn (setf c (incf i)) 1) + :end (progn (setf d (incf i)) 4) + :from-end (setf e (incf i)) + :key (progn (setf f (incf i)) #'null) + ) i a b c d e f)) a 6 1 2 3 4 5 6) @@ -624,11 +624,11 @@ (let ((i 0) a b c d e f) (values (find-if (progn (setf a (incf i)) #'null) - (progn (setf b (incf i)) '(nil nil nil a nil nil)) - :key (progn (setf c (incf i)) #'null) - :from-end (setf d (incf i)) - :end (progn (setf e (incf i)) 4) - :start (progn (setf f (incf i)) 1) - ) + (progn (setf b (incf i)) '(nil nil nil a nil nil)) + :key (progn (setf c (incf i)) #'null) + :from-end (setf d (incf i)) + :end (progn (setf e (incf i)) 4) + :start (progn (setf f (incf i)) 1) + ) i a b c d e f)) a 6 1 2 3 4 5 6) diff --git a/ansi-tests/find-method.lsp b/ansi-tests/find-method.lsp index acbf3309..72f1a75d 100644 --- a/ansi-tests/find-method.lsp +++ b/ansi-tests/find-method.lsp @@ -44,17 +44,17 @@ (deftest find-method.5 (find-method #'find-method-gf-01 (list :around) (list (find-class t)) - nil) + nil) nil) (deftest find-method.6 (find-method #'find-method-gf-01 (list :after) - (list (find-class 'integer)) nil) + (list (find-class 'integer)) nil) nil) (deftest find-method.7 (find-method #'find-method-gf-01 (list :before) (list (find-class 'real)) - nil) + nil) nil) ;;; EQL specializers @@ -77,7 +77,7 @@ (deftest find-method.9 (eqt (find-method #'find-method-gf-02 nil - (list (list 'eql *find-method-02-method2-value*))) + (list (list 'eql *find-method-02-method2-value*))) *find-method-gf-02-method2*) t) @@ -122,7 +122,7 @@ (deftest find-method.error.8 (handler-case (find-method #'find-method-gf-01 nil (list (find-class 'integer) - (find-class t))) + (find-class t))) (error () :error)) :error) @@ -135,8 +135,8 @@ (deftest find-method.error.10 (handler-case (find-method #'find-method-gf-01 nil (list (find-class 'integer) - (find-class t)) - nil) + (find-class t)) + nil) (error () :error)) :error) diff --git a/ansi-tests/find-package.lsp b/ansi-tests/find-package.lsp index 71ecbbc5..fa44b0a3 100644 --- a/ansi-tests/find-package.lsp +++ b/ansi-tests/find-package.lsp @@ -11,13 +11,13 @@ (deftest find-package.1 (let ((p (find-package "CL")) - (p2 (find-package "COMMON-LISP"))) + (p2 (find-package "COMMON-LISP"))) (and p p2 (eqt p p2))) t) (deftest find-package.2 (let ((p (find-package "CL-USER")) - (p2 (find-package "COMMON-LISP-USER"))) + (p2 (find-package "COMMON-LISP-USER"))) (and p p2 (eqt p p2))) t) @@ -31,8 +31,8 @@ (set-up-packages) (let ((p (ignore-errors (find-package "A")))) (if (packagep p) - t - p))) + t + p))) t) (deftest find-package.5 @@ -40,8 +40,8 @@ (set-up-packages) (let ((p (ignore-errors (find-package #\A)))) (if (packagep p) - t - p))) + t + p))) t) (deftest find-package.6 @@ -49,8 +49,8 @@ (set-up-packages) (let ((p (ignore-errors (find-package "B")))) (if (packagep p) - t - p))) + t + p))) t) (deftest find-package.7 @@ -58,25 +58,25 @@ (set-up-packages) (let ((p (ignore-errors (find-package #\B)))) (if (packagep p) - t - p))) + t + p))) t) (deftest find-package.8 (progn (set-up-packages) (let ((p (ignore-errors (find-package "Q"))) - (p2 (ignore-errors (find-package "A")))) + (p2 (ignore-errors (find-package "A")))) (and (packagep p) - (packagep p2) - (eqt p p2)))) + (packagep p2) + (eqt p p2)))) t) (deftest find-package.9 (progn (set-up-packages) (let ((p (ignore-errors (find-package "A"))) - (p2 (ignore-errors (find-package "B")))) + (p2 (ignore-errors (find-package "B")))) (eqt p p2))) nil) @@ -84,63 +84,63 @@ (progn (set-up-packages) (let ((p (ignore-errors (find-package #\Q))) - (p2 (ignore-errors (find-package "Q")))) + (p2 (ignore-errors (find-package "Q")))) (and (packagep p) - (eqt p p2)))) + (eqt p p2)))) t) (deftest find-package.11 (let* ((cl (find-package "CL")) - (cl2 (find-package cl))) + (cl2 (find-package cl))) (and (packagep cl) - (eqt cl cl2))) + (eqt cl cl2))) t) (deftest find-package.12 (let* ((name (make-array '(7) :initial-contents "KEYWORD" - :element-type 'base-char)) - (p (find-package name))) + :element-type 'base-char)) + (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.13 (let* ((name (make-array '(10) :initial-contents "KEYWORDXYZ" - :fill-pointer 7 - :element-type 'base-char)) - (p (find-package name))) + :fill-pointer 7 + :element-type 'base-char)) + (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.14 (let* ((name (make-array '(10) :initial-contents "KEYWORDXYZ" - :fill-pointer 7 - :element-type 'character)) - (p (find-package name))) + :fill-pointer 7 + :element-type 'character)) + (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.15 (let* ((name0 (make-array '(10) :initial-contents "XYKEYWORDZ" - :element-type 'character)) - (name (make-array '(7) :displaced-to name0 :displaced-index-offset 2 - :element-type 'character)) - (p (find-package name))) + :element-type 'character)) + (name (make-array '(7) :displaced-to name0 :displaced-index-offset 2 + :element-type 'character)) + (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.16 (let* ((name (make-array '(7) :initial-contents "KEYWORD" - :adjustable t - :element-type 'base-char)) - (p (find-package name))) + :adjustable t + :element-type 'base-char)) + (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) (deftest find-package.17 (let* ((name (make-array '(7) :initial-contents "KEYWORD" - :adjustable t - :element-type 'character)) - (p (find-package name))) + :adjustable t + :element-type 'character)) + (p (find-package name))) (and p (eqt p (symbol-package :test)))) t) diff --git a/ansi-tests/find-symbol.lsp b/ansi-tests/find-symbol.lsp index 99f5a44e..59544757 100644 --- a/ansi-tests/find-symbol.lsp +++ b/ansi-tests/find-symbol.lsp @@ -61,9 +61,9 @@ (set-up-packages) (let ((vals (multiple-value-list (find-symbol "FOO" #\A)))) (values (length vals) - (package-name (symbol-package (first vals))) - (symbol-name (first vals)) - (second vals)))) + (package-name (symbol-package (first vals))) + (symbol-name (first vals)) + (second vals)))) 2 "A" "FOO" :external) (deftest find-symbol.13 @@ -72,9 +72,9 @@ (intern "X" (find-package "A")) (let ((vals (multiple-value-list (find-symbol "X" #\A)))) (values (length vals) - (package-name (symbol-package (first vals))) - (symbol-name (first vals)) - (second vals)))) + (package-name (symbol-package (first vals))) + (symbol-name (first vals)) + (second vals)))) 2 "A" "X" :internal) (deftest find-symbol.14 @@ -82,9 +82,9 @@ (set-up-packages) (let ((vals (multiple-value-list (find-symbol "FOO" #\B)))) (values (length vals) - (package-name (symbol-package (first vals))) - (symbol-name (first vals)) - (second vals)))) + (package-name (symbol-package (first vals))) + (symbol-name (first vals)) + (second vals)))) 2 "A" "FOO" :inherited) (deftest find-symbol.15 @@ -97,39 +97,39 @@ (deftest find-symbol.17 (let ((name (make-array '(3) :initial-contents "FOO" - :element-type 'base-char))) + :element-type 'base-char))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.18 (let ((name (make-array '(4) :initial-contents "FOOD" - :element-type 'character - :fill-pointer 3))) + :element-type 'character + :fill-pointer 3))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.19 (let ((name (make-array '(4) :initial-contents "FOOD" - :element-type 'base-char - :fill-pointer 3))) + :element-type 'base-char + :fill-pointer 3))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.20 (let* ((name0 (make-array '(5) :initial-contents "XFOOY" - :element-type 'character)) - (name (make-array '(3) :element-type 'character - :displaced-to name0 - :displaced-index-offset 1))) + :element-type 'character)) + (name (make-array '(3) :element-type 'character + :displaced-to name0 + :displaced-index-offset 1))) (find-symbol name "FS-B")) FS-A::FOO :inherited) (deftest find-symbol.21 (let* ((name0 (make-array '(5) :initial-contents "XFOOY" - :element-type 'base-char)) - (name (make-array '(3) :element-type 'base-char - :displaced-to name0 - :displaced-index-offset 1))) + :element-type 'base-char)) + (name (make-array '(3) :element-type 'base-char + :displaced-to name0 + :displaced-index-offset 1))) (find-symbol name "FS-B")) FS-A::FOO :inherited) @@ -139,8 +139,8 @@ (deftest find-symbol.23 (find-symbol "FOO" (make-array '(5) :initial-contents "FS-BX" - :fill-pointer 4 - :element-type 'base-char)) + :fill-pointer 4 + :element-type 'base-char)) FS-A::FOO :inherited) @@ -149,7 +149,7 @@ (let ((i 0) x y) (values (find-symbol (progn (setf x (incf i)) (string '#:car)) - (progn (setf y (incf i)) "COMMON-LISP")) + (progn (setf y (incf i)) "COMMON-LISP")) i x y)) car 2 1 2) diff --git a/ansi-tests/find.lsp b/ansi-tests/find.lsp index 9825349a..b3c2da6c 100644 --- a/ansi-tests/find.lsp +++ b/ansi-tests/find.lsp @@ -15,39 +15,39 @@ (deftest find-list.3 (loop for i from 0 to 7 collect - (find 'c '(a b c d e c a) :start i)) + (find 'c '(a b c d e c a) :start i)) (c c c c c c nil nil)) (deftest find-list.4 (loop for i from 0 to 7 collect - (find 'c '(a b c d e c a) :start i :end nil)) + (find 'c '(a b c d e c a) :start i :end nil)) (c c c c c c nil nil)) (deftest find-list.5 (loop for i from 7 downto 0 collect - (find 'c '(a b c d e c a) :end i)) + (find 'c '(a b c d e c a) :end i)) (c c c c c nil nil nil)) (deftest find-list.6 (loop for i from 0 to 7 collect - (find 'c '(a b c d e c a) :start i :from-end t)) + (find 'c '(a b c d e c a) :start i :from-end t)) (c c c c c c nil nil)) (deftest find-list.7 (loop for i from 0 to 7 collect - (find 'c '(a b c d e c a) :start i :end nil :from-end t)) + (find 'c '(a b c d e c a) :start i :end nil :from-end t)) (c c c c c c nil nil)) (deftest find-list.8 (loop for i from 7 downto 0 collect - (find 'c '(a b c d e c a) :end i :from-end t)) + (find 'c '(a b c d e c a) :end i :from-end t)) (c c c c c nil nil nil)) (deftest find-list.9 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find 'c '(a b c d e c a) :start i :end j))) + (loop for j from (1+ i) to 7 + collect + (find 'c '(a b c d e c a) :start i :end j))) ((nil nil c c c c c) (nil c c c c c) (c c c c c) @@ -58,9 +58,9 @@ (deftest find-list.10 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find 'c '(a b c d e c a) :start i :end j :from-end t))) + (loop for j from (1+ i) to 7 + collect + (find 'c '(a b c d e c a) :start i :end j :from-end t))) ((nil nil c c c c c) (nil c c c c c) (c c c c c) @@ -87,7 +87,7 @@ (deftest find-list.15 (find 'a '(a a b a c e d a f a) :test (complement #'eql) - :from-end t) + :from-end t) f) (deftest find-list.16 @@ -96,7 +96,7 @@ (deftest find-list.17 (find 'a '(a a b a c e d a f a) :test-not 'eql - :from-end t) + :from-end t) f) (deftest find-list.18 @@ -105,7 +105,7 @@ (deftest find-list.19 (find 'a '(a a b a c e d a f a) :test-not #'eql - :from-end t) + :from-end t) f) (deftest find-list.20 @@ -114,22 +114,22 @@ (deftest find-list.21 (find 'a '(a a b a c e d a f a) :test #'eql - :start 2) + :start 2) a) (deftest find-list.22 (find 'a '(a a b a c e d a f a) :test #'eql - :start 2 :end nil) + :start 2 :end nil) a) (deftest find-list.23 (find 'a '(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5) + :start 0 :end 5) b) (deftest find-list.24 (find 'a '(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5 :from-end t) + :start 0 :end 5 :from-end t) c) (deftest find-list.25 @@ -142,12 +142,12 @@ (deftest find-list.27 (find 'a '((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car - :start 3) + :start 3) (a b)) (deftest find-list.28 (find 'a '((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car - :start 2 :from-end t) + :start 2 :from-end t) (a b)) (deftest find-list.29 @@ -178,39 +178,39 @@ (deftest find-vector.3 (loop for i from 0 to 7 collect - (find 'c #(a b c d e c a) :start i)) + (find 'c #(a b c d e c a) :start i)) (c c c c c c nil nil)) (deftest find-vector.4 (loop for i from 0 to 7 collect - (find 'c #(a b c d e c a) :start i :end nil)) + (find 'c #(a b c d e c a) :start i :end nil)) (c c c c c c nil nil)) (deftest find-vector.5 (loop for i from 7 downto 0 collect - (find 'c #(a b c d e c a) :end i)) + (find 'c #(a b c d e c a) :end i)) (c c c c c nil nil nil)) (deftest find-vector.6 (loop for i from 0 to 7 collect - (find 'c #(a b c d e c a) :start i :from-end t)) + (find 'c #(a b c d e c a) :start i :from-end t)) (c c c c c c nil nil)) (deftest find-vector.7 (loop for i from 0 to 7 collect - (find 'c #(a b c d e c a) :start i :end nil :from-end t)) + (find 'c #(a b c d e c a) :start i :end nil :from-end t)) (c c c c c c nil nil)) (deftest find-vector.8 (loop for i from 7 downto 0 collect - (find 'c #(a b c d e c a) :end i :from-end t)) + (find 'c #(a b c d e c a) :end i :from-end t)) (c c c c c nil nil nil)) (deftest find-vector.9 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find 'c #(a b c d e c a) :start i :end j))) + (loop for j from (1+ i) to 7 + collect + (find 'c #(a b c d e c a) :start i :end j))) ((nil nil c c c c c) (nil c c c c c) (c c c c c) @@ -221,9 +221,9 @@ (deftest find-vector.10 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find 'c #(a b c d e c a) :start i :end j :from-end t))) + (loop for j from (1+ i) to 7 + collect + (find 'c #(a b c d e c a) :start i :end j :from-end t))) ((nil nil c c c c c) (nil c c c c c) (c c c c c) @@ -250,7 +250,7 @@ (deftest find-vector.15 (find 'a #(a a b a c e d a f a) :test (complement #'eql) - :from-end t) + :from-end t) f) (deftest find-vector.16 @@ -259,7 +259,7 @@ (deftest find-vector.17 (find 'a #(a a b a c e d a f a) :test-not 'eql - :from-end t) + :from-end t) f) (deftest find-vector.18 @@ -268,7 +268,7 @@ (deftest find-vector.19 (find 'a #(a a b a c e d a f a) :test-not #'eql - :from-end t) + :from-end t) f) (deftest find-vector.20 @@ -277,22 +277,22 @@ (deftest find-vector.21 (find 'a #(a a b a c e d a f a) :test #'eql - :start 2) + :start 2) a) (deftest find-vector.22 (find 'a #(a a b a c e d a f a) :test #'eql - :start 2 :end nil) + :start 2 :end nil) a) (deftest find-vector.23 (find 'a #(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5) + :start 0 :end 5) b) (deftest find-vector.24 (find 'a #(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5 :from-end t) + :start 0 :end 5 :from-end t) c) (deftest find-vector.25 @@ -305,26 +305,26 @@ (deftest find-vector.27 (find 'a #((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car - :start 3) + :start 3) (a b)) (deftest find-vector.28 (find 'a #((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car - :start 2 :from-end t) + :start 2 :from-end t) (a b)) (deftest find-vector.29 (let ((a (make-array '(10) - :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 5))) + :initial-contents '(1 2 3 4 5 6 7 8 9 10) + :fill-pointer 5))) (loop for i from 1 to 10 collect (find i a))) (1 2 3 4 5 nil nil nil nil nil)) (deftest find-vector.30 (let ((a (make-array '(10) - :initial-contents (loop for i from 1 for e in '(1 2 3 4 5 5 4 3 2 1) - collect (list e i)) - :fill-pointer 5))) + :initial-contents (loop for i from 1 for e in '(1 2 3 4 5 5 4 3 2 1) + collect (list e i)) + :fill-pointer 5))) (loop for i from 1 to 5 collect (find i a :from-end t :key #'car))) ((1 1) (2 2) (3 3) (4 4) (5 5))) @@ -407,39 +407,39 @@ (deftest find-bit-vector.3 (loop for i from 0 to 7 collect - (find 1 #*0010010 :start i)) + (find 1 #*0010010 :start i)) (1 1 1 1 1 1 nil nil)) (deftest find-bit-vector.4 (loop for i from 0 to 7 collect - (find 1 #*0010010 :start i :end nil)) + (find 1 #*0010010 :start i :end nil)) (1 1 1 1 1 1 nil nil)) (deftest find-bit-vector.5 (loop for i from 7 downto 0 collect - (find 1 #*0010010 :end i)) + (find 1 #*0010010 :end i)) (1 1 1 1 1 nil nil nil)) (deftest find-bit-vector.6 (loop for i from 0 to 7 collect - (find 1 #*0010010 :start i :from-end t)) + (find 1 #*0010010 :start i :from-end t)) (1 1 1 1 1 1 nil nil)) (deftest find-bit-vector.7 (loop for i from 0 to 7 collect - (find 0 #*1101101 :start i :end nil :from-end t)) + (find 0 #*1101101 :start i :end nil :from-end t)) (0 0 0 0 0 0 nil nil)) (deftest find-bit-vector.8 (loop for i from 7 downto 0 collect - (find 0 #*1101101 :end i :from-end t)) + (find 0 #*1101101 :end i :from-end t)) (0 0 0 0 0 nil nil nil)) (deftest find-bit-vector.9 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find 1 #*0010010 :start i :end j))) + (loop for j from (1+ i) to 7 + collect + (find 1 #*0010010 :start i :end j))) ((nil nil 1 1 1 1 1) (nil 1 1 1 1 1) (1 1 1 1 1) @@ -450,9 +450,9 @@ (deftest find-bit-vector.10 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find 1 #*0010010 :start i :end j :from-end t))) + (loop for j from (1+ i) to 7 + collect + (find 1 #*0010010 :start i :end j :from-end t))) ((nil nil 1 1 1 1 1) (nil 1 1 1 1 1) (1 1 1 1 1) @@ -479,7 +479,7 @@ (deftest find-bit-vector.15 (find 0 #*0010111010 :test (complement #'eql) - :from-end t) + :from-end t) 1) (deftest find-bit-vector.16 @@ -496,17 +496,17 @@ (deftest find-bit-vector.17 (find 0 #*001011101 :test-not 'eql - :from-end t) + :from-end t) 1) (deftest find-bit-vector.17a (find 0 #*0000000 :test-not 'eql - :from-end t) + :from-end t) nil) (deftest find-bit-vector.17b (find 1 #*111111111111 :test-not 'eql - :from-end t) + :from-end t) nil) (deftest find-bit-vector.18 @@ -519,12 +519,12 @@ (deftest find-bit-vector.19 (find 0 #*00101110 :test-not #'eql - :from-end t) + :from-end t) 1) (deftest find-bit-vector.19a (find 0 #*00000000 :test-not #'eql - :from-end t) + :from-end t) nil) (deftest find-bit-vector.20 @@ -533,102 +533,102 @@ (deftest find-bit-vector.21 (find 0 #*00101110 :test #'eql - :start 2) + :start 2) 0) (deftest find-bit-vector.21a (find 0 #*00111111 :test #'eql - :start 2) + :start 2) nil) (deftest find-bit-vector.21b (find 1 #*00111111 :test #'eql - :start 2) + :start 2) 1) (deftest find-bit-vector.22 (find 0 #*00101110 :test #'eql - :start 2 :end nil) + :start 2 :end nil) 0) (deftest find-bit-vector.22a (find 0 #*001111111 :test #'eql - :start 2 :end nil) + :start 2 :end nil) nil) (deftest find-bit-vector.22b (find 1 #*001111111 :test #'eql - :start 2 :end nil) + :start 2 :end nil) 1) (deftest find-bit-vector.23 (find 0 #*00101110 :test-not #'eql - :start 0 :end 5) + :start 0 :end 5) 1) (deftest find-bit-vector.23a (find 0 #*00000111 :test-not #'eql - :start 0 :end 5) + :start 0 :end 5) nil) (deftest find-bit-vector.23b (find 0 #*00001000 :test-not #'eql - :start 0 :end 5) + :start 0 :end 5) 1) (deftest find-bit-vector.24 (find 0 #*00101110 :test-not #'eql - :start 0 :end 5 :from-end t) + :start 0 :end 5 :from-end t) 1) (deftest find-bit-vector.24a (find 0 #*0000001111 :test-not #'eql - :start 0 :end 5 :from-end t) + :start 0 :end 5 :from-end t) nil) (deftest find-bit-vector.24b (find 0 #*0000100 :test-not #'eql - :start 0 :end 5 :from-end t) + :start 0 :end 5 :from-end t) 1) (deftest find-bit-vector.25 (find 2 #*1100001010 :key #'1+ - :start 3) + :start 3) 1) (deftest find-bit-vector.26 (find 2 #*11100000 :key #'1+ - :start 3) + :start 3) nil) (deftest find-bit-vector.26a (find 2 #*11110000 :key #'1+ - :start 3) + :start 3) 1) (deftest find-bit-vector.27 (find 2 #*1100001010 :key #'1+ - :start 2 :from-end t) + :start 2 :from-end t) 1) (deftest find-bit-vector.28 (find 2 #*1100000000 :key #'1+ - :start 2 :from-end t) + :start 2 :from-end t) nil) (deftest find-bit-vector.29 (let ((a - (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5))) + (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) + :element-type 'bit + :fill-pointer 5))) (values (find 0 a) - (find 0 a :from-end t))) + (find 0 a :from-end t))) nil nil) (deftest find-bit-vector.30 (let ((a (make-array '(10) :initial-contents '(1 1 1 1 0 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5))) + :element-type 'bit + :fill-pointer 5))) (values (find 0 a) (find 0 a :from-end t))) 0 0) @@ -668,39 +668,39 @@ (deftest find-string.3 (loop for i from 0 to 7 collect - (find #\c "abcdeca" :start i)) + (find #\c "abcdeca" :start i)) (#\c #\c #\c #\c #\c #\c nil nil)) (deftest find-string.4 (loop for i from 0 to 7 collect - (find #\c "abcdeca" :start i :end nil)) + (find #\c "abcdeca" :start i :end nil)) (#\c #\c #\c #\c #\c #\c nil nil)) (deftest find-string.5 (loop for i from 7 downto 0 collect - (find #\c "abcdeca" :end i)) + (find #\c "abcdeca" :end i)) (#\c #\c #\c #\c #\c nil nil nil)) (deftest find-string.6 (loop for i from 0 to 7 collect - (find #\c "abcdeca" :start i :from-end t)) + (find #\c "abcdeca" :start i :from-end t)) (#\c #\c #\c #\c #\c #\c nil nil)) (deftest find-string.7 (loop for i from 0 to 7 collect - (find #\c "abcdeca" :start i :end nil :from-end t)) + (find #\c "abcdeca" :start i :end nil :from-end t)) (#\c #\c #\c #\c #\c #\c nil nil)) (deftest find-string.8 (loop for i from 7 downto 0 collect - (find #\c "abcdeca" :end i :from-end t)) + (find #\c "abcdeca" :end i :from-end t)) (#\c #\c #\c #\c #\c nil nil nil)) (deftest find-string.9 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find #\c "abcdeca" :start i :end j))) + (loop for j from (1+ i) to 7 + collect + (find #\c "abcdeca" :start i :end j))) ((nil nil #\c #\c #\c #\c #\c) (nil #\c #\c #\c #\c #\c) (#\c #\c #\c #\c #\c) @@ -711,9 +711,9 @@ (deftest find-string.10 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (find #\c "abcdeca" :start i :end j :from-end t))) + (loop for j from (1+ i) to 7 + collect + (find #\c "abcdeca" :start i :end j :from-end t))) ((nil nil #\c #\c #\c #\c #\c) (nil #\c #\c #\c #\c #\c) (#\c #\c #\c #\c #\c) @@ -724,13 +724,13 @@ (deftest find-string.11 (find 5 "12345648" :key #'(lambda (c) - (1+ (read-from-string (string c))))) + (1+ (read-from-string (string c))))) #\4) (deftest find-string.13 (find 5 "12345648" :key #'(lambda (c) - (1+ (read-from-string (string c)))) - :from-end t) + (1+ (read-from-string (string c)))) + :from-end t) #\4) (deftest find-string.14 @@ -739,7 +739,7 @@ (deftest find-string.15 (find #\a "aabacedafa" :test (complement #'eql) - :from-end t) + :from-end t) #\f) (deftest find-string.16 @@ -748,7 +748,7 @@ (deftest find-string.17 (find #\a "aabacedafa" :test-not 'eql - :from-end t) + :from-end t) #\f) (deftest find-string.18 @@ -757,7 +757,7 @@ (deftest find-string.19 (find #\a "aabacedafa" :test-not #'eql - :from-end t) + :from-end t) #\f) (deftest find-string.20 @@ -766,33 +766,33 @@ (deftest find-string.21 (find #\a "aabAcedafa" :test #'char-equal - :start 2) + :start 2) #\A) (deftest find-string.22 (find #\a "aabAcedafa" :test #'char-equal - :start 2 :end nil) + :start 2 :end nil) #\A) (deftest find-string.23 (find #\a "aAbAcedafa" :test-not #'char-equal - :start 0 :end 5) + :start 0 :end 5) #\b) (deftest find-string.24 (find #\a "aabacedafa" :test-not #'char-equal - :start 0 :end 5 :from-end t) + :start 0 :end 5 :from-end t) #\c) (deftest find-string.25 (let ((s (make-array '(10) :initial-contents "abcdefghij" - :element-type 'character - :fill-pointer 5))) + :element-type 'character + :fill-pointer 5))) (values (loop for e across "abcdefghij" - collect (find e s)) + collect (find e s)) (loop for e across "abcdefghij" - collect (find e s :from-end t)))) + collect (find e s :from-end t)))) (#\a #\b #\c #\d #\e nil nil nil nil nil) (#\a #\b #\c #\d #\e nil nil nil nil nil)) @@ -840,20 +840,20 @@ (deftest find.allow-other-keys.1 (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) - :bad t :allow-other-keys t) + :bad t :allow-other-keys t) 2) (deftest find.allow-other-keys.2 (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) - :allow-other-keys t :also-bad t) + :allow-other-keys t :also-bad t) 2) ;;; The leftmost of two :allow-other-keys arguments is the one that matters. (deftest find.allow-other-keys.3 (find 0 '(1 2 3 4 5) :key #'(lambda (x) (mod x 2)) - :allow-other-keys t - :allow-other-keys nil - :bad t) + :allow-other-keys t + :allow-other-keys nil + :bad t) 2) (deftest find.keywords.4 @@ -889,7 +889,7 @@ (deftest find.error.8 (signals-error (find 'a nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest find.error.9 @@ -927,7 +927,7 @@ (let ((i 0) x y) (values (find (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) '(nil nil nil a nil nil))) + (progn (setf y (incf i)) '(nil nil nil a nil nil))) i x y)) a 2 1 2) @@ -935,12 +935,12 @@ (let ((i 0) a b c d e f) (values (find (progn (setf a (incf i)) nil) - (progn (setf b (incf i)) '(nil nil nil a nil nil)) - :start (progn (setf c (incf i)) 1) - :end (progn (setf d (incf i)) 4) - :from-end (setf e (incf i)) - :key (progn (setf f (incf i)) #'null) - ) + (progn (setf b (incf i)) '(nil nil nil a nil nil)) + :start (progn (setf c (incf i)) 1) + :end (progn (setf d (incf i)) 4) + :from-end (setf e (incf i)) + :key (progn (setf f (incf i)) #'null) + ) i a b c d e f)) a 6 1 2 3 4 5 6) @@ -948,11 +948,11 @@ (let ((i 0) a b c d e f) (values (find (progn (setf a (incf i)) nil) - (progn (setf b (incf i)) '(nil nil nil a nil nil)) - :key (progn (setf c (incf i)) #'null) - :from-end (setf d (incf i)) - :end (progn (setf e (incf i)) 4) - :start (progn (setf f (incf i)) 1) - ) + (progn (setf b (incf i)) '(nil nil nil a nil nil)) + :key (progn (setf c (incf i)) #'null) + :from-end (setf d (incf i)) + :end (progn (setf e (incf i)) 4) + :start (progn (setf f (incf i)) 1) + ) i a b c d e f)) a 6 1 2 3 4 5 6) diff --git a/ansi-tests/finish-output.lsp b/ansi-tests/finish-output.lsp index f6fab14e..4b398e92 100644 --- a/ansi-tests/finish-output.lsp +++ b/ansi-tests/finish-output.lsp @@ -19,16 +19,16 @@ (deftest finish-output.4 (loop for s in (list *debug-io* *error-output* *query-io* - *standard-output* *trace-output* *terminal-io*) - for results = (multiple-value-list (finish-output s)) - unless (equal results '(nil)) - collect s) + *standard-output* *trace-output* *terminal-io*) + for results = (multiple-value-list (finish-output s)) + unless (equal results '(nil)) + collect s) nil) (deftest finish-output.5 (let ((os (make-string-output-stream))) (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "") - os))) + os))) (finish-output t))) nil) @@ -49,6 +49,6 @@ (deftest finish-output.error.3 (check-type-error #'finish-output - #'(lambda (x) (typep x '(or stream (member nil t))))) + #'(lambda (x) (typep x '(or stream (member nil t))))) nil) diff --git a/ansi-tests/flet.lsp b/ansi-tests/flet.lsp index 3c037227..a7817598 100644 --- a/ansi-tests/flet.lsp +++ b/ansi-tests/flet.lsp @@ -25,7 +25,7 @@ (deftest flet.4 (block %f (flet ((%f (&optional (x (return-from %f :good))) - nil)) + nil)) (%f) :bad)) :good) @@ -35,7 +35,7 @@ (deftest flet.4a (block %f (flet ((%f (&key (x (return-from %f :good))) - nil)) + nil)) (%f) :bad)) :good) @@ -50,7 +50,7 @@ (deftest flet.6 (block %f (flet ((%f (&aux (x (return-from %f 10))) - 20)) + 20)) (%f))) 10) @@ -58,7 +58,7 @@ (deftest flet.7 (flet ((%f (x) (+ x 5))) (flet ((%f (y) (cond ((eql y 20) 30) - (t (%f 20))))) + (t (%f 20))))) (%f 15))) 25) @@ -133,45 +133,45 @@ ;;; Can handle at least 50 lambda parameters (deftest flet.19 (flet ((%f (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 - b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 - c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 - d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 - e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) - (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 - b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 - c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 - d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 - e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) + b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 + c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 + e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) + (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 + c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 + e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) (%f 1 2 3 4 5 6 7 8 9 10 - 11 12 13 14 15 16 17 18 19 20 - 21 22 23 24 25 26 27 28 29 30 - 31 32 33 34 35 36 37 38 39 40 - 41 42 43 44 45 46 47 48 49 50)) + 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 + 31 32 33 34 35 36 37 38 39 40 + 41 42 43 44 45 46 47 48 49 50)) 1275) ;;; flet works with a large (maximal?) number of arguments (deftest flet.20 (let* ((n (min (1- lambda-parameters-limit) 1024)) - (vars (loop repeat n collect (gensym)))) + (vars (loop repeat n collect (gensym)))) (eval `(eqlt ,n - (flet ((%f ,vars (+ ,@ vars))) - (%f ,@(loop for e in vars collect 1)))))) + (flet ((%f ,vars (+ ,@ vars))) + (%f ,@(loop for e in vars collect 1)))))) t) ;;; Declarations and documentation strings are ok (deftest flet.21 (flet ((%f (x) - (declare (type fixnum x)) - "Add one to the fixnum x." - (1+ x))) + (declare (type fixnum x)) + "Add one to the fixnum x." + (1+ x))) (declare (ftype (function (fixnum) integer) %f)) (%f 10)) 11) (deftest flet.22 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p)) - (list x y (not (not y-p)) z (not (not z-p))))) + (list x y (not (not y-p)) z (not (not z-p))))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c))) (10 1 nil 2 nil) (20 40 t 2 nil) @@ -179,7 +179,7 @@ (deftest flet.23 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r) - (list x y (not (not y-p)) z (not (not z-p)) r))) + (list x y (not (not y-p)) z (not (not z-p)) r))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) (%f 'd 'e 'f 'g 'h))) (10 1 nil 2 nil nil) (20 40 t 2 nil nil) @@ -188,10 +188,10 @@ (deftest flet.24 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) - (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) + (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) - (%f 'd 'e 'f :foo 'h) - (%f 'd 'e 'f :bar 'i) )) + (%f 'd 'e 'f :foo 'h) + (%f 'd 'e 'f :bar 'i) )) (10 1 nil 2 nil nil nil nil) (20 40 t 2 nil nil nil nil) (a b t c t nil nil nil) @@ -200,11 +200,11 @@ (deftest flet.25 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar - &allow-other-keys) - (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) + &allow-other-keys) + (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) - (%f 'd 'e 'f :foo 'h :whatever nil) - (%f 'd 'e 'f :bar 'i :illegal t :foo 'z) )) + (%f 'd 'e 'f :foo 'h :whatever nil) + (%f 'd 'e 'f :bar 'i :illegal t :foo 'z) )) (10 1 nil 2 nil nil nil nil) (20 40 t 2 nil nil nil nil) (a b t c t nil nil nil) @@ -213,10 +213,10 @@ (deftest flet.26 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) - (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) + (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) - (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys t) - (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys t) )) + (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys t) + (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys t) )) (10 1 nil 2 nil nil nil nil) (20 40 t 2 nil nil nil nil) (a b t c t nil nil nil) @@ -228,10 +228,10 @@ ;;; associated value is false." (deftest flet.27 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r &key foo bar) - (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) + (list x y (not (not y-p)) z (not (not z-p)) r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) - (%f 'd 'e 'f :foo 'h :allow-other-keys nil) - (%f 'd 'e 'f :bar 'i :allow-other-keys nil) )) + (%f 'd 'e 'f :foo 'h :allow-other-keys nil) + (%f 'd 'e 'f :bar 'i :allow-other-keys nil) )) (10 1 nil 2 nil nil nil nil) (20 40 t 2 nil nil nil nil) (a b t c t nil nil nil) @@ -240,12 +240,12 @@ (deftest flet.28 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r - &key foo bar allow-other-keys) - (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys - r foo bar))) + &key foo bar allow-other-keys) + (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys + r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) - (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys 100) - (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys 200) )) + (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys 100) + (%f 'd 'e 'f :bar 'i :illegal t :foo 'z :allow-other-keys 200) )) (10 1 nil 2 nil nil nil nil nil) (20 40 t 2 nil nil nil nil nil) (a b t c t nil nil nil nil) @@ -254,13 +254,13 @@ (deftest flet.29 (flet ((%f (x &optional (y 1 y-p) (z 2 z-p) &rest r - &key foo bar allow-other-keys &allow-other-keys) - (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys - r foo bar))) + &key foo bar allow-other-keys &allow-other-keys) + (list x y (not (not y-p)) z (not (not z-p)) allow-other-keys + r foo bar))) (values (%f 10) (%f 20 40) (%f 'a 'b 'c) - (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys nil :blah t) - (%f 'd 'e 'f :bar 'i :illegal t :foo 'z - :allow-other-keys nil :zzz 10) )) + (%f 'd 'e 'f :foo 'h :whatever nil :allow-other-keys nil :blah t) + (%f 'd 'e 'f :bar 'i :illegal t :foo 'z + :allow-other-keys nil :zzz 10) )) (10 1 nil 2 nil nil nil nil nil) (20 40 t 2 nil nil nil nil nil) (a b t c t nil nil nil nil) @@ -283,17 +283,17 @@ (flet ((%f (&key a b c) (list a b c))) (%f :a 10 :b 20 :c 30 :a 40 :b 50 :c 60)) (10 20 30)) - + ;;; More aux parameters (deftest flet.33 (flet ((%f (x y &aux (a (1+ x)) (b (+ x y a)) (c (list x y a b))) - c)) + c)) (%f 5 9)) (5 9 6 20)) (deftest flet.34 (flet ((%f (x y &rest r &key foo bar &aux (c (list x y r foo bar))) - c)) + c)) (values (%f 1 2) (%f 1 2 :foo 'a) @@ -312,9 +312,9 @@ (declare (special x)) (flet ((%f () x)) (flet ((%g (x) - (declare (special x)) - (%f))) - (%g 'good)))) + (declare (special x)) + (%f))) + (%g 'good)))) good) (deftest flet.36 @@ -322,9 +322,9 @@ (declare (special x)) (flet ((%f () x)) (flet ((%g (&aux (x 'good)) - (declare (special x)) - (%f))) - (%g)))) + (declare (special x)) + (%f))) + (%g)))) good) (deftest flet.37 @@ -332,9 +332,9 @@ (declare (special x)) (flet ((%f () x)) (flet ((%g (&rest x) - (declare (special x)) - (%f))) - (%g 'good)))) + (declare (special x)) + (%f))) + (%g 'good)))) (good)) (deftest flet.38 @@ -342,9 +342,9 @@ (declare (special x)) (flet ((%f () x)) (flet ((%g (&key (x 'good)) - (declare (special x)) - (%f))) - (%g)))) + (declare (special x)) + (%f))) + (%g)))) good) (deftest flet.39 @@ -352,9 +352,9 @@ (declare (special x)) (flet ((%f () x)) (flet ((%g (&key (x 'bad)) - (declare (special x)) - (%f))) - (%g :x 'good)))) + (declare (special x)) + (%f))) + (%g :x 'good)))) good) (deftest flet.40 @@ -362,8 +362,8 @@ (declare (special x)) (flet ((%f () x)) (flet ((%g (&key (x 'bad)) - (%f))) - (%g :x 'worse)))) + (%f))) + (%g :x 'worse)))) good) @@ -386,31 +386,31 @@ (deftest flet.49 (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors (flet ((,s () 'a)) (,s))) - unless (eq (eval form) 'a) - collect s) + for form = `(ignore-errors (flet ((,s () 'a)) (,s))) + unless (eq (eval form) 'a) + collect s) nil) (deftest flet.50 (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors (flet ((,s () 'a)) - (declare (ftype (function () symbol) - ,s)) - (,s))) - unless (eq (eval form) 'a) - collect s) + for form = `(ignore-errors (flet ((,s () 'a)) + (declare (ftype (function () symbol) + ,s)) + (,s))) + unless (eq (eval form) 'a) + collect s) nil) ;;; Binding SETF functions of certain COMMON-LISP symbols (deftest flet.51 (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors - (flet (((setf ,s) (&rest args) - (declare (ignore args)) - 'a)) - (setf (,s) 10))) - unless (eq (eval form) 'a) - collect s) + for form = `(ignore-errors + (flet (((setf ,s) (&rest args) + (declare (ignore args)) + 'a)) + (setf (,s) 10))) + unless (eq (eval form) 'a) + collect s) nil) ;;; Check that FLET does not have a tagbody @@ -475,9 +475,9 @@ (declare (special x)) (let ((x :good)) (flet ((%f (&optional (y x)) - (declare (special x)) - y)) - (%f)))) + (declare (special x)) + y)) + (%f)))) :good) (deftest flet.63 @@ -485,9 +485,9 @@ (declare (special x)) (let ((x :good)) (flet ((%f (&key (y x)) - (declare (special x)) - y)) - (%f)))) + (declare (special x)) + y)) + (%f)))) :good) (deftest flet.64 @@ -511,7 +511,7 @@ (declare (special x)) (let ((x :good)) (flet ((%f () (declare (special x)))) - x))) + x))) :good) (deftest flet.67 @@ -519,9 +519,9 @@ (declare (special x)) (let ((x :good)) (flet ((%f (&aux (y x)) - (declare (special x)) - y)) - (%f)))) + (declare (special x)) + y)) + (%f)))) :good) (deftest flet.68 @@ -529,17 +529,17 @@ (declare (special x)) (let ((x :good)) (flet ((%f () x)) - (declare (special x)) - (%f)))) + (declare (special x)) + (%f)))) :good) (deftest flet.69 (let ((*x* 0)) (declare (special *x*)) (flet ((%f (i) - #'(lambda (arg) - (declare (ignore arg)) - (incf *x* i)))) + #'(lambda (arg) + (declare (ignore arg)) + (incf *x* i)))) (values (mapcar (%f 1) '(a b c)) (mapcar (%f 2) '(a b c))))) @@ -550,13 +550,13 @@ (deftest flet.70 (macrolet ((%m (z) z)) - (flet () (expand-in-current-env (%m :good)))) + (flet () (expand-in-current-env (%m :good)))) :good) (deftest flet.71 (macrolet ((%m (z) z)) - (flet ((%f () (expand-in-current-env (%m :good)))) - (%f))) + (flet ((%f () (expand-in-current-env (%m :good)))) + (%f))) :good) diff --git a/ansi-tests/float.lsp b/ansi-tests/float.lsp index 8f097df0..a92daf81 100644 --- a/ansi-tests/float.lsp +++ b/ansi-tests/float.lsp @@ -18,7 +18,7 @@ (deftest float.1 (notnot (member (float 0) '(0.0f0 -0.0f0))) t) - + (deftest float.2 (float 1) 1.0f0) @@ -29,75 +29,75 @@ (deftest float.4 (loop for i from -1000 to 1000 - always - (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - for tp in '(short-float single-float double-float long-float) - for y = (float i x) - always (and (= i y) (typep y tp)))) + always + (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) + for tp in '(short-float single-float double-float long-float) + for y = (float i x) + always (and (= i y) (typep y tp)))) t) (deftest float.5 (loop for x in *reals* - always (or (not (floatp x)) - (eql (float x) x))) + always (or (not (floatp x)) + (eql (float x) x))) t) (deftest float.6 (loop for x in *reals* - unless (handler-case - (or (not (typep x 'short-float)) - (let ((y (float x 0.0f0))) - (and (typep y 'single-float) - (= x y)))) - (arithmetic-error () t)) - collect x) + unless (handler-case + (or (not (typep x 'short-float)) + (let ((y (float x 0.0f0))) + (and (typep y 'single-float) + (= x y)))) + (arithmetic-error () t)) + collect x) nil) - + (deftest float.7 (loop for x in *reals* - unless (or (not (typep x 'short-float)) - (let ((y (float x 0.0d0))) - (and (typep y 'double-float) - (= x y)))) - collect x) + unless (or (not (typep x 'short-float)) + (let ((y (float x 0.0d0))) + (and (typep y 'double-float) + (= x y)))) + collect x) nil) (deftest float.8 (loop for x in *reals* - unless (or (not (typep x 'short-float)) - (let ((y (float x 0.0l0))) - (and (typep y 'long-float) - (= x y)))) - collect x) + unless (or (not (typep x 'short-float)) + (let ((y (float x 0.0l0))) + (and (typep y 'long-float) + (= x y)))) + collect x) nil) (deftest float.9 (loop for x in *reals* - unless (or (not (typep x 'single-float)) - (let ((y (float x 0.0d0))) - (and (typep y 'double-float) - (= x y)))) - collect x) + unless (or (not (typep x 'single-float)) + (let ((y (float x 0.0d0))) + (and (typep y 'double-float) + (= x y)))) + collect x) nil) (deftest float.10 (loop for x in *reals* - unless (or (not (typep x 'single-float)) - (let ((y (float x 0.0l0))) - (and (typep y 'long-float) - (= x y)))) - collect x) + unless (or (not (typep x 'single-float)) + (let ((y (float x 0.0l0))) + (and (typep y 'long-float) + (= x y)))) + collect x) nil) - + (deftest float.11 (loop for x in *reals* - unless (or (not (typep x 'double-float)) - (let ((y (float x 0.0l0))) - (and (typep y 'long-float) - (= x y)))) - collect x) + unless (or (not (typep x 'double-float)) + (let ((y (float x 0.0l0))) + (and (typep y 'long-float) + (= x y)))) + collect x) nil) - + diff --git a/ansi-tests/floor-aux.lsp b/ansi-tests/floor-aux.lsp index 49754304..0c315383 100644 --- a/ansi-tests/floor-aux.lsp +++ b/ansi-tests/floor-aux.lsp @@ -7,102 +7,102 @@ (defun floor.1-fn () (loop for n = (- (random 2000000000) - 1000000000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (floor n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (integerp r) - (< -1 r d)) - collect (list n d q r n2))) + 1000000000) + for d = (1+ (random 10000)) + for vals = (multiple-value-list (floor n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (= n n2) + (integerp r) + (< -1 r d)) + collect (list n d q r n2))) (defun floor.2-fn () (loop for num = (random 1000000000) - for denom = (1+ (random 1000)) - for n = (/ num denom) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (floor n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (<= 0 r) - (< r d) - (= n n2)) - collect (list n d q r n2))) + for denom = (1+ (random 1000)) + for n = (/ num denom) + for d = (1+ (random 10000)) + for vals = (multiple-value-list (floor n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (<= 0 r) + (< r d) + (= n n2)) + collect (list n d q r n2))) (defun floor.3-fn (width) (loop for n = (- (random width) (/ width 2)) - for vals = (multiple-value-list (floor n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (<= 0 r) - (< r 1) - ) - collect (list n q r n2))) + for vals = (multiple-value-list (floor n)) + for (q r) = vals + for n2 = (+ q r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (= n n2) + (<= 0 r) + (< r 1) + ) + collect (list n q r n2))) (defun floor.7-fn () (loop for numerator = (- (random 10000000000) 5000000000) - for denominator = (1+ (random 100000)) - for n = (/ numerator denominator) - for vals = (multiple-value-list (floor n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (= n n2) - (<= 0 r) - (< r 1) - ) - collect (list n q r n2))) + for denominator = (1+ (random 100000)) + for n = (/ numerator denominator) + for vals = (multiple-value-list (floor n)) + for (q r) = vals + for n2 = (+ q r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (rationalp r) + (= n n2) + (<= 0 r) + (< r 1) + ) + collect (list n q r n2))) (defun floor.8-fn () (loop for num1 = (- (random 10000000000) 5000000000) - for den1 = (1+ (random 100000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000))) - for den2 = (1+ (random 1000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (floor n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (>= 0 r) - (> r d) - (= n n2)) - collect (list n q d r n2))) + for den1 = (1+ (random 100000)) + for n = (/ num1 den1) + for num2 = (- (1+ (random 1000000))) + for den2 = (1+ (random 1000000)) + for d = (/ num2 den2) + for vals = (multiple-value-list (floor n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (rationalp r) + (>= 0 r) + (> r d) + (= n n2)) + collect (list n q d r n2))) (defun floor.9-fn () (loop for num1 = (- (random 1000000000000000) 500000000000000) - for den1 = (1+ (random 10000000000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000000))) - for den2 = (1+ (random 10000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (floor n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (>= 0 r) - (> r d) - (= n n2)) - collect (list n q d r n2))) + for den1 = (1+ (random 10000000000)) + for n = (/ num1 den1) + for num2 = (- (1+ (random 1000000000))) + for den2 = (1+ (random 10000000)) + for d = (/ num2 den2) + for vals = (multiple-value-list (floor n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (rationalp r) + (>= 0 r) + (> r d) + (= n n2)) + collect (list n q d r n2))) ;;; Need float tests diff --git a/ansi-tests/floor.lsp b/ansi-tests/floor.lsp index bd838540..50828587 100644 --- a/ansi-tests/floor.lsp +++ b/ansi-tests/floor.lsp @@ -58,118 +58,118 @@ (deftest floor.10 (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (floor x x)) - unless (and (eql q 1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) + for (q r) = (multiple-value-list (floor x x)) + unless (and (eql q 1) + (zerop r) + (if (rationalp x) (eql r 0) + (eql r (float 0 x)))) + collect x) nil) (deftest floor.11 (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (floor (- x) x)) - unless (and (eql q -1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) + for (q r) = (multiple-value-list (floor (- x) x)) + unless (and (eql q -1) + (zerop r) + (if (rationalp x) (eql r 0) + (eql r (float 0 x)))) + collect x) nil) (deftest floor.12 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (floor x)) + unless (and (eql q i) + (eql r rrad)) + collect (list i x q r))) nil) (deftest floor.13 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (floor x)) + unless (and (eql q (1- i)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest floor.14 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (floor x)) + unless (and (eql q i) + (eql r rrad)) + collect (list i x q r))) nil) (deftest floor.15 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (floor x)) + unless (and (eql q (1- i)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest floor.16 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (floor x)) + unless (and (eql q i) + (eql r rrad)) + collect (list i x q r))) nil) (deftest floor.17 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (floor x)) + unless (and (eql q (1- i)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest floor.18 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (floor x)) + unless (and (eql q i) + (eql r rrad)) + collect (list i x q r))) nil) (deftest floor.19 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (floor x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (floor x)) + unless (and (eql q (1- i)) + (eql r rrad)) + collect (list i x q r))) nil) ;;; To add: tests that involve adding/subtracting EPSILON constants diff --git a/ansi-tests/fmakunbound.lsp b/ansi-tests/fmakunbound.lsp index 026afada..0385032c 100644 --- a/ansi-tests/fmakunbound.lsp +++ b/ansi-tests/fmakunbound.lsp @@ -8,48 +8,48 @@ (deftest fmakunbound.1 (let ((g (gensym))) (and (not (fboundp g)) - (setf (symbol-function g) #'car) - (fboundp g) - (values (eqt (check-values (fmakunbound g)) g) - (fboundp g)))) + (setf (symbol-function g) #'car) + (fboundp g) + (values (eqt (check-values (fmakunbound g)) g) + (fboundp g)))) t nil) (deftest fmakunbound.2 (let ((g (gensym))) (and (not (fboundp g)) - (eval `(defun ,g () nil)) - (fboundp g) - (values (eqt (check-values (fmakunbound g)) g) - (fboundp g)))) + (eval `(defun ,g () nil)) + (fboundp g) + (values (eqt (check-values (fmakunbound g)) g) + (fboundp g)))) t nil) (deftest fmakunbound.3 (let ((g (gensym))) (and (not (fboundp g)) - (eval `(defmacro ,g () nil)) - (fboundp g) - (values (eqt (check-values (fmakunbound g)) g) - (fboundp g)))) + (eval `(defmacro ,g () nil)) + (fboundp g) + (values (eqt (check-values (fmakunbound g)) g) + (fboundp g)))) t nil) (deftest fmakunbound.4 (let* ((g (gensym)) - (n `(setf ,g))) + (n `(setf ,g))) (and (not (fboundp n)) - (eval `(defun ,n () nil)) - (fboundp n) - (values (equalt (check-values (fmakunbound n)) n) - (fboundp n)))) + (eval `(defun ,n () nil)) + (fboundp n) + (values (equalt (check-values (fmakunbound n)) n) + (fboundp n)))) t nil) (deftest fmakunbound.error.1 (check-type-error #'fmakunbound - #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) + #'(lambda (x) (typep x '(or symbol (cons (eql setf) (cons symbol null)))))) nil) (deftest fmakunbound.error.2 (check-type-error #'fmakunbound (constantly nil) - '((setf) (setf . foo) (setf foo . bar) (setf foo bar))) + '((setf) (setf . foo) (setf foo . bar) (setf foo bar))) nil) (deftest fmakunbound.error.3 @@ -70,13 +70,13 @@ (deftest fmakunbound.error.7 (loop for x in *mini-universe* - unless (symbolp x) - nconc - (handler-case - (list x (fmakunbound `(setf ,x))) - (type-error (c) - (assert (not (typep (type-error-datum c) - (type-error-expected-type c)))) - nil) - (error (c) (list (list x c))))) - nil) \ No newline at end of file + unless (symbolp x) + nconc + (handler-case + (list x (fmakunbound `(setf ,x))) + (type-error (c) + (assert (not (typep (type-error-datum c) + (type-error-expected-type c)))) + nil) + (error (c) (list (list x c))))) + nil) diff --git a/ansi-tests/force-output.lsp b/ansi-tests/force-output.lsp index af3584bc..9ae066d8 100644 --- a/ansi-tests/force-output.lsp +++ b/ansi-tests/force-output.lsp @@ -19,16 +19,16 @@ (deftest force-output.4 (loop for s in (list *debug-io* *error-output* *query-io* - *standard-output* *trace-output* *terminal-io*) - for results = (multiple-value-list (force-output s)) - unless (equal results '(nil)) - collect s) + *standard-output* *trace-output* *terminal-io*) + for results = (multiple-value-list (force-output s)) + unless (equal results '(nil)) + collect s) nil) (deftest force-output.5 (let ((os (make-string-output-stream))) (let ((*terminal-io* (make-two-way-stream (make-string-input-stream "") - os))) + os))) (force-output t))) nil) @@ -50,7 +50,7 @@ (deftest force-output.error.3 (check-type-error #'force-output - #'(lambda (x) (typep x '(or stream (member nil t))))) + #'(lambda (x) (typep x '(or stream (member nil t))))) nil) diff --git a/ansi-tests/format-a.lsp b/ansi-tests/format-a.lsp index 2b055f31..b7d1b02a 100644 --- a/ansi-tests/format-a.lsp +++ b/ansi-tests/format-a.lsp @@ -45,24 +45,24 @@ (deftest format.a.7 (let ((fn (formatter "~a"))) (loop for c across +standard-chars+ - for s1 = (string c) - for s2 = (format nil "~a" s1) - for s3 = (formatter-call-to-string fn s1) - unless (and (string= s1 s2) (string= s2 s3)) - collect (list c s1 s2 s3))) + for s1 = (string c) + for s2 = (format nil "~a" s1) + for s3 = (formatter-call-to-string fn s1) + unless (and (string= s1 s2) (string= s2 s3)) + collect (list c s1 s2 s3))) nil) (deftest format.a.8 (let ((fn (formatter "~A"))) (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s1 = (and c (string c)) - for s2 = (and c (format nil "~A" s1)) - for s3 = (and c (formatter-call-to-string fn s1)) - unless (or (null c) (string= s1 s2) (string= s2 s3)) - do (incf count) and collect (list c s1 s2 s3) - when (> count 100) collect "count limit exceeded" and do (loop-finish))) + for i from 0 below (min #x10000 char-code-limit) + for c = (code-char i) + for s1 = (and c (string c)) + for s2 = (and c (format nil "~A" s1)) + for s3 = (and c (formatter-call-to-string fn s1)) + unless (or (null c) (string= s1 s2) (string= s2 s3)) + do (incf count) and collect (list c s1 s2 s3) + when (> count 100) collect "count limit exceeded" and do (loop-finish))) nil) (deftest format.a.9 @@ -70,12 +70,12 @@ (apply #'values (loop for i from 1 to 10 - for fmt = (format nil "~~~d@a" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s))) + for fmt = (format nil "~~~d@a" i) + for s = (format nil fmt nil) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn nil) + do (assert (string= s s2)) + collect s))) "NIL" "NIL" "NIL" @@ -92,12 +92,12 @@ (apply #'values (loop for i from 1 to 10 - for fmt = (format nil "~~~da" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s))) + for fmt = (format nil "~~~da" i) + for s = (format nil fmt nil) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn nil) + do (assert (string= s s2)) + collect s))) "NIL" "NIL" "NIL" @@ -114,12 +114,12 @@ (apply #'values (loop for i from 1 to 10 - for fmt = (format nil "~~~d@:A" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s))) + for fmt = (format nil "~~~d@:A" i) + for s = (format nil fmt nil) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn nil) + do (assert (string= s s2)) + collect s))) "()" "()" " ()" @@ -136,12 +136,12 @@ (apply #'values (loop for i from 1 to 10 - for fmt = (format nil "~~~d:a" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s))) + for fmt = (format nil "~~~d:a" i) + for s = (format nil fmt nil) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn nil) + do (assert (string= s s2)) + collect s))) "()" "()" "() " @@ -159,10 +159,10 @@ #'values (let ((fn (formatter "~V:a"))) (loop for i from 1 to 10 - for s = (format nil "~v:A" i nil) - for s2 = (formatter-call-to-string fn i nil) - do (assert (string= s s2)) - collect s)))) + for s = (format nil "~v:A" i nil) + for s2 = (formatter-call-to-string fn i nil) + do (assert (string= s s2)) + collect s)))) "()" "()" "() " @@ -180,10 +180,10 @@ #'values (let ((fn (formatter "~V@:A"))) (loop for i from 1 to 10 - for s = (format nil "~v:@a" i nil) - for s2 = (formatter-call-to-string fn i nil) - do (assert (string= s s2)) - collect s)))) + for s = (format nil "~v:@a" i nil) + for s2 = (formatter-call-to-string fn i nil) + do (assert (string= s s2)) + collect s)))) "()" "()" " ()" @@ -244,10 +244,10 @@ (deftest format.a.29 (let ((fn (formatter "~v,,2A"))) (loop for i from -4 to 10 - for s = (format nil "~v,,2A" i "ABC") - for s2 = (formatter-call-to-string fn i "ABC") - do (assert (string= s s2)) - collect s)) + for s = (format nil "~v,,2A" i "ABC") + for s2 = (formatter-call-to-string fn i "ABC") + do (assert (string= s s2)) + collect s)) ("ABC " "ABC " "ABC " @@ -313,10 +313,10 @@ (deftest format.a.44 (let ((fn (formatter "~3,,vA"))) (loop for i from 0 to 6 - for s =(format nil "~3,,vA" i "ABC") - for s2 = (formatter-call-to-string fn i "ABC") - do (assert (string= s s2)) - collect s)) + for s =(format nil "~3,,vA" i "ABC") + for s2 = (formatter-call-to-string fn i "ABC") + do (assert (string= s s2)) + collect s)) ("ABC" "ABC " "ABC " @@ -328,10 +328,10 @@ (deftest format.a.44a (let ((fn (formatter "~3,,v@A"))) (loop for i from 0 to 6 - for s = (format nil "~3,,v@A" i "ABC") - for s2 = (formatter-call-to-string fn i "ABC") - do (assert (string= s s2)) - collect s)) + for s = (format nil "~3,,v@A" i "ABC") + for s2 = (formatter-call-to-string fn i "ABC") + do (assert (string= s s2)) + collect s)) ("ABC" " ABC" " ABC" diff --git a/ansi-tests/format-ampersand.lsp b/ansi-tests/format-ampersand.lsp index a6e3a8d4..3063da9a 100644 --- a/ansi-tests/format-ampersand.lsp +++ b/ansi-tests/format-ampersand.lsp @@ -20,44 +20,44 @@ (deftest format.&.5 (loop for i from 1 to 100 - for s1 = (make-string (1- i) :initial-element #\Newline) - for format-string = (format nil "~~~D&" i) - for s2 = (format nil format-string) - unless (string= s1 s2) - collect i) + for s1 = (make-string (1- i) :initial-element #\Newline) + for format-string = (format nil "~~~D&" i) + for s2 = (format nil format-string) + unless (string= s1 s2) + collect i) nil) (deftest formatter.&.5 (loop for i from 1 to 100 - for s1 = (make-string (1- i) :initial-element #\Newline) - for format-string = (format nil "~~~D&" i) - for fn = (eval `(formatter ,format-string)) - for s2 = (formatter-call-to-string fn) - unless (string= s1 s2) - collect i) + for s1 = (make-string (1- i) :initial-element #\Newline) + for format-string = (format nil "~~~D&" i) + for fn = (eval `(formatter ,format-string)) + for s2 = (formatter-call-to-string fn) + unless (string= s1 s2) + collect i) nil) (deftest format.&.6 (loop for i from 1 to 100 - for s1 = (concatenate 'string - "X" - (make-string i :initial-element #\Newline)) - for format-string = (format nil "X~~~D&" i) - for s2 = (format nil format-string) - unless (string= s1 s2) - collect i) + for s1 = (concatenate 'string + "X" + (make-string i :initial-element #\Newline)) + for format-string = (format nil "X~~~D&" i) + for s2 = (format nil format-string) + unless (string= s1 s2) + collect i) nil) (deftest formatter.&.6 (loop for i from 1 to 100 - for s1 = (concatenate 'string - "X" - (make-string i :initial-element #\Newline)) - for format-string = (format nil "X~~~D&" i) - for fn = (eval `(formatter ,format-string)) - for s2 = (formatter-call-to-string fn) - unless (string= s1 s2) - collect i) + for s1 = (concatenate 'string + "X" + (make-string i :initial-element #\Newline)) + for format-string = (format nil "X~~~D&" i) + for fn = (eval `(formatter ,format-string)) + for s2 = (formatter-call-to-string fn) + unless (string= s1 s2) + collect i) nil) (def-format-test format.&.7 @@ -68,40 +68,40 @@ (deftest format.&.9 (loop for i from 1 to 100 - for s1 = (make-string (1- i) :initial-element #\Newline) - for s2 = (format nil "~V&" i) - unless (string= s1 s2) - collect i) + for s1 = (make-string (1- i) :initial-element #\Newline) + for s2 = (format nil "~V&" i) + unless (string= s1 s2) + collect i) nil) (deftest formatter.&.9 (let ((fn (formatter "~V&"))) (loop for i from 1 to 100 - for s1 = (make-string (1- i) :initial-element #\Newline) - for s2 = (formatter-call-to-string fn i) - unless (string= s1 s2) - collect i)) + for s1 = (make-string (1- i) :initial-element #\Newline) + for s2 = (formatter-call-to-string fn i) + unless (string= s1 s2) + collect i)) nil) (deftest format.&.10 (loop for i from 1 to (min (- call-arguments-limit 3) 100) - for s1 = (make-string (1- i) :initial-element #\Newline) - for args = (make-list i) - for s2 = (apply #'format nil "~#&" args) - unless (string= s1 s2) - collect i) + for s1 = (make-string (1- i) :initial-element #\Newline) + for args = (make-list i) + for s2 = (apply #'format nil "~#&" args) + unless (string= s1 s2) + collect i) nil) (deftest formatter.&.10 (let ((fn (formatter "~#&"))) (loop for i from 1 to (min (- call-arguments-limit 3) 100) - for s1 = (make-string (1- i) :initial-element #\Newline) - for args = (loop for j below i collect j) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream args) args))) - unless (string= s1 s2) - collect i)) + for s1 = (make-string (1- i) :initial-element #\Newline) + for args = (loop for j below i collect j) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream args) args))) + unless (string= s1 s2) + collect i)) nil) (def-format-test format.&.11 @@ -112,5 +112,5 @@ (def-format-test format.&.13 "X~#%" ('a 'b 'c) #.(let ((nl (string #\Newline))) - (concatenate 'string "X" nl nl nl)) + (concatenate 'string "X" nl nl nl)) 3) diff --git a/ansi-tests/format-b.lsp b/ansi-tests/format-b.lsp index fb116da7..c4a64875 100644 --- a/ansi-tests/format-b.lsp +++ b/ansi-tests/format-b.lsp @@ -11,191 +11,191 @@ (let ((fn (formatter "~b"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~B" i) - for s2 = (formatter-call-to-string fn i) - for j = (let ((*read-base* 2)) (read-from-string s1)) - repeat 1000 - when (or (not (string= s1 s2)) - (/= i j) - (find #\+ s1) - (loop for c across s1 thereis (not (find c "-01")))) - collect (list i s1 j s2)))) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~B" i) + for s2 = (formatter-call-to-string fn i) + for j = (let ((*read-base* 2)) (read-from-string s1)) + repeat 1000 + when (or (not (string= s1 s2)) + (/= i j) + (find #\+ s1) + (loop for c across s1 thereis (not (find c "-01")))) + collect (list i s1 j s2)))) nil) (deftest format.b.2 (let ((fn (formatter "~@b"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@b" i) - for s2 = (formatter-call-to-string fn i) - for j = (let ((*read-base* 2)) (read-from-string s1)) - repeat 1000 - when (or (/= i j) - (not (string= s1 s2)) - (loop for c across s1 thereis (not (find c "-+01")))) - collect (list i s1 j s2)))) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@b" i) + for s2 = (formatter-call-to-string fn i) + for j = (let ((*read-base* 2)) (read-from-string s1)) + repeat 1000 + when (or (/= i j) + (not (string= s1 s2)) + (loop for c across s1 thereis (not (find c "-+01")))) + collect (list i s1 j s2)))) nil) (deftest format.b.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~b" i) - for fmt = (format nil "~~~db" mincol) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~b" i) + for fmt = (format nil "~~~db" mincol) + for s2 = (format nil fmt i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest formatter.b.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~b" i) - for fmt = (format nil "~~~db" mincol) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~b" i) + for fmt = (format nil "~~~db" mincol) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn i) + for pos = (search s1 s2) + repeat 100 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest format.b.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@B" i) - for fmt = (format nil "~~~d@b" mincol) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@B" i) + for fmt = (format nil "~~~d@b" mincol) + for s2 = (format nil fmt i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (and (>= i 0) (not (eql (elt s1 0) #\+))) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest formatter.b.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@B" i) - for fmt = (format nil "~~~d@b" mincol) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@B" i) + for fmt = (format nil "~~~d@b" mincol) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn i) + for pos = (search s1 s2) + repeat 100 + when (or (null pos) + (and (>= i 0) (not (eql (elt s1 0) #\+))) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest format.b.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~b" i) - for fmt = (format nil "~~~d,'~c~c" mincol padchar - (random-from-seq "bB")) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~b" i) + for fmt = (format nil "~~~d,'~c~c" mincol padchar + (random-from-seq "bB")) + for s2 = (format nil fmt i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 pos))) nil) (deftest formatter.b.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~b" i) - for fmt = (format nil "~~~d,'~c~c" mincol padchar - (random-from-seq "bB")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~b" i) + for fmt = (format nil "~~~d,'~c~c" mincol padchar + (random-from-seq "bB")) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn i) + for pos = (search s1 s2) + repeat 100 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 pos))) nil) (deftest format.b.6 (let ((fn (formatter "~v,vB"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~b" i) - for s2 = (format nil "~v,vb" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~b" i) + for s2 = (format nil "~v,vb" mincol padchar i) + for s3 = (formatter-call-to-string fn mincol padchar i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (not (string= s2 s3)) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 s3 pos)))) nil) (deftest format.b.7 (let ((fn (formatter "~v,v@B"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@B" i) - for s2 = (format nil "~v,v@b" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@B" i) + for s2 = (format nil "~v,v@b" mincol padchar i) + for s3 = (formatter-call-to-string fn mincol padchar i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (not (string= s2 s3)) + (and (>= i 0) (not (eql (elt s1 0) #\+))) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 s3 pos)))) nil) ;;; Comma tests @@ -203,153 +203,153 @@ (deftest format.b.8 (let ((fn (formatter "~:B"))) (loop for i from -7 to 7 - for s1 = (format nil "~b" i) - for s2 = (format nil "~:b" i) - for s3 = (formatter-call-to-string fn i) - unless (and (string= s1 s2) (string= s2 s3)) - collect (list i s1 s2 s3))) + for s1 = (format nil "~b" i) + for s2 = (format nil "~:b" i) + for s3 = (formatter-call-to-string fn i) + unless (and (string= s1 s2) (string= s2 s3)) + collect (list i s1 s2 s3))) nil) (deftest format.b.9 (let ((fn (formatter "~:b"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = #\, - for s1 = (format nil "~b" i) - for s2 = (format nil "~:B" i) - for s3 = (formatter-call-to-string fn i) - repeat 1000 - unless (and (string= s1 (remove commachar s2)) - (string= s2 s3) - (not (eql (elt s2 0) commachar)) - (or (>= i 0) (not (eql (elt s2 1) commachar))) - (let ((len (length s2)) - (ci+1 4)) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (find (elt s2 i) "01"))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = #\, + for s1 = (format nil "~b" i) + for s2 = (format nil "~:B" i) + for s3 = (formatter-call-to-string fn i) + repeat 1000 + unless (and (string= s1 (remove commachar s2)) + (string= s2 s3) + (not (eql (elt s2 0) commachar)) + (or (>= i 0) (not (eql (elt s2 1) commachar))) + (let ((len (length s2)) + (ci+1 4)) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (find (elt s2 i) "01"))))) + collect (list x i commachar s1 s2 s3)))) nil) (deftest format.b.10 (let ((fn (formatter "~,,v:B"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~b" i) - for s2 = (format nil "~,,v:b" commachar i) - for s3 = (formatter-call-to-string fn commachar i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (string= s2 s3) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for s1 = (format nil "~b" i) + for s2 = (format nil "~,,v:b" commachar i) + for s3 = (formatter-call-to-string fn commachar i) + repeat 1000 + unless (and + (eql (elt s1 0) (elt s2 0)) + (string= s2 s3) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 4) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2 s3)))) nil) (deftest format.b.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~b" i) - for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "bB")) - for s2 = (format nil fmt i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for s1 = (format nil "~b" i) + for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "bB")) + for s2 = (format nil fmt i) + repeat 1000 + unless (and + (eql (elt s1 0) (elt s2 0)) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 4) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2))) nil) (deftest formatter.b.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~b" i) - for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "bB")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - repeat 100 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for s1 = (format nil "~b" i) + for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "bB")) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn i) + repeat 100 + unless (and + (eql (elt s1 0) (elt s2 0)) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 4) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2))) nil) (deftest format.b.12 (let ((fn (formatter "~,,V,V:b"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~b" i) - for s2 = (format nil "~,,v,v:B" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (string= s2 s3) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for commaint = (1+ (random 20)) + for s1 = (format nil "~b" i) + for s2 = (format nil "~,,v,v:B" commachar commaint i) + for s3 = (formatter-call-to-string fn commachar commaint i) + repeat 1000 + unless (and + (eql (elt s1 0) (elt s2 0)) + (string= s2 s3) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 (1+ commaint)) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2 s3)))) nil) (deftest format.b.13 (let ((fn (formatter "~,,V,V@:B"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~@B" i) - for s2 = (format nil "~,,v,v:@b" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (string= s2 s3) - (eql (elt s1 0) (elt s2 0)) - (eql (elt s1 1) (elt s2 1)) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j 1)) - (loop for i from 2 below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for commaint = (1+ (random 20)) + for s1 = (format nil "~@B" i) + for s2 = (format nil "~,,v,v:@b" commachar commaint i) + for s3 = (formatter-call-to-string fn commachar commaint i) + repeat 1000 + unless (and + (string= s2 s3) + (eql (elt s1 0) (elt s2 0)) + (eql (elt s1 1) (elt s2 1)) + (let ((len (length s2)) + (ci+1 (1+ commaint)) + (j 1)) + (loop for i from 2 below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2 s3)))) nil) ;;; NIL arguments @@ -371,43 +371,43 @@ (deftest format.b.18 (let ((fn (formatter "~b"))) (loop for x in *mini-universe* - for s1 = (format nil "~b" x) - for s2 = (let ((*print-base* 2)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) - collect (list x s1 s2 s3))) + for s1 = (format nil "~b" x) + for s2 = (let ((*print-base* 2)) (format nil "~A" x)) + for s3 = (formatter-call-to-string fn x) + unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) + collect (list x s1 s2 s3))) nil) (deftest format.b.19 (let ((fn (formatter "~:b"))) (loop for x in *mini-universe* - for s1 = (format nil "~:B" x) - for s2 = (let ((*print-base* 2)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) - collect (list x s1 s2 s3))) + for s1 = (format nil "~:B" x) + for s2 = (let ((*print-base* 2)) (format nil "~A" x)) + for s3 = (formatter-call-to-string fn x) + unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) + collect (list x s1 s2 s3))) nil) (deftest format.b.20 (let ((fn (formatter "~@b"))) (loop for x in *mini-universe* - for s1 = (format nil "~@b" x) - for s2 = (let ((*print-base* 2)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) - collect (list x s1 s2 s3))) + for s1 = (format nil "~@b" x) + for s2 = (let ((*print-base* 2)) (format nil "~A" x)) + for s3 = (formatter-call-to-string fn x) + unless (or (integerp x) (and (string= s1 s2) (string= s1 s3))) + collect (list x s1 s2 s3))) nil) (deftest format.b.21 (let ((fn (formatter "~:@b"))) (loop for x in *mini-universe* - for s1 = (let ((*print-base* 2)) (format nil "~A" x)) - for s2 = (format nil "~@:B" x) - for s3 = (formatter-call-to-string fn x) - for s4 = (let ((*print-base* 2)) (format nil "~A" x)) - unless (or (integerp x) (and (string= s1 s2) (string= s1 s3)) - (string/= s1 s4)) - collect (list x s1 s2 s3))) + for s1 = (let ((*print-base* 2)) (format nil "~A" x)) + for s2 = (format nil "~@:B" x) + for s3 = (formatter-call-to-string fn x) + for s4 = (let ((*print-base* 2)) (format nil "~A" x)) + unless (or (integerp x) (and (string= s1 s2) (string= s1 s3)) + (string/= s1 s4)) + collect (list x s1 s2 s3))) nil) ;;; Must add tests for non-integers when the parameters @@ -421,15 +421,15 @@ (apply #'values (let ((fn (formatter "~#B")) - (bv #b11001)) + (bv #b11001)) (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~#b" bv args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream bv args) args))) - do (assert (string= s s2)) - collect s))) + for args = (make-list i) + for s = (apply #'format nil "~#b" bv args) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream bv args) args))) + do (assert (string= s s2)) + collect s))) "11001" "11001" "11001" @@ -446,15 +446,15 @@ (apply #'values (let ((fn (formatter "~,,,#:b")) - (bv #b1100100010)) + (bv #b1100100010)) (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#:B" bv args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream bv args) args))) - do (assert (string= s s2)) - collect s))) + for args = (make-list i) + for s = (apply #'format nil "~,,,#:B" bv args) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream bv args) args))) + do (assert (string= s s2)) + collect s))) "1,1,0,0,1,0,0,0,1,0" "11,00,10,00,10" "1,100,100,010" @@ -471,15 +471,15 @@ (apply #'values (let ((fn (formatter "~,,,#@:B")) - (bv #b1100100010)) + (bv #b1100100010)) (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#@:B" bv args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream bv args) args))) - do (assert (string= s s2)) - collect s))) + for args = (make-list i) + for s = (apply #'format nil "~,,,#@:B" bv args) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream bv args) args))) + do (assert (string= s s2)) + collect s))) "+1,1,0,0,1,0,0,0,1,0" "+11,00,10,00,10" "+1,100,100,010" @@ -514,22 +514,22 @@ (loop for mincol = (and (coin) (random 50)) for padchar = (and (coin) - (random-from-seq +standard-chars+)) + (random-from-seq +standard-chars+)) for commachar = (and (coin) - (random-from-seq +standard-chars+)) + (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate - 'string - (if mincol (format nil "~~~d," mincol) "~,") - (if padchar (format nil "'~c," padchar) ",") - (if commachar (format nil "'~c," commachar) ",") - (if commaint (format nil "~db" commaint) "b")) + 'string + (if mincol (format nil "~~~d," mincol) "~,") + (if padchar (format nil "'~c," padchar) ",") + (if commachar (format nil "'~c," commachar) ",") + (if commaint (format nil "~db" commaint) "b")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,vb" mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) (string= s2 s3)) collect (list mincol padchar commachar commaint fmt x s1 s2))) - nil) \ No newline at end of file + nil) diff --git a/ansi-tests/format-brace.lsp b/ansi-tests/format-brace.lsp index d2051655..e3304313 100644 --- a/ansi-tests/format-brace.lsp +++ b/ansi-tests/format-brace.lsp @@ -37,17 +37,17 @@ (deftest format.{.8 (loop for i from 0 to 10 - for s = (format nil "~v{~A~}" i '(1 2 3 4 5 6 7 8 9 0)) - unless (string= s (subseq "1234567890" 0 i)) - collect (list i s)) + for s = (format nil "~v{~A~}" i '(1 2 3 4 5 6 7 8 9 0)) + unless (string= s (subseq "1234567890" 0 i)) + collect (list i s)) nil) (deftest formatter.{.8 (let ((fn (formatter "~V{~A~}"))) (loop for i from 0 to 10 - for s = (formatter-call-to-string fn i '(1 2 3 4 5 6 7 8 9 0)) - unless (string= s (subseq "1234567890" 0 i)) - collect (list i s))) + for s = (formatter-call-to-string fn i '(1 2 3 4 5 6 7 8 9 0)) + unless (string= s (subseq "1234567890" 0 i)) + collect (list i s))) nil) (def-format-test format.{.9 @@ -142,26 +142,26 @@ (def-format-test format.\:{.7 "~0:{XYZ~}" ('((1))) "") - + (def-format-test format.\:{.8 "~2:{XYZ~}" ('((1))) "XYZ") - + (def-format-test format.\:{.9 "~2:{~A~}" ('((1) (2))) "12") - + (def-format-test format.\:{.10 "~2:{~A~}" ('((1 X) (2 Y) (3 Z))) "12") (deftest format.\:{.11 (loop for i from 0 to 10 collect - (format nil "~v:{~A~}" i '((1) (2) (3 X) (4 Y Z) (5) (6)))) + (format nil "~v:{~A~}" i '((1) (2) (3 X) (4 Y Z) (5) (6)))) ("" "1" "12" "123" "1234" "12345" "123456" "123456" "123456" "123456" "123456")) (deftest formatter.\:{.11 (let ((fn (formatter "~v:{~A~}"))) (loop for i from 0 to 10 collect - (formatter-call-to-string fn i '((1) (2) (3 X) (4 Y Z) (5) (6))))) + (formatter-call-to-string fn i '((1) (2) (3 X) (4 Y Z) (5) (6))))) ("" "1" "12" "123" "1234" "12345" "123456" "123456" "123456" "123456" "123456")) @@ -176,14 +176,14 @@ (deftest format.\:{.15 (loop for i from 0 to 10 collect - (format nil "~v:{~A~:}" i '((1 X) (2 Y) (3) (4 A B)))) + (format nil "~v:{~A~:}" i '((1 X) (2 Y) (3) (4 A B)))) ("" "1" "12" "123" "1234" "1234" "1234" "1234" "1234" "1234" "1234")) (deftest formatter.\:{.15 (let ((fn (formatter "~v:{~A~:}"))) (loop for i from 0 to 10 collect - (formatter-call-to-string fn i '((1 X) (2 Y) (3) (4 A B))))) + (formatter-call-to-string fn i '((1 X) (2 Y) (3) (4 A B))))) ("" "1" "12" "123" "1234" "1234" "1234" "1234" "1234" "1234" "1234")) @@ -229,20 +229,20 @@ (deftest format.@{.10 (loop for i from 0 to 10 - for x = nil then (cons i x) - collect (apply #'format nil "~v@{~A~}" i (reverse x))) + for x = nil then (cons i x) + collect (apply #'format nil "~v@{~A~}" i (reverse x))) ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" "123456789" "12345678910")) (deftest formatter.@{.10 (let ((fn (formatter "~v@{~A~}"))) (loop for i from 0 to 10 - for x = nil then (cons i x) - for rest = (list 'a 'b 'c) - collect - (with-output-to-string - (s) - (assert (equal (apply fn s i (append (reverse x) rest)) rest))))) + for x = nil then (cons i x) + for rest = (list 'a 'b 'c) + collect + (with-output-to-string + (s) + (assert (equal (apply fn s i (append (reverse x) rest)) rest))))) ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" "123456789" "12345678910")) @@ -287,21 +287,21 @@ (deftest format.\:@.10 (loop for i from 0 to 10 - for x = nil then (cons (list i) x) - collect - (apply #'format nil "~V:@{~A~}" i (reverse x))) + for x = nil then (cons (list i) x) + collect + (apply #'format nil "~V:@{~A~}" i (reverse x))) ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" "123456789" "12345678910")) (deftest formatter.\:@.10 (let ((fn (formatter "~V@:{~A~}"))) (loop for i from 0 to 10 - for x = nil then (cons (list i) x) - for rest = (list 'a 'b) - collect - (with-output-to-string - (s) - (assert (equal (apply fn s i (append (reverse x) rest)) rest))))) + for x = nil then (cons (list i) x) + for rest = (list 'a 'b) + collect + (with-output-to-string + (s) + (assert (equal (apply fn s i (append (reverse x) rest)) rest))))) ("" "1" "12" "123" "1234" "12345" "123456" "1234567" "12345678" "123456789" "12345678910")) @@ -334,7 +334,7 @@ (deftest format.\:{.error.2 (signals-type-error x 'x (format nil "~:{~A~}" x)) t) - + (deftest format.\:{.error.3 (signals-error (format nil "~:{~A~}" '((x) . y)) type-error) t) diff --git a/ansi-tests/format-c.lsp b/ansi-tests/format-c.lsp index 2cfb68e0..1a8822dc 100644 --- a/ansi-tests/format-c.lsp +++ b/ansi-tests/format-c.lsp @@ -11,44 +11,44 @@ (deftest format.c.1 (loop for c across +standard-chars+ - for s = (format nil "~C" c) - unless (string= s (string c)) - collect (list c s)) + for s = (format nil "~C" c) + unless (string= s (string c)) + collect (list c s)) nil) (deftest format.c.1a (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s = (and c (format nil "~c" c)) - unless (or (not c) - (not (eql (char-code c) (char-int c))) - (string= s (string c))) - do (incf count) and collect (list i c s) - when (> count 100) collect "count limit exceeded" and do (loop-finish)) + for i from 0 below (min #x10000 char-code-limit) + for c = (code-char i) + for s = (and c (format nil "~c" c)) + unless (or (not c) + (not (eql (char-code c) (char-int c))) + (string= s (string c))) + do (incf count) and collect (list i c s) + when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) (deftest format.c.2 (loop for c across +standard-chars+ - for s = (format nil "~:c" c) - unless (or (not (graphic-char-p c)) - (eql c #\Space) - (string= s (string c))) - collect (list c s)) + for s = (format nil "~:c" c) + unless (or (not (graphic-char-p c)) + (eql c #\Space) + (string= s (string c))) + collect (list c s)) nil) (deftest format.c.2a (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s = (and c (format nil "~:C" c)) - unless (or (not c) - (not (eql (char-code c) (char-int c))) - (not (graphic-char-p c)) - (eql c #\Space) - (string= s (string c))) - do (incf count) and collect (list i c s) - when (> count 100) collect "count limit exceeded" and do (loop-finish)) + for i from 0 below (min #x10000 char-code-limit) + for c = (code-char i) + for s = (and c (format nil "~:C" c)) + unless (or (not c) + (not (eql (char-code c) (char-int c))) + (not (graphic-char-p c)) + (eql c #\Space) + (string= s (string c))) + do (incf count) and collect (list i c s) + when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) (def-format-test format.c.3 @@ -56,61 +56,61 @@ (deftest format.c.4 (loop for c across +standard-chars+ - for s = (format nil "~:C" c) - unless (or (graphic-char-p c) - (string= s (char-name c))) - collect (list c (char-name c) s)) + for s = (format nil "~:C" c) + unless (or (graphic-char-p c) + (string= s (char-name c))) + collect (list c (char-name c) s)) nil) (deftest format.c.4a (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s = (and c (format nil "~:c" c)) - unless (or (not c) - (not (eql (char-code c) (char-int c))) - (graphic-char-p c) - (string= s (char-name c))) - do (incf count) and collect (print (list i c s)) - when (> count 100) collect "count limit exceeded" and do (loop-finish)) + for i from 0 below (min #x10000 char-code-limit) + for c = (code-char i) + for s = (and c (format nil "~:c" c)) + unless (or (not c) + (not (eql (char-code c) (char-int c))) + (graphic-char-p c) + (string= s (char-name c))) + do (incf count) and collect (print (list i c s)) + when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) (deftest format.c.5 (loop for c across +standard-chars+ - for s = (format nil "~@c" c) - for c2 = (read-from-string s) - unless (eql c c2) - collect (list c s c2)) + for s = (format nil "~@c" c) + for c2 = (read-from-string s) + unless (eql c c2) + collect (list c s c2)) nil) (deftest format.c.5a (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s = (and c (format nil "~@C" c)) - for c2 = (and c (read-from-string s)) - unless (eql c c2) - do (incf count) and collect (list c s c2) - when (> count 100) collect "count limit exceeded" and do (loop-finish)) + for i from 0 below (min #x10000 char-code-limit) + for c = (code-char i) + for s = (and c (format nil "~@C" c)) + for c2 = (and c (read-from-string s)) + unless (eql c c2) + do (incf count) and collect (list c s c2) + when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) (deftest format.c.6 (loop for c across +standard-chars+ - for s1 = (format nil "~:C" c) - for s2 = (format nil "~:@C" c) - unless (eql (search s1 s2) 0) - collect (list c s1 s2)) + for s1 = (format nil "~:C" c) + for s2 = (format nil "~:@C" c) + unless (eql (search s1 s2) 0) + collect (list c s1 s2)) nil) (deftest format.c.6a (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s1 = (and c (format nil "~:C" c)) - for s2 = (and c (format nil "~@:C" c)) - unless (or (not c) (eql (search s1 s2) 0)) - do (incf count) and collect (list c s1 s2) - when (> count 100) collect "count limit exceeded" and do (loop-finish)) + for i from 0 below (min #x10000 char-code-limit) + for c = (code-char i) + for s1 = (and c (format nil "~:C" c)) + for s2 = (and c (format nil "~@:C" c)) + unless (or (not c) (eql (search s1 s2) 0)) + do (incf count) and collect (list c s1 s2) + when (> count 100) collect "count limit exceeded" and do (loop-finish)) nil) diff --git a/ansi-tests/format-circumflex.lsp b/ansi-tests/format-circumflex.lsp index a0216c20..52e6fbba 100644 --- a/ansi-tests/format-circumflex.lsp +++ b/ansi-tests/format-circumflex.lsp @@ -61,20 +61,20 @@ (def-format-test format.^.{.18 "~{~v,v^~A~}" ((list (1+ most-positive-fixnum) - (1+ most-positive-fixnum) - 1)) + (1+ most-positive-fixnum) + 1)) "") (def-format-test format.^.{.19 "~{~0,v,v^~A~}" ((list (1+ most-positive-fixnum) - (1+ most-positive-fixnum) - 1)) + (1+ most-positive-fixnum) + 1)) "") (def-format-test format.^.{.20 "~{~0,v,v^~A~}" ((list (1+ most-positive-fixnum) - most-positive-fixnum - 1)) + most-positive-fixnum + 1)) "1") (def-format-test format.^.{.21 diff --git a/ansi-tests/format-conditional.lsp b/ansi-tests/format-conditional.lsp index 30e3a8fd..66b728e5 100644 --- a/ansi-tests/format-conditional.lsp +++ b/ansi-tests/format-conditional.lsp @@ -27,13 +27,13 @@ (deftest format.cond.7 (loop for i from -1 to 10 - collect (format nil "~[a~;b~;c~;d~;e~;f~;g~;h~;i~]" i)) + collect (format nil "~[a~;b~;c~;d~;e~;f~;g~;h~;i~]" i)) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (deftest formatter.cond.7 (let ((fn (formatter "~[a~;b~;c~;d~;e~;f~;g~;h~;i~]"))) (loop for i from -1 to 10 - collect (formatter-call-to-string fn i))) + collect (formatter-call-to-string fn i))) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (def-format-test format.cond.8 @@ -53,24 +53,24 @@ (deftest format.cond.13 (loop for i from -1 to 10 - collect (format nil "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]" i nil)) + collect (format nil "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]" i nil)) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (deftest formatter.cond.13 (let ((fn (formatter "~V[a~;b~;c~;d~;e~;f~;g~;h~;i~]"))) (loop for i from -1 to 10 - collect (formatter-call-to-string fn i))) + collect (formatter-call-to-string fn i))) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (deftest format.cond.14 (loop for i from -1 to 10 - collect (format nil "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]" nil i)) + collect (format nil "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]" nil i)) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (deftest formatter.cond.14 (let ((fn (formatter "~v[a~;b~;c~;d~;e~;f~;g~;h~;i~]"))) (loop for i from -1 to 10 - collect (formatter-call-to-string fn nil i))) + collect (formatter-call-to-string fn nil i))) ("" "a" "b" "c" "d" "e" "f" "g" "h" "i" "" "")) (def-format-test format.cond.15 @@ -83,17 +83,17 @@ (deftest format.cond\:.1 (loop for i from -100 to 100 - for s = (format nil "~[~:;a~]" i) - unless (or (zerop i) (string= s "a")) - collect (list i s)) + for s = (format nil "~[~:;a~]" i) + unless (or (zerop i) (string= s "a")) + collect (list i s)) nil) (deftest formatter.cond\:.1 (let ((fn (formatter "~[~:;a~]"))) (loop for i from -100 to 100 - for s = (formatter-call-to-string fn i) - unless (or (zerop i) (string= s "a")) - collect (list i s))) + for s = (formatter-call-to-string fn i) + unless (or (zerop i) (string= s "a")) + collect (list i s))) nil) (def-format-test format.cond\:.2 @@ -107,35 +107,35 @@ (deftest format.cond\:.5 (loop for i from -1 to 10 - collect (format nil "~[a~;b~;c~;d~:;e~]" i)) + collect (format nil "~[a~;b~;c~;d~:;e~]" i)) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest formatter.cond\:.5 (let ((fn (formatter "~[a~;b~;c~;d~:;e~]"))) (loop for i from -1 to 10 - collect (formatter-call-to-string fn i))) + collect (formatter-call-to-string fn i))) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest format.cond\:.6 (loop for i from -1 to 10 - collect (format nil "~v[a~;b~;c~;d~:;e~]" i nil)) + collect (format nil "~v[a~;b~;c~;d~:;e~]" i nil)) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest formatter.cond\:.6 (let ((fn (formatter "~v[a~;b~;c~;d~:;e~]"))) (loop for i from -1 to 10 - collect (formatter-call-to-string fn i))) + collect (formatter-call-to-string fn i))) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest format.cond\:.7 (loop for i from -1 to 10 - collect (format nil "~v[a~;b~;c~;d~:;e~]" nil i)) + collect (format nil "~v[a~;b~;c~;d~:;e~]" nil i)) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (deftest formatter.cond\:.7 (let ((fn (formatter "~v[a~;b~;c~;d~:;e~]"))) (loop for i from -1 to 10 - collect (formatter-call-to-string fn nil i))) + collect (formatter-call-to-string fn nil i))) ("e" "a" "b" "c" "d" "e" "e" "e" "e" "e" "e" "e")) (def-format-test format.cond\:.8 @@ -151,17 +151,17 @@ (deftest format.\:cond.2 (loop for x in *mini-universe* - for s = (format nil "~:[a~;b~]" x) - when (and x (not (string= s "b"))) - collect (list x s)) + for s = (format nil "~:[a~;b~]" x) + when (and x (not (string= s "b"))) + collect (list x s)) nil) (deftest formatter.\:cond.2 (let ((fn (formatter "~:[a~;b~]"))) (loop for x in *mini-universe* - for s = (formatter-call-to-string fn x) - when (and x (not (string= s "b"))) - collect (list x s))) + for s = (formatter-call-to-string fn x) + when (and x (not (string= s "b"))) + collect (list x s))) nil) ;;; ~@[ ... ~] diff --git a/ansi-tests/format-d.lsp b/ansi-tests/format-d.lsp index 8cee9db0..cb86b700 100644 --- a/ansi-tests/format-d.lsp +++ b/ansi-tests/format-d.lsp @@ -10,390 +10,390 @@ (deftest format.d.1 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~D" i) - for j = (read-from-string s1) - repeat 1000 - when (or (/= i j) - (find #\. s1) - (find #\+ s1) - (find-if #'alpha-char-p s1)) - collect (list i s1 j))) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~D" i) + for j = (read-from-string s1) + repeat 1000 + when (or (/= i j) + (find #\. s1) + (find #\+ s1) + (find-if #'alpha-char-p s1)) + collect (list i s1 j))) nil) (deftest formatter.d.1 (let ((fn (formatter "~D"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (formatter-call-to-string fn i) - for j = (read-from-string s1) - repeat 1000 - when (or (/= i j) - (find #\. s1) - (find #\+ s1) - (find-if #'alpha-char-p s1)) - collect (list i s1 j)))) + for i = (- (random (+ x x)) x) + for s1 = (formatter-call-to-string fn i) + for j = (read-from-string s1) + repeat 1000 + when (or (/= i j) + (find #\. s1) + (find #\+ s1) + (find-if #'alpha-char-p s1)) + collect (list i s1 j)))) nil) (deftest format.d.2 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@d" i) - for j = (read-from-string s1) - repeat 1000 - when (or (/= i j) - (find #\. s1) - ;; (find #\+ s1) - (find-if #'alpha-char-p s1)) - collect (list i s1 j))) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@d" i) + for j = (read-from-string s1) + repeat 1000 + when (or (/= i j) + (find #\. s1) + ;; (find #\+ s1) + (find-if #'alpha-char-p s1)) + collect (list i s1 j))) nil) (deftest formatter.d.2 (let ((fn (formatter "~@D"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (formatter-call-to-string fn i) - for j = (read-from-string s1) - repeat 1000 - when (or (/= i j) - (find #\. s1) - ;; (find #\+ s1) - (find-if #'alpha-char-p s1)) - collect (list i s1 j)))) + for i = (- (random (+ x x)) x) + for s1 = (formatter-call-to-string fn i) + for j = (read-from-string s1) + repeat 1000 + when (or (/= i j) + (find #\. s1) + ;; (find #\+ s1) + (find-if #'alpha-char-p s1)) + collect (list i s1 j)))) nil) (deftest format.d.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~d" i) - for s2 = (format nil (format nil "~~~dd" mincol) i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~d" i) + for s2 = (format nil (format nil "~~~dd" mincol) i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest formatter.d.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~d" i) - for format-string = (format nil "~~~dd" mincol) - ; for s2 = (format nil format-string i) - for fn = (eval `(formatter ,format-string)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~d" i) + for format-string = (format nil "~~~dd" mincol) + ; for s2 = (format nil format-string i) + for fn = (eval `(formatter ,format-string)) + for s2 = (formatter-call-to-string fn i) + for pos = (search s1 s2) + repeat 100 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest format.d.4 (with-standard-io-syntax (loop with limit = 10 - with count = 0 - for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@D" i) - for format-string = (format nil "~~~d@d" mincol) - for s2 = (format nil format-string i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (if (> (incf count) limit) - "Count limit exceeded" - (list i mincol s1 format-string s2 pos)) - while (<= count limit))) + with count = 0 + for x = (ash 1 (+ 2 (random 80))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@D" i) + for format-string = (format nil "~~~d@d" mincol) + for s2 = (format nil format-string i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (and (>= i 0) (not (eql (elt s1 0) #\+))) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (if (> (incf count) limit) + "Count limit exceeded" + (list i mincol s1 format-string s2 pos)) + while (<= count limit))) nil) (deftest formatter.d.4 (with-standard-io-syntax (loop with limit = 10 - with count = 0 - for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@D" i) - for format-string = (format nil "~~~d@d" mincol) - for fn = (eval `(formatter ,format-string)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (if (> (incf count) limit) - "Count limit exceeded" - (list i mincol s1 s2 pos)) - while (<= count limit))) + with count = 0 + for x = (ash 1 (+ 2 (random 80))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@D" i) + for format-string = (format nil "~~~d@d" mincol) + for fn = (eval `(formatter ,format-string)) + for s2 = (formatter-call-to-string fn i) + for pos = (search s1 s2) + repeat 100 + when (or (null pos) + (and (>= i 0) (not (eql (elt s1 0) #\+))) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (if (> (incf count) limit) + "Count limit exceeded" + (list i mincol s1 s2 pos)) + while (<= count limit))) nil) (deftest format.d.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~d" i) - for s2 = (format nil (format nil "~~~d,'~cd" mincol padchar) i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~d" i) + for s2 = (format nil (format nil "~~~d,'~cd" mincol padchar) i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 pos))) nil) (deftest formatter.d.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~d" i) - for format-string = (format nil "~~~d,'~cd" mincol padchar) - for fn = (eval `(formatter ,format-string)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~d" i) + for format-string = (format nil "~~~d,'~cd" mincol padchar) + for fn = (eval `(formatter ,format-string)) + for s2 = (formatter-call-to-string fn i) + for pos = (search s1 s2) + repeat 100 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 pos))) nil) (deftest format.d.6 (let ((fn (formatter "~v,vd"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~d" i) - for s2 = (format nil "~v,vD" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~d" i) + for s2 = (format nil "~v,vD" mincol padchar i) + for s3 = (formatter-call-to-string fn mincol padchar i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (not (string= s2 s3)) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 s3 pos)))) nil) (deftest format.d.7 (let ((fn (formatter "~v,v@D"))) (with-standard-io-syntax (loop with limit = 10 - with count = 0 - for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@d" i) - for s2 = (format nil "~v,v@d" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (if (> (incf count) limit) - "Count limit exceeded" - (list i mincol s1 s2 s3 pos)) - while (<= count limit)))) + with count = 0 + for x = (ash 1 (+ 2 (random 80))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@d" i) + for s2 = (format nil "~v,v@d" mincol padchar i) + for s3 = (formatter-call-to-string fn mincol padchar i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (not (string= s2 s3)) + (and (>= i 0) (not (eql (elt s1 0) #\+))) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (if (> (incf count) limit) + "Count limit exceeded" + (list i mincol s1 s2 s3 pos)) + while (<= count limit)))) nil) ;;; Comma tests (deftest format.d.8 (let ((fn1 (formatter "~d")) - (fn2 (formatter "~:d"))) + (fn2 (formatter "~:d"))) (loop for i from -999 to 999 - for s1 = (format nil "~d" i) - for s2 = (format nil "~:d" i) - for s3 = (formatter-call-to-string fn1 i) - for s4 = (formatter-call-to-string fn2 i) - unless (and (string= s1 s2) (string= s1 s3) (string= s1 s4)) - collect (list i s1 s2 s3 s4))) + for s1 = (format nil "~d" i) + for s2 = (format nil "~:d" i) + for s3 = (formatter-call-to-string fn1 i) + for s4 = (formatter-call-to-string fn2 i) + unless (and (string= s1 s2) (string= s1 s3) (string= s1 s4)) + collect (list i s1 s2 s3 s4))) nil) (deftest format.d.9 (let ((fn1 (formatter "~d")) - (fn2 (formatter "~:d"))) + (fn2 (formatter "~:d"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = #\, - for s1 = (format nil "~d" i) - for s2 = (format nil "~:d" i) - for s3 = (formatter-call-to-string fn1 i) - for s4 = (formatter-call-to-string fn2 i) - repeat 1000 - unless (and (string= s1 s3) - (string= s2 s4) - (string= s1 (remove commachar s2)) - (not (eql (elt s2 0) commachar)) - (or (>= i 0) (not (eql (elt s2 1) commachar))) - (let ((len (length s2)) - (ci+1 4)) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (find (elt s2 i) "0123456789"))))) - collect (list x i commachar s1 s2 s3 s4)))) + for i = (- (random (+ x x)) x) + for commachar = #\, + for s1 = (format nil "~d" i) + for s2 = (format nil "~:d" i) + for s3 = (formatter-call-to-string fn1 i) + for s4 = (formatter-call-to-string fn2 i) + repeat 1000 + unless (and (string= s1 s3) + (string= s2 s4) + (string= s1 (remove commachar s2)) + (not (eql (elt s2 0) commachar)) + (or (>= i 0) (not (eql (elt s2 1) commachar))) + (let ((len (length s2)) + (ci+1 4)) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (find (elt s2 i) "0123456789"))))) + collect (list x i commachar s1 s2 s3 s4)))) nil) (deftest format.d.10 (let ((fn (formatter "~,,v:d"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~d" i) - for s2 = (format nil "~,,v:d" commachar i) - for s3 = (formatter-call-to-string fn commachar i) - repeat 1000 - unless (and - (string= s2 s3) - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for s1 = (format nil "~d" i) + for s2 = (format nil "~,,v:d" commachar i) + for s3 = (formatter-call-to-string fn commachar i) + repeat 1000 + unless (and + (string= s2 s3) + (eql (elt s1 0) (elt s2 0)) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 4) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2 s3)))) nil) (deftest format.d.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~d" i) - for format-string = (format nil "~~,,'~c:d" commachar) - for s2 = (format nil format-string i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for s1 = (format nil "~d" i) + for format-string = (format nil "~~,,'~c:d" commachar) + for s2 = (format nil format-string i) + repeat 1000 + unless (and + (eql (elt s1 0) (elt s2 0)) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 4) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2))) nil) (deftest formatter.d.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~d" i) - for format-string = (format nil "~~,,'~c:d" commachar) - for fn = (eval `(formatter ,format-string)) - ; for s2 = (format nil format-string i) - for s2 = (formatter-call-to-string fn i) - repeat 100 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for s1 = (format nil "~d" i) + for format-string = (format nil "~~,,'~c:d" commachar) + for fn = (eval `(formatter ,format-string)) + ; for s2 = (format nil format-string i) + for s2 = (formatter-call-to-string fn i) + repeat 100 + unless (and + (eql (elt s1 0) (elt s2 0)) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 4) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2))) nil) (deftest format.d.12 (let ((fn (formatter "~,,v,v:d"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~d" i) - for s2 = (format nil "~,,v,v:D" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (string= s2 s3) - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for commaint = (1+ (random 20)) + for s1 = (format nil "~d" i) + for s2 = (format nil "~,,v,v:D" commachar commaint i) + for s3 = (formatter-call-to-string fn commachar commaint i) + repeat 1000 + unless (and + (string= s2 s3) + (eql (elt s1 0) (elt s2 0)) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 (1+ commaint)) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2 s3)))) nil) (deftest format.d.13 (let ((fn (formatter "~,,v,v:@D"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~@d" i) - for s2 = (format nil "~,,v,v:@d" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (eql (elt s1 1) (elt s2 1)) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j 1)) - (loop for i from 2 below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for commaint = (1+ (random 20)) + for s1 = (format nil "~@d" i) + for s2 = (format nil "~,,v,v:@d" commachar commaint i) + for s3 = (formatter-call-to-string fn commachar commaint i) + repeat 1000 + unless (and + (eql (elt s1 0) (elt s2 0)) + (eql (elt s1 1) (elt s2 1)) + (let ((len (length s2)) + (ci+1 (1+ commaint)) + (j 1)) + (loop for i from 2 below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2 s3)))) nil) ;;; NIL arguments @@ -414,35 +414,35 @@ (deftest format.d.18 (loop for x in *mini-universe* - for s1 = (format nil "~d" x) - for s2 = (format nil "~A" x) - unless (or (integerp x) (string= s1 s2)) - collect (list x s1 s2)) + for s1 = (format nil "~d" x) + for s2 = (format nil "~A" x) + unless (or (integerp x) (string= s1 s2)) + collect (list x s1 s2)) nil) (deftest format.d.19 (loop for x in *mini-universe* - for s1 = (format nil "~:d" x) - for s2 = (format nil "~A" x) - unless (or (integerp x) (string= s1 s2)) - collect (list x s1 s2)) + for s1 = (format nil "~:d" x) + for s2 = (format nil "~A" x) + unless (or (integerp x) (string= s1 s2)) + collect (list x s1 s2)) nil) (deftest format.d.20 (loop for x in *mini-universe* - for s1 = (format nil "~@d" x) - for s2 = (format nil "~A" x) - unless (or (integerp x) (string= s1 s2)) - collect (list x s1 s2)) + for s1 = (format nil "~@d" x) + for s2 = (format nil "~A" x) + unless (or (integerp x) (string= s1 s2)) + collect (list x s1 s2)) nil) (deftest format.d.21 (loop for x in *mini-universe* - for s1 = (format nil "~A" x) - for s2 = (format nil "~@:d" x) + for s1 = (format nil "~A" x) + for s2 = (format nil "~@:d" x) for s3 = (format nil "~A" x) - unless (or (integerp x) (string= s1 s2) (not (string= s1 s3))) - collect (list x s1 s2)) + unless (or (integerp x) (string= s1 s2) (not (string= s1 s3))) + collect (list x s1 s2)) nil) ;;; Must add tests for non-integers when the parameters @@ -456,9 +456,9 @@ (apply #'values (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~#d" 12345 args) - collect s)) + for args = (make-list i) + for s = (apply #'format nil "~#d" 12345 args) + collect s)) "12345" "12345" "12345" @@ -476,12 +476,12 @@ #'values (let ((fn (formatter "~#D"))) (loop for i from 0 to 10 - for args = (make-list i) - ; for s = (apply #'format nil "~#d" 12345 args) - for s = (with-output-to-string - (stream) - (assert (equal (apply fn stream 12345 args) args))) - collect s))) + for args = (make-list i) + ; for s = (apply #'format nil "~#d" 12345 args) + for s = (with-output-to-string + (stream) + (assert (equal (apply fn stream 12345 args) args))) + collect s))) "12345" "12345" "12345" @@ -499,13 +499,13 @@ #'values (let ((fn (formatter "~,,,#:D"))) (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#:d" 1234567890 args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream 1234567890 args) args))) - do (assert (string= s s2)) - collect s))) + for args = (make-list i) + for s = (apply #'format nil "~,,,#:d" 1234567890 args) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream 1234567890 args) args))) + do (assert (string= s s2)) + collect s))) "1,2,3,4,5,6,7,8,9,0" "12,34,56,78,90" "1,234,567,890" @@ -523,13 +523,13 @@ #'values (let ((fn (formatter "~,,,#:@d"))) (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#@:D" 1234567890 args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream 1234567890 args) args))) - do (assert (string= s s2)) - collect s))) + for args = (make-list i) + for s = (apply #'format nil "~,,,#@:D" 1234567890 args) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream 1234567890 args) args))) + do (assert (string= s s2)) + collect s))) "+1,2,3,4,5,6,7,8,9,0" "+12,34,56,78,90" "+1,234,567,890" @@ -564,18 +564,18 @@ (loop for mincol = (and (coin) (random 50)) for padchar = (and (coin) - (random-from-seq +standard-chars+)) + (random-from-seq +standard-chars+)) for commachar = (and (coin) - (random-from-seq +standard-chars+)) + (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate - 'string - (if mincol (format nil "~~~d," mincol) "~,") - (if padchar (format nil "'~c," padchar) ",") - (if commachar (format nil "'~c," commachar) ",") - (if commaint (format nil "~dd" commaint) "d")) + 'string + (if mincol (format nil "~~~d," mincol) "~,") + (if padchar (format nil "'~c," padchar) ",") + (if commachar (format nil "'~c," commachar) ",") + (if commaint (format nil "~dd" commaint) "d")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,vd" mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) diff --git a/ansi-tests/format-f.lsp b/ansi-tests/format-f.lsp index 0e6fca87..e2c6a2e2 100644 --- a/ansi-tests/format-f.lsp +++ b/ansi-tests/format-f.lsp @@ -11,220 +11,220 @@ (deftest format.f.1 (let ((*print-readably* nil) - (fn (formatter "~F"))) + (fn (formatter "~F"))) (loop for type in '(short-float single-float double-float long-float - short-float single-float double-float long-float) + short-float single-float double-float long-float) for x in '(0.0s0 0.0f0 0.0d0 0.0l0 - -0.0s0 -0.0f0 -0.0d0 -0.0l0) + -0.0s0 -0.0f0 -0.0d0 -0.0l0) for s1 = (let ((*read-default-float-format* type)) (format nil "~f" x)) for s2 = (let ((*read-default-float-format* type)) (prin1-to-string x)) for s3 = (let ((*read-default-float-format* type)) - (formatter-call-to-string fn x)) + (formatter-call-to-string fn x)) unless (and (string= s1 s2) (string= s1 s3)) collect (list x type s1 s2 s3))) nil) (deftest format.f.2 (let ((*print-readably* nil) - (fn (formatter "~f"))) + (fn (formatter "~f"))) (loop for i = (random 4) for type = (elt #(short-float single-float double-float long-float) i) for x = (expt (coerce 10 type) - (- (random 10.0s0) 3)) + (- (random 10.0s0) 3)) for s1 = (let ((*read-default-float-format* type)) (format nil "~f" x)) for s2 = (let ((*read-default-float-format* type)) (prin1-to-string x)) for s3 = (let ((*read-default-float-format* type)) - (formatter-call-to-string fn x)) + (formatter-call-to-string fn x)) repeat 1000 when (and (<= 1/1000 x) - (< x 10000000) - (or (not (string= s1 s2)) - (not (string= s1 s3)))) + (< x 10000000) + (or (not (string= s1 s2)) + (not (string= s1 s3)))) collect (list x s1 s2 s3))) nil) (deftest format.f.3 (let ((*print-readably* nil) - (fn (formatter "~F"))) + (fn (formatter "~F"))) (loop for i = (random 4) for type = (elt #(short-float single-float double-float long-float) i) for x = (- (expt (coerce 10 type) - (- (random 10.0s0) 3))) + (- (random 10.0s0) 3))) for s1 = (let ((*read-default-float-format* type)) (format nil "~f" x)) for s2 = (let ((*read-default-float-format* type)) (prin1-to-string x)) for s3 = (let ((*read-default-float-format* type)) - (formatter-call-to-string fn x)) + (formatter-call-to-string fn x)) repeat 1000 when (and (>= -1/1000 x) - (> x -10000000) - (not (and (string= s1 s2) (string= s1 s3)))) + (> x -10000000) + (not (and (string= s1 s2) (string= s1 s3)))) collect (list x s1 s2 s3))) nil) (deftest format.f.4 (let ((fn (formatter "~3f"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) - for s = (format nil "~3f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "1.0") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~3f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "1.0") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.5 (let ((fn (formatter "~2f"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) - for s = (format nil "~2f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "1.") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~2f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "1.") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.6 (let ((fn (formatter "~4F"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) - for s = (format nil "~4F" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s " 1.0") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~4F" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s " 1.0") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.7 (let ((fn (formatter "~4@F"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) - for s = (format nil "~4@f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "+1.0") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~4@f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "+1.0") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.8 (let ((fn (formatter "~3@F"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) - for s = (format nil "~3@F" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "+1.") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~3@F" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "+1.") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.9 (let ((fn (formatter "~4f"))) (loop for x in (remove-duplicates '(1 1.0s0 1.0f0 1.0d0 1.0l0)) - for s = (format nil "~4f" (- x)) - for s2 = (formatter-call-to-string fn (- x)) - unless (and (string= s "-1.0") (string= s s2)) - collect (list (- x) s s2))) + for s = (format nil "~4f" (- x)) + for s2 = (formatter-call-to-string fn (- x)) + unless (and (string= s "-1.0") (string= s s2)) + collect (list (- x) s s2))) nil) (deftest format.f.10 (let ((fn (formatter "~3F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~3f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "0.5") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~3f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "0.5") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.11 (let ((fn (formatter "~4f"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~4f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s " 0.5") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~4f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s " 0.5") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.12 (let ((fn (formatter "~4,2F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~4,2f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "0.50") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~4,2f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "0.50") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.13 (let ((fn (formatter "~3,2F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~3,2f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s ".50") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~3,2f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s ".50") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.14 (let ((fn (formatter "~2,1F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~2,1f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s ".5") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~2,1f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s ".5") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.15 (let ((fn (formatter "~4,2@F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~4,2@f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "+.50") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~4,2@f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "+.50") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.16 (let ((fn (formatter "~2,2F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~2,2f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s ".50") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~2,2f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s ".50") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.17 (let ((fn (formatter "~,2F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~,2f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "0.50") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~,2f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "0.50") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.18 (let ((fn (formatter "~,2F"))) (loop for xn in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for x = (- xn) - for s = (format nil "~,2f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "-0.50") (string= s s2)) - collect (list x s s2))) + for x = (- xn) + for s = (format nil "~,2f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "-0.50") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.19 (let ((fn (formatter "~4,2,-1F"))) (loop for x in (remove-duplicates '(5 5.0s0 5.0f0 5.0d0 5.0l0)) - for s = (format nil "~4,2,-1f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "0.50") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~4,2,-1f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "0.50") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.20 (let ((fn (formatter "~4,2,0F"))) (loop for x in (remove-duplicates '(1/2 0.5s0 0.5f0 0.5d0 0.5l0)) - for s = (format nil "~4,2,0f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "0.50") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~4,2,0f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "0.50") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.21 (let ((fn (formatter "~4,2,1f"))) (loop for x in (remove-duplicates '(1/20 0.05s0 0.05f0 0.05d0 0.05l0)) - for s = (format nil "~4,2,1f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "0.50") (string= s s2)) - collect (list x s s2))) + for s = (format nil "~4,2,1f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "0.50") (string= s s2)) + collect (list x s s2))) nil) ;;; overflow @@ -232,41 +232,41 @@ (deftest format.f.22 (let ((fn (formatter "~5,1,,'*F"))) (loop for x in (remove-duplicates - '(1000 1000.0s0 1000.0f0 1000.0d0 1000.0l0)) - for s = (format nil "~5,1,,'*f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "*****") (string= s s2)) - collect (list x s s2))) + '(1000 1000.0s0 1000.0f0 1000.0d0 1000.0l0)) + for s = (format nil "~5,1,,'*f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "*****") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.23 (let ((fn (formatter "~5,1,,'*f"))) (loop for x in (remove-duplicates - '(100 100.0s0 100.0f0 100.0d0 100.0l0)) - for s = (format nil "~5,1,,'*f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "100.0") (string= s s2)) - collect (list x s s2))) + '(100 100.0s0 100.0f0 100.0d0 100.0l0)) + for s = (format nil "~5,1,,'*f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "100.0") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.24 (let ((fn (formatter "~4,0,,'*F"))) (loop for x in (remove-duplicates - '(100 100.0s0 100.0f0 100.0d0 100.0l0)) - for s = (format nil "~4,0,,'*f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "100.") (string= s s2)) - collect (list x s s2))) + '(100 100.0s0 100.0f0 100.0d0 100.0l0)) + for s = (format nil "~4,0,,'*f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "100.") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.25 (let ((fn (formatter "~1,1,,f"))) (loop for x in (remove-duplicates - '(100 100.0s0 100.0f0 100.0d0 100.0l0)) - for s = (format nil "~1,1,,f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "100.0") (string= s s2)) - collect (list x s s2))) + '(100 100.0s0 100.0f0 100.0d0 100.0l0)) + for s = (format nil "~1,1,,f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "100.0") (string= s s2)) + collect (list x s s2))) nil) ;;; padchar @@ -274,21 +274,21 @@ (deftest format.f.26 (let ((fn (formatter "~10,1,,f"))) (loop for x in (remove-duplicates - '(100 100.0s0 100.0f0 100.0d0 100.0l0)) - for s = (format nil "~10,1,,f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s " 100.0") (string= s s2)) - collect (list x s s2))) + '(100 100.0s0 100.0f0 100.0d0 100.0l0)) + for s = (format nil "~10,1,,f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s " 100.0") (string= s s2)) + collect (list x s s2))) nil) (deftest format.f.27 (let ((fn (formatter "~10,1,,,'*F"))) (loop for x in (remove-duplicates - '(100 100.0s0 100.0f0 100.0d0 100.0l0)) - for s = (format nil "~10,1,,,'*f" x) - for s2 = (formatter-call-to-string fn x) - unless (and (string= s "*****100.0") (string= s s2)) - collect (list x s s2))) + '(100 100.0s0 100.0f0 100.0d0 100.0l0)) + for s = (format nil "~10,1,,,'*f" x) + for s2 = (formatter-call-to-string fn x) + unless (and (string= s "*****100.0") (string= s s2)) + collect (list x s s2))) nil) ;;; v parameters @@ -296,56 +296,56 @@ (deftest format.f.28 (let ((fn (formatter "~VF"))) (loop for x = (random 100.0) - for s1 = (format nil "~f" x) - for s2 = (format nil "~vf" nil x) - for s3 = (formatter-call-to-string fn nil x) - repeat 100 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list x s1 s2 s3))) + for s1 = (format nil "~f" x) + for s2 = (format nil "~vf" nil x) + for s3 = (formatter-call-to-string fn nil x) + repeat 100 + unless (and (string= s1 s2) (string= s2 s3)) + collect (list x s1 s2 s3))) nil) (deftest format.f.29 (let ((fn (formatter "~,vf"))) (loop for x = (random 100.0) - for s1 = (format nil "~f" x) - for s2 = (format nil "~,vf" nil x) - for s3 = (formatter-call-to-string fn nil x) - repeat 100 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list x s1 s2 s3))) + for s1 = (format nil "~f" x) + for s2 = (format nil "~,vf" nil x) + for s3 = (formatter-call-to-string fn nil x) + repeat 100 + unless (and (string= s1 s2) (string= s2 s3)) + collect (list x s1 s2 s3))) nil) (deftest format.f.30 (let ((fn (formatter "~,,Vf"))) (loop for x = (random 100.0) - for s1 = (format nil "~f" x) - for s2 = (format nil "~,,vf" nil x) - for s3 = (formatter-call-to-string fn nil x) - repeat 100 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list x s1 s2 s3))) + for s1 = (format nil "~f" x) + for s2 = (format nil "~,,vf" nil x) + for s3 = (formatter-call-to-string fn nil x) + repeat 100 + unless (and (string= s1 s2) (string= s2 s3)) + collect (list x s1 s2 s3))) nil) (deftest format.f.31 (let ((fn (formatter "~,,,vF"))) (loop for x = (random 100.0) - for s1 = (format nil "~f" x) - for s2 = (format nil "~,,,vf" nil x) - for s3 = (formatter-call-to-string fn nil x) - repeat 100 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list x s1 s2 s3))) + for s1 = (format nil "~f" x) + for s2 = (format nil "~,,,vf" nil x) + for s3 = (formatter-call-to-string fn nil x) + repeat 100 + unless (and (string= s1 s2) (string= s2 s3)) + collect (list x s1 s2 s3))) nil) (deftest format.f.32 (let ((fn (formatter "~,,,,VF"))) (loop for x = (random 100.0) - for s1 = (format nil "~f" x) - for s2 = (format nil "~,,,,vf" nil x) - for s3 = (formatter-call-to-string fn nil x) - repeat 100 - unless (and (string= s1 s2) (string= s2 s3)) - collect (list x s1 s2 s3))) + for s1 = (format nil "~f" x) + for s2 = (format nil "~,,,,vf" nil x) + for s3 = (formatter-call-to-string fn nil x) + repeat 100 + unless (and (string= s1 s2) (string= s2 s3)) + collect (list x s1 s2 s3))) nil) ;;; Randomized tests @@ -353,22 +353,22 @@ #| (deftest format.f.33 (let ((bound (if (> 10000000 most-positive-short-float) - most-positive-short-float - (coerce 10000000 'short-float)))) + most-positive-short-float + (coerce 10000000 'short-float)))) (loop for d = (random 10) - for w = (+ 1 d (random 10)) - for x = (random bound) - for xr = (rational x) - for s = (format nil "~v,vf" w d x) - for sr = (decode-fixed-decimal-string s) - for eps = (expt 1/10 d) - for abs-xr-sr = (abs (- xr sr)) - for abs-xr-sr-hi = (abs (- xr (+ sr eps))) - for abs-xr-sr-lo = (abs (- xr (- sr eps))) - repeat 100 - unless (and (<= abs-xr-sr abs-xr-sr-hi) - (<= abs-xr-sr abs-xr-sr-lo)) - collect (list d w x xr s sr eps abs-xr-sr abs-xr-sr-hi abs-xr-sr-lo))) + for w = (+ 1 d (random 10)) + for x = (random bound) + for xr = (rational x) + for s = (format nil "~v,vf" w d x) + for sr = (decode-fixed-decimal-string s) + for eps = (expt 1/10 d) + for abs-xr-sr = (abs (- xr sr)) + for abs-xr-sr-hi = (abs (- xr (+ sr eps))) + for abs-xr-sr-lo = (abs (- xr (- sr eps))) + repeat 100 + unless (and (<= abs-xr-sr abs-xr-sr-hi) + (<= abs-xr-sr abs-xr-sr-lo)) + collect (list d w x xr s sr eps abs-xr-sr abs-xr-sr-hi abs-xr-sr-lo))) nil) |# @@ -376,47 +376,47 @@ (with-standard-io-syntax (let ((*read-default-float-format* 'short-float)) (loop for i from (- 1 (ash 1 13)) below (ash 1 13) - for sf = (coerce i 'short-float) - for s = (format nil "~f" sf) - for i2 = (floor (read-from-string s)) - unless (or (zerop i) (eql i i2)) - collect (list i sf s i2)))) + for sf = (coerce i 'short-float) + for s = (format nil "~f" sf) + for i2 = (floor (read-from-string s)) + unless (or (zerop i) (eql i i2)) + collect (list i sf s i2)))) nil) (deftest format.f.35 (with-standard-io-syntax (let ((*read-default-float-format* 'single-float)) (loop for i = (- (random (1- (ash 1 25))) -1 (ash 1 24)) - for sf = (coerce i 'single-float) - for s = (format nil "~f" sf) - for i2 = (floor (read-from-string s)) - repeat 2000 - unless (or (zerop i) (eql i i2)) - collect (list i sf s i2)))) + for sf = (coerce i 'single-float) + for s = (format nil "~f" sf) + for i2 = (floor (read-from-string s)) + repeat 2000 + unless (or (zerop i) (eql i i2)) + collect (list i sf s i2)))) nil) (deftest format.f.36 (with-standard-io-syntax (let ((*read-default-float-format* 'double-float)) (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) - for sf = (coerce i 'double-float) - for s = (format nil "~f" sf) - for i2 = (floor (read-from-string s)) - repeat 2000 - unless (or (zerop i) (eql i i2)) - collect (list i sf s i2)))) + for sf = (coerce i 'double-float) + for s = (format nil "~f" sf) + for i2 = (floor (read-from-string s)) + repeat 2000 + unless (or (zerop i) (eql i i2)) + collect (list i sf s i2)))) nil) (deftest format.f.37 (with-standard-io-syntax (let ((*read-default-float-format* 'long-float)) (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) - for sf = (coerce i 'long-float) - for s = (format nil "~f" sf) - for i2 = (floor (read-from-string s)) - repeat 2000 - unless (or (zerop i) (eql i i2)) - collect (list i sf s i2)))) + for sf = (coerce i 'long-float) + for s = (format nil "~f" sf) + for i2 = (floor (read-from-string s)) + repeat 2000 + unless (or (zerop i) (eql i i2)) + collect (list i sf s i2)))) nil) (deftest format.f.38 @@ -425,66 +425,66 @@ nil '(lambda () (with-standard-io-syntax - (let ((*read-default-float-format* 'short-float) - (total 0) - (len 0)) - (loop for i from (- 1 (ash 1 13)) below (ash 1 13) - unless (zerop i) - nconc - (loop for sf = (coerce i 'short-float) - for w = (random 8) - for d = (random 4) - for s = (format nil "~v,vf" w d sf) - for i2 = (ignore-errors (floor (read-from-string s))) - repeat 5 - ; do (print (list w d s i i2)) - unless (eql i i2) - do (incf total) - and collect (list i sf w d s i2)) - when (> total 100) collect "count limit exceeded" - and do (loop-finish))))))) + (let ((*read-default-float-format* 'short-float) + (total 0) + (len 0)) + (loop for i from (- 1 (ash 1 13)) below (ash 1 13) + unless (zerop i) + nconc + (loop for sf = (coerce i 'short-float) + for w = (random 8) + for d = (random 4) + for s = (format nil "~v,vf" w d sf) + for i2 = (ignore-errors (floor (read-from-string s))) + repeat 5 + ; do (print (list w d s i i2)) + unless (eql i i2) + do (incf total) + and collect (list i sf w d s i2)) + when (> total 100) collect "count limit exceeded" + and do (loop-finish))))))) nil) (deftest format.f.39 (with-standard-io-syntax (let ((*read-default-float-format* 'single-float)) (loop for i = (- (random (1- (ash 1 25))) -1 (ash 1 24)) - for sf = (coerce i 'single-float) - for w = (and (coin) (random 16)) - for d = (random 4) - for s = (format nil "~v,vf" w d sf) - for i2 = (floor (read-from-string s)) - repeat 2000 - unless (or (zerop i) (eql i i2)) - collect (list i sf w d s i2)))) + for sf = (coerce i 'single-float) + for w = (and (coin) (random 16)) + for d = (random 4) + for s = (format nil "~v,vf" w d sf) + for i2 = (floor (read-from-string s)) + repeat 2000 + unless (or (zerop i) (eql i i2)) + collect (list i sf w d s i2)))) nil) (deftest format.f.40 (with-standard-io-syntax (let ((*read-default-float-format* 'double-float)) (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) - for sf = (coerce i 'double-float) - for w = (and (coin) (random 30)) - for d = (random 6) - for s = (format nil "~v,vf" w d sf) - for i2 = (floor (read-from-string s)) - repeat 2000 - unless (or (zerop i) (eql i i2)) - collect (list i sf w d s i2)))) + for sf = (coerce i 'double-float) + for w = (and (coin) (random 30)) + for d = (random 6) + for s = (format nil "~v,vf" w d sf) + for i2 = (floor (read-from-string s)) + repeat 2000 + unless (or (zerop i) (eql i i2)) + collect (list i sf w d s i2)))) nil) (deftest format.f.41 (with-standard-io-syntax (let ((*read-default-float-format* 'long-float)) (loop for i = (- (random (1- (ash 1 51))) -1 (ash 1 50)) - for sf = (coerce i 'long-float) - for w = (and (coin) (random 30)) - for d = (random 6) - for s = (format nil "~v,vf" w d sf) - for i2 = (floor (read-from-string s)) - repeat 2000 - unless (or (zerop i) (eql i i2)) - collect (list i sf w d s i2)))) + for sf = (coerce i 'long-float) + for w = (and (coin) (random 30)) + for d = (random 6) + for s = (format nil "~v,vf" w d sf) + for i2 = (floor (read-from-string s)) + repeat 2000 + unless (or (zerop i) (eql i i2)) + collect (list i sf w d s i2)))) nil) (deftest format.f.42 @@ -492,26 +492,26 @@ (loop for k = (and (coin) (random 6)) for x = (random (/ (random-from-seq #(#.(coerce (* 32 (1- (ash 1 13))) 'short-float) - #.(coerce (* 256 (1- (ash 1 24))) 'single-float) - #.(coerce (* 256 (1- (ash 1 50))) 'double-float) - #.(coerce (* 256 (1- (ash 1 50))) 'long-float))) - (if k (expt 10 k) 1))) + #.(coerce (* 256 (1- (ash 1 24))) 'single-float) + #.(coerce (* 256 (1- (ash 1 50))) 'double-float) + #.(coerce (* 256 (1- (ash 1 50))) 'long-float))) + (if k (expt 10 k) 1))) for w = (and (coin) (random 30)) for d = (and (coin) (random 10)) for overflowchar = (and (coin) (random-from-seq chars)) for padchar = (and (coin) (random-from-seq chars)) for f1 = (concatenate 'string - "~" - (if w (format nil "~d" w) "") - "," - (if d (format nil "~d" d) "") - "," - (if k (format nil "~d" k) "") - "," - (if overflowchar (format nil "'~c" overflowchar) "") - "," - (if padchar (format nil "'~c" padchar) "") - (string (random-from-seq "fF"))) + "~" + (if w (format nil "~d" w) "") + "," + (if d (format nil "~d" d) "") + "," + (if k (format nil "~d" k) "") + "," + (if overflowchar (format nil "'~c" overflowchar) "") + "," + (if padchar (format nil "'~c" padchar) "") + (string (random-from-seq "fF"))) for s1 = (format nil f1 x) for s2 = (format nil "~v,v,v,v,vf" w d k overflowchar padchar x) repeat 2000 @@ -526,11 +526,11 @@ (deftest format.f.44 (loop for i from 0 below (min #x10000 char-code-limit) - for x = 2312.9817 - for c = (code-char i) - for f1 = (and c (format nil "~~,,,,'~cf" c)) - for s1 = (and c (ignore-errors (format nil f1 x))) - for s2 = (and c (format nil "~,,,,vf" c x)) - unless (equal s1 s2) - collect (list i c f1 s1 s2)) + for x = 2312.9817 + for c = (code-char i) + for f1 = (and c (format nil "~~,,,,'~cf" c)) + for s1 = (and c (ignore-errors (format nil f1 x))) + for s2 = (and c (format nil "~,,,,vf" c x)) + unless (equal s1 s2) + collect (list i c f1 s1 s2)) nil) diff --git a/ansi-tests/format-justify.lsp b/ansi-tests/format-justify.lsp index f3b2737e..d157debc 100644 --- a/ansi-tests/format-justify.lsp +++ b/ansi-tests/format-justify.lsp @@ -13,122 +13,122 @@ (def-pprint-test format.justify.2 (loop for i from 1 to 20 - for s1 = (make-string i :initial-element #\x) - for s2 = (format nil "~<~A~>" s1) - unless (string= s1 s2) - collect (list i s1 s2)) + for s1 = (make-string i :initial-element #\x) + for s2 = (format nil "~<~A~>" s1) + unless (string= s1 s2) + collect (list i s1 s2)) nil) (def-pprint-test format.justify.3 (loop for i from 1 to 20 - for s1 = (make-string i :initial-element #\x) - for s2 = (format nil "~<~A~;~A~>" s1 s1) - unless (string= s2 (concatenate 'string s1 s1)) - collect (list i s1 s2)) + for s1 = (make-string i :initial-element #\x) + for s2 = (format nil "~<~A~;~A~>" s1 s1) + unless (string= s2 (concatenate 'string s1 s1)) + collect (list i s1 s2)) nil) (def-pprint-test format.justify.4 (loop for i from 1 to 20 - for s1 = (make-string i :initial-element #\x) - for expected = (concatenate 'string s1 " " s1) - for s2 = (format nil "~,,1<~A~;~A~>" s1 s1) - unless (string= s2 expected) - collect (list i expected s2)) + for s1 = (make-string i :initial-element #\x) + for expected = (concatenate 'string s1 " " s1) + for s2 = (format nil "~,,1<~A~;~A~>" s1 s1) + unless (string= s2 expected) + collect (list i expected s2)) nil) (def-pprint-test format.justify.5 (loop for i from 1 to 20 - for s1 = (make-string i :initial-element #\x) - for expected = (concatenate 'string s1 "," s1) - for s2 = (format nil "~,,1,',<~A~;~A~>" s1 s1) - unless (string= s2 expected) - collect (list i expected s2)) + for s1 = (make-string i :initial-element #\x) + for expected = (concatenate 'string s1 "," s1) + for s2 = (format nil "~,,1,',<~A~;~A~>" s1 s1) + unless (string= s2 expected) + collect (list i expected s2)) nil) (def-pprint-test format.justify.6 (loop for i from 1 to 20 - for s1 = (make-string i :initial-element #\x) - for expected = (concatenate 'string s1 " " s1) - for s2 = (format nil "~,,2<~A~;~A~>" s1 s1) - unless (string= s2 expected) - collect (list i expected s2)) + for s1 = (make-string i :initial-element #\x) + for expected = (concatenate 'string s1 " " s1) + for s2 = (format nil "~,,2<~A~;~A~>" s1 s1) + unless (string= s2 expected) + collect (list i expected s2)) nil) (def-pprint-test format.justify.7 (loop for mincol = (random 50) - for len = (random 50) - for s1 = (make-string len :initial-element #\x) - for s2 = (format nil "~v<~A~>" mincol s1) - for expected = (if (< len mincol) - (concatenate 'string - (make-string (- mincol len) :initial-element #\Space) - s1) - s1) - repeat 100 - unless (string= s2 expected) - collect (list mincol len s1 s2 expected)) + for len = (random 50) + for s1 = (make-string len :initial-element #\x) + for s2 = (format nil "~v<~A~>" mincol s1) + for expected = (if (< len mincol) + (concatenate 'string + (make-string (- mincol len) :initial-element #\Space) + s1) + s1) + repeat 100 + unless (string= s2 expected) + collect (list mincol len s1 s2 expected)) nil) (def-pprint-test format.justify.8 (loop for mincol = (random 50) - for minpad = (random 10) - for len = (random 50) - for s1 = (make-string len :initial-element #\x) - for s2 = (format nil "~v,,v<~A~>" mincol minpad s1) - for expected = (if (< len mincol) - (concatenate 'string - (make-string (- mincol len) :initial-element #\Space) - s1) - s1) - repeat 100 - unless (string= s2 expected) - collect (list mincol minpad len s1 s2 expected)) + for minpad = (random 10) + for len = (random 50) + for s1 = (make-string len :initial-element #\x) + for s2 = (format nil "~v,,v<~A~>" mincol minpad s1) + for expected = (if (< len mincol) + (concatenate 'string + (make-string (- mincol len) :initial-element #\Space) + s1) + s1) + repeat 100 + unless (string= s2 expected) + collect (list mincol minpad len s1 s2 expected)) nil) (def-pprint-test format.justify.9 (loop for mincol = (random 50) - for padchar = (random-from-seq +standard-chars+) - for len = (random 50) - for s1 = (make-string len :initial-element #\x) - for s2 = (format nil "~v,,,v<~A~>" mincol padchar s1) - for expected = (if (< len mincol) - (concatenate 'string - (make-string (- mincol len) :initial-element padchar) - s1) - s1) - repeat 100 - unless (string= s2 expected) - collect (list mincol padchar len s1 s2 expected)) + for padchar = (random-from-seq +standard-chars+) + for len = (random 50) + for s1 = (make-string len :initial-element #\x) + for s2 = (format nil "~v,,,v<~A~>" mincol padchar s1) + for expected = (if (< len mincol) + (concatenate 'string + (make-string (- mincol len) :initial-element padchar) + s1) + s1) + repeat 100 + unless (string= s2 expected) + collect (list mincol padchar len s1 s2 expected)) nil) (def-pprint-test format.justify.10 (loop for mincol = (random 50) - for padchar = (random-from-seq +standard-chars+) - for len = (random 50) - for s1 = (make-string len :initial-element #\x) - for s2 = (format nil (format nil "~~~d,,,'~c<~~A~~>" mincol padchar) s1) - for expected = (if (< len mincol) - (concatenate 'string - (make-string (- mincol len) :initial-element padchar) - s1) - s1) - repeat 500 - unless (string= s2 expected) - collect (list mincol padchar len s1 s2 expected)) + for padchar = (random-from-seq +standard-chars+) + for len = (random 50) + for s1 = (make-string len :initial-element #\x) + for s2 = (format nil (format nil "~~~d,,,'~c<~~A~~>" mincol padchar) s1) + for expected = (if (< len mincol) + (concatenate 'string + (make-string (- mincol len) :initial-element padchar) + s1) + s1) + repeat 500 + unless (string= s2 expected) + collect (list mincol padchar len s1 s2 expected)) nil) (def-pprint-test format.justify.11 (loop for i = (1+ (random 20)) - for colinc = (1+ (random 10)) - for s1 = (make-string i :initial-element #\x) - for s2 = (format nil "~,v<~A~>" colinc s1) - for expected-len = (* colinc (ceiling i colinc)) - for expected = (concatenate 'string - (make-string (- expected-len i) :initial-element #\Space) - s1) - repeat 10 - unless (string= expected s2) - collect (list i colinc expected s2)) + for colinc = (1+ (random 10)) + for s1 = (make-string i :initial-element #\x) + for s2 = (format nil "~,v<~A~>" colinc s1) + for expected-len = (* colinc (ceiling i colinc)) + for expected = (concatenate 'string + (make-string (- expected-len i) :initial-element #\Space) + s1) + repeat 10 + unless (string= expected s2) + collect (list i colinc expected s2)) nil) (def-pprint-test format.justify.12 @@ -213,7 +213,7 @@ X AAA BBB CCC") (def-pprint-test format.justify.30 (format nil "~%X ~<~%X ~0,3:;AAA~>~<~%X ~0,3:;BBB~>~<~%X ~0,3:;CCC~>") " -X +X X AAA X BBB X CCC") @@ -226,7 +226,7 @@ X AAABBBCCC") (def-pprint-test format.justify.32 (format nil "~%X ~<~%X ~0,3:;AAA~>,~<~%X ~0,3:;BBB~>,~<~%X ~0,3:;CCC~>") " -X +X X AAA, X BBB, X CCC") diff --git a/ansi-tests/format-logical-block.lsp b/ansi-tests/format-logical-block.lsp index c1b97d14..5f764f4e 100644 --- a/ansi-tests/format-logical-block.lsp +++ b/ansi-tests/format-logical-block.lsp @@ -286,8 +286,8 @@ (def-pprint-test format.logical-block.circle.3 (format nil "~:<~@{~A~^ ~}~:>" (let ((x (list 0))) - (setf (cdr x) x) - x)) + (setf (cdr x) x) + x)) "#1=(0 . #1#)" :circle t :len 500) diff --git a/ansi-tests/format-o.lsp b/ansi-tests/format-o.lsp index 60176aeb..4ded9b77 100644 --- a/ansi-tests/format-o.lsp +++ b/ansi-tests/format-o.lsp @@ -11,194 +11,194 @@ (let ((fn (formatter "~o"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~O" i) - for j = (let ((*read-base* 8)) (read-from-string s1)) - for s2 = (formatter-call-to-string fn i) - repeat 1000 - when (or (/= i j) - (not (string= s1 s2)) - (find #\. s1) - (find #\+ s1) - (find-if #'alpha-char-p s1)) - collect (list i s1 j s2)))) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~O" i) + for j = (let ((*read-base* 8)) (read-from-string s1)) + for s2 = (formatter-call-to-string fn i) + repeat 1000 + when (or (/= i j) + (not (string= s1 s2)) + (find #\. s1) + (find #\+ s1) + (find-if #'alpha-char-p s1)) + collect (list i s1 j s2)))) nil) (deftest format.o.2 (let ((fn (formatter "~@O"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@o" i) - for j = (let ((*read-base* 8)) (read-from-string s1)) - for s2 = (formatter-call-to-string fn i) - repeat 1000 - when (or (/= i j) - (not (string= s1 s2)) - (find #\. s1) - ;; (find #\+ s1) - (find-if #'alpha-char-p s1)) - collect (list i s1 j s2)))) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@o" i) + for j = (let ((*read-base* 8)) (read-from-string s1)) + for s2 = (formatter-call-to-string fn i) + repeat 1000 + when (or (/= i j) + (not (string= s1 s2)) + (find #\. s1) + ;; (find #\+ s1) + (find-if #'alpha-char-p s1)) + collect (list i s1 j s2)))) nil) (deftest format.o.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~o" i) - for fmt = (format nil "~~~do" mincol) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~o" i) + for fmt = (format nil "~~~do" mincol) + for s2 = (format nil fmt i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest formatter.o.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~o" i) - for fmt = (format nil "~~~do" mincol) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~o" i) + for fmt = (format nil "~~~do" mincol) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn i) + for pos = (search s1 s2) + repeat 100 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest format.o.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@O" i) - for fmt = (format nil "~~~d@o" mincol) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@O" i) + for fmt = (format nil "~~~d@o" mincol) + for s2 = (format nil fmt i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (and (>= i 0) (not (eql (elt s1 0) #\+))) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest formatter.o.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@O" i) - for fmt = (format nil "~~~d@o" mincol) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@O" i) + for fmt = (format nil "~~~d@o" mincol) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn i) + for pos = (search s1 s2) + repeat 100 + when (or (null pos) + (and (>= i 0) (not (eql (elt s1 0) #\+))) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest format.o.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~o" i) - for fmt = (format nil "~~~d,'~c~c" mincol padchar - (random-from-seq "oO")) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~o" i) + for fmt = (format nil "~~~d,'~c~c" mincol padchar + (random-from-seq "oO")) + for s2 = (format nil fmt i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 pos))) nil) (deftest formatter.o.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~o" i) - for fmt = (format nil "~~~d,'~c~c" mincol padchar - (random-from-seq "oO")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~o" i) + for fmt = (format nil "~~~d,'~c~c" mincol padchar + (random-from-seq "oO")) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn i) + for pos = (search s1 s2) + repeat 100 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 pos))) nil) (deftest format.o.6 (let ((fn (formatter "~V,Vo"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~o" i) - for s2 = (format nil "~v,vO" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~o" i) + for s2 = (format nil "~v,vO" mincol padchar i) + for s3 = (formatter-call-to-string fn mincol padchar i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (not (string= s2 s3)) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 s3 pos)))) nil) (deftest format.o.7 (let ((fn (formatter "~v,V@O"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@o" i) - for s2 = (format nil "~v,v@o" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@o" i) + for s2 = (format nil "~v,v@o" mincol padchar i) + for s3 = (formatter-call-to-string fn mincol padchar i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (not (string= s2 s3)) + (and (>= i 0) (not (eql (elt s1 0) #\+))) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 s3 pos)))) nil) ;;; Comma tests @@ -206,153 +206,153 @@ (deftest format.o.8 (let ((fn (formatter "~:O"))) (loop for i from #o-777 to #o777 - for s1 = (format nil "~o" i) - for s2 = (format nil "~:o" i) - for s3 = (formatter-call-to-string fn i) - unless (and (string= s1 s2) (string= s2 s3)) - collect (list i s1 s2 s3))) + for s1 = (format nil "~o" i) + for s2 = (format nil "~:o" i) + for s3 = (formatter-call-to-string fn i) + unless (and (string= s1 s2) (string= s2 s3)) + collect (list i s1 s2 s3))) nil) (deftest format.o.9 (let ((fn (formatter "~:o"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = #\, - for s1 = (format nil "~o" i) - for s2 = (format nil "~:O" i) - for s3 = (formatter-call-to-string fn i) - repeat 1000 - unless (and (string= s1 (remove commachar s2)) - (string= s2 s3) - (not (eql (elt s2 0) commachar)) - (or (>= i 0) (not (eql (elt s2 1) commachar))) - (let ((len (length s2)) - (ci+1 4)) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (find (elt s2 i) "01234567"))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = #\, + for s1 = (format nil "~o" i) + for s2 = (format nil "~:O" i) + for s3 = (formatter-call-to-string fn i) + repeat 1000 + unless (and (string= s1 (remove commachar s2)) + (string= s2 s3) + (not (eql (elt s2 0) commachar)) + (or (>= i 0) (not (eql (elt s2 1) commachar))) + (let ((len (length s2)) + (ci+1 4)) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (find (elt s2 i) "01234567"))))) + collect (list x i commachar s1 s2 s3)))) nil) (deftest format.o.10 (let ((fn (formatter "~,,v:o"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~o" i) - for s2 = (format nil "~,,v:o" commachar i) - for s3 = (formatter-call-to-string fn commachar i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (string= s2 s3) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for s1 = (format nil "~o" i) + for s2 = (format nil "~,,v:o" commachar i) + for s3 = (formatter-call-to-string fn commachar i) + repeat 1000 + unless (and + (eql (elt s1 0) (elt s2 0)) + (string= s2 s3) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 4) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2 s3)))) nil) (deftest format.o.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~o" i) - for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "oO")) - for s2 = (format nil fmt i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for s1 = (format nil "~o" i) + for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "oO")) + for s2 = (format nil fmt i) + repeat 1000 + unless (and + (eql (elt s1 0) (elt s2 0)) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 4) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2))) nil) (deftest formatter.o.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~o" i) - for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "oO")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - repeat 100 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for s1 = (format nil "~o" i) + for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "oO")) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn i) + repeat 100 + unless (and + (eql (elt s1 0) (elt s2 0)) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 4) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2))) nil) (deftest format.o.12 (let ((fn (formatter "~,,V,v:O"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~o" i) - for s2 = (format nil "~,,v,v:O" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (string= s2 s3) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for commaint = (1+ (random 20)) + for s1 = (format nil "~o" i) + for s2 = (format nil "~,,v,v:O" commachar commaint i) + for s3 = (formatter-call-to-string fn commachar commaint i) + repeat 1000 + unless (and + (eql (elt s1 0) (elt s2 0)) + (string= s2 s3) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 (1+ commaint)) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2 s3)))) nil) (deftest format.o.13 (let ((fn (formatter "~,,v,V@:O"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~@o" i) - for s2 = (format nil "~,,v,v:@o" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (string= s2 s3) - (eql (elt s1 0) (elt s2 0)) - (eql (elt s1 1) (elt s2 1)) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j 1)) - (loop for i from 2 below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for commaint = (1+ (random 20)) + for s1 = (format nil "~@o" i) + for s2 = (format nil "~,,v,v:@o" commachar commaint i) + for s3 = (formatter-call-to-string fn commachar commaint i) + repeat 1000 + unless (and + (string= s2 s3) + (eql (elt s1 0) (elt s2 0)) + (eql (elt s1 1) (elt s2 1)) + (let ((len (length s2)) + (ci+1 (1+ commaint)) + (j 1)) + (loop for i from 2 below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2 s3)))) nil) ;;; NIL arguments @@ -374,43 +374,43 @@ (deftest format.o.18 (let ((fn (formatter "~o"))) (loop for x in *mini-universe* - for s1 = (format nil "~o" x) - for s2 = (let ((*print-base* 8)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) + for s1 = (format nil "~o" x) + for s2 = (let ((*print-base* 8)) (format nil "~A" x)) + for s3 = (formatter-call-to-string fn x) + unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) + collect (list x s1 s2 s3))) nil) (deftest format.o.19 (let ((fn (formatter "~:o"))) (loop for x in *mini-universe* - for s1 = (format nil "~:o" x) - for s2 = (let ((*print-base* 8)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) + for s1 = (format nil "~:o" x) + for s2 = (let ((*print-base* 8)) (format nil "~A" x)) + for s3 = (formatter-call-to-string fn x) + unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) + collect (list x s1 s2 s3))) nil) (deftest format.o.20 (let ((fn (formatter "~@o"))) (loop for x in *mini-universe* - for s1 = (format nil "~@o" x) - for s2 = (let ((*print-base* 8)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) + for s1 = (format nil "~@o" x) + for s2 = (let ((*print-base* 8)) (format nil "~A" x)) + for s3 = (formatter-call-to-string fn x) + unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) + collect (list x s1 s2 s3))) nil) (deftest format.o.21 (let ((fn (formatter "~:@o"))) (loop for x in *mini-universe* - for s1 = (let ((*print-base* 8)) (format nil "~A" x)) - for s2 = (format nil "~@:o" x) - for s3 = (formatter-call-to-string fn x) - for s4 = (let ((*print-base* 8)) (format nil "~A" x)) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3)) - (string/= s1 s4)) - collect (list x s1 s2 s3))) + for s1 = (let ((*print-base* 8)) (format nil "~A" x)) + for s2 = (format nil "~@:o" x) + for s3 = (formatter-call-to-string fn x) + for s4 = (let ((*print-base* 8)) (format nil "~A" x)) + unless (or (integerp x) (and (string= s1 s2) (string= s2 s3)) + (string/= s1 s4)) + collect (list x s1 s2 s3))) nil) ;;; Must add tests for non-integers when the parameters @@ -424,15 +424,15 @@ (apply #'values (let ((fn (formatter "~#o")) - (n #o12345)) + (n #o12345)) (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~#o" n args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream n args) args))) - do (assert (string= s s2)) - collect s))) + for args = (make-list i) + for s = (apply #'format nil "~#o" n args) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream n args) args))) + do (assert (string= s s2)) + collect s))) "12345" "12345" "12345" @@ -449,15 +449,15 @@ (apply #'values (let ((fn (formatter "~,,,#:o")) - (n #o1234567012)) + (n #o1234567012)) (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#:o" n args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream n args) args))) - do (assert (string= s s2)) - collect s))) + for args = (make-list i) + for s = (apply #'format nil "~,,,#:o" n args) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream n args) args))) + do (assert (string= s s2)) + collect s))) "1,2,3,4,5,6,7,0,1,2" "12,34,56,70,12" "1,234,567,012" @@ -474,15 +474,15 @@ (apply #'values (let ((fn (formatter "~,,,#:@o")) - (n #o1234567012)) + (n #o1234567012)) (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#@:O" n args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream n args) args))) - do (assert (string= s s2)) - collect s))) + for args = (make-list i) + for s = (apply #'format nil "~,,,#@:O" n args) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream n args) args))) + do (assert (string= s s2)) + collect s))) "+1,2,3,4,5,6,7,0,1,2" "+12,34,56,70,12" "+1,234,567,012" @@ -517,18 +517,18 @@ (loop for mincol = (and (coin) (random 50)) for padchar = (and (coin) - (random-from-seq +standard-chars+)) + (random-from-seq +standard-chars+)) for commachar = (and (coin) - (random-from-seq +standard-chars+)) + (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate - 'string - (if mincol (format nil "~~~d," mincol) "~,") - (if padchar (format nil "'~c," padchar) ",") - (if commachar (format nil "'~c," commachar) ",") - (if commaint (format nil "~do" commaint) "o")) + 'string + (if mincol (format nil "~~~d," mincol) "~,") + (if padchar (format nil "'~c," padchar) ",") + (if commachar (format nil "'~c," commachar) ",") + (if commaint (format nil "~do" commaint) "o")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,vo" mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) diff --git a/ansi-tests/format-p.lsp b/ansi-tests/format-p.lsp index 3285222f..adfa42d7 100644 --- a/ansi-tests/format-p.lsp +++ b/ansi-tests/format-p.lsp @@ -21,17 +21,17 @@ (deftest format.p.5 (loop for x in *universe* - for s = (format nil "~p" x) - unless (or (eql x 1) (string= s "s")) - collect (list x s)) + for s = (format nil "~p" x) + unless (or (eql x 1) (string= s "s")) + collect (list x s)) nil) (deftest formatter.p.5 (let ((fn (formatter "~p"))) (loop for x in *universe* - for s = (formatter-call-to-string fn x) - unless (or (eql x 1) (string= s "s")) - collect (list x s))) + for s = (formatter-call-to-string fn x) + unless (or (eql x 1) (string= s "s")) + collect (list x s))) nil) ;;; :p @@ -78,15 +78,15 @@ (deftest format.p.18 (loop for x in *universe* - for s = (format nil "~@p" x) - unless (or (eql x 1) (string= s "ies")) - collect (list x s)) + for s = (format nil "~@p" x) + unless (or (eql x 1) (string= s "ies")) + collect (list x s)) nil) (deftest formatter.p.18 (let ((fn (formatter "~@P"))) (loop for x in *universe* - for s = (formatter-call-to-string fn x) - unless (or (eql x 1) (string= s "ies")) - collect (list x s))) + for s = (formatter-call-to-string fn x) + unless (or (eql x 1) (string= s "ies")) + collect (list x s))) nil) diff --git a/ansi-tests/format-page.lsp b/ansi-tests/format-page.lsp index 8678c29e..2320f18b 100644 --- a/ansi-tests/format-page.lsp +++ b/ansi-tests/format-page.lsp @@ -16,11 +16,11 @@ ((> (length s) 1) (values s :too-long)) (t (let ((c (elt s 0))) - (loop for i from 2 to 100 - for s = (format nil (format nil "~~~D|" i)) - unless (and (= (length s) i) - (every #'(lambda (c2) (char= c c2)) s)) - collect i))))) + (loop for i from 2 to 100 + for s = (format nil (format nil "~~~D|" i)) + unless (and (= (length s) i) + (every #'(lambda (c2) (char= c c2)) s)) + collect i))))) nil) (deftest format.page.3 @@ -30,11 +30,11 @@ ((> (length s) 1) (values s :too-long)) (t (let ((c (elt s 0))) - (loop for i from 2 to 100 - for s = (format nil "~v|" i) - unless (and (= (length s) i) - (every #'(lambda (c2) (char= c c2)) s)) - collect i))))) + (loop for i from 2 to 100 + for s = (format nil "~v|" i) + unless (and (= (length s) i) + (every #'(lambda (c2) (char= c c2)) s)) + collect i))))) nil) (def-format-test format.page.4 diff --git a/ansi-tests/format-paren.lsp b/ansi-tests/format-paren.lsp index 46312e4c..c79a0575 100644 --- a/ansi-tests/format-paren.lsp +++ b/ansi-tests/format-paren.lsp @@ -13,39 +13,39 @@ ;;; Conversion of simple characters to downcase (deftest format.paren.2 (loop for i from 0 below (min char-code-limit (ash 1 16)) - for c = (code-char i) - when (and c - (eql (char-code c) (char-int c)) - (upper-case-p c) - (let ((s1 (format nil "~(~c~)" c)) - (s2 (string (char-downcase c)))) - (if - (or (not (eql (length s1) 1)) - (not (eql (length s2) 1)) - (not (eql (elt s1 0) - (elt s2 0)))) - (list i c s1 s2) - nil))) - collect it) + for c = (code-char i) + when (and c + (eql (char-code c) (char-int c)) + (upper-case-p c) + (let ((s1 (format nil "~(~c~)" c)) + (s2 (string (char-downcase c)))) + (if + (or (not (eql (length s1) 1)) + (not (eql (length s2) 1)) + (not (eql (elt s1 0) + (elt s2 0)))) + (list i c s1 s2) + nil))) + collect it) nil) (deftest formatter.paren.2 (let ((fn (formatter "~(~c~)"))) (loop for i from 0 below (min char-code-limit (ash 1 16)) - for c = (code-char i) - when (and c - (eql (char-code c) (char-int c)) - (upper-case-p c) - (let ((s1 (formatter-call-to-string fn c)) - (s2 (string (char-downcase c)))) - (if - (or (not (eql (length s1) 1)) - (not (eql (length s2) 1)) - (not (eql (elt s1 0) - (elt s2 0)))) - (list i c s1 s2) - nil))) - collect it)) + for c = (code-char i) + when (and c + (eql (char-code c) (char-int c)) + (upper-case-p c) + (let ((s1 (formatter-call-to-string fn c)) + (s2 (string (char-downcase c)))) + (if + (or (not (eql (length s1) 1)) + (not (eql (length s2) 1)) + (not (eql (elt s1 0) + (elt s2 0)))) + (list i c s1 s2) + nil))) + collect it)) nil) @@ -57,7 +57,7 @@ (def-format-test format.paren.5 "~:(this is a TEST.~)" nil "This Is A Test.") - + (def-format-test format.paren.6 "~:(this is7a TEST.~)" nil "This Is7a Test.") @@ -66,39 +66,39 @@ (deftest format.paren.8 (loop for i from 0 below (min char-code-limit (ash 1 16)) - for c = (code-char i) - when (and c - (eql (char-code c) (char-int c)) - (lower-case-p c) - (let ((s1 (format nil "~@:(~c~)" c)) - (s2 (string (char-upcase c)))) - (if - (or (not (eql (length s1) 1)) - (not (eql (length s2) 1)) - (not (eql (elt s1 0) - (elt s2 0)))) - (list i c s1 s2) - nil))) - collect it) + for c = (code-char i) + when (and c + (eql (char-code c) (char-int c)) + (lower-case-p c) + (let ((s1 (format nil "~@:(~c~)" c)) + (s2 (string (char-upcase c)))) + (if + (or (not (eql (length s1) 1)) + (not (eql (length s2) 1)) + (not (eql (elt s1 0) + (elt s2 0)))) + (list i c s1 s2) + nil))) + collect it) nil) (deftest formatter.paren.8 (let ((fn (formatter "~@:(~c~)"))) (loop for i from 0 below (min char-code-limit (ash 1 16)) - for c = (code-char i) - when (and c - (eql (char-code c) (char-int c)) - (lower-case-p c) - (let ((s1 (formatter-call-to-string fn c)) - (s2 (string (char-upcase c)))) - (if - (or (not (eql (length s1) 1)) - (not (eql (length s2) 1)) - (not (eql (elt s1 0) - (elt s2 0)))) - (list i c s1 s2) - nil))) - collect it)) + for c = (code-char i) + when (and c + (eql (char-code c) (char-int c)) + (lower-case-p c) + (let ((s1 (formatter-call-to-string fn c)) + (s2 (string (char-upcase c)))) + (if + (or (not (eql (length s1) 1)) + (not (eql (length s2) 1)) + (not (eql (elt s1 0) + (elt s2 0)))) + (list i c s1 s2) + nil))) + collect it)) nil) ;;; Nested conversion diff --git a/ansi-tests/format-percent.lsp b/ansi-tests/format-percent.lsp index 3d881099..96813b5c 100644 --- a/ansi-tests/format-percent.lsp +++ b/ansi-tests/format-percent.lsp @@ -11,13 +11,13 @@ (deftest format.%.2 (loop for i from 0 to 100 - for s1 = (make-string i :initial-element #\Newline) - for format-string = (format nil "~~~D%" i) - for s2 = (format nil format-string) - for fn = (eval `(formatter ,s2)) - for s3 = (formatter-call-to-string fn) - unless (and (string= s1 s2) (string= s1 s3)) - collect i) + for s1 = (make-string i :initial-element #\Newline) + for format-string = (format nil "~~~D%" i) + for s2 = (format nil format-string) + for fn = (eval `(formatter ,s2)) + for s3 = (formatter-call-to-string fn) + unless (and (string= s1 s2) (string= s1 s3)) + collect i) nil) (def-format-test format.%.3 @@ -28,38 +28,38 @@ (deftest format.%.5 (loop for i from 0 to 100 - for s1 = (make-string i :initial-element #\Newline) - for s2 = (format nil "~v%" i) - unless (string= s1 s2) - collect i) + for s1 = (make-string i :initial-element #\Newline) + for s2 = (format nil "~v%" i) + unless (string= s1 s2) + collect i) nil) (deftest formatter.%.5 (let ((fn (formatter "~v%"))) (loop for i from 0 to 100 - for s1 = (make-string i :initial-element #\Newline) - for s2 = (formatter-call-to-string fn i) - unless (string= s1 s2) - collect i)) + for s1 = (make-string i :initial-element #\Newline) + for s2 = (formatter-call-to-string fn i) + unless (string= s1 s2) + collect i)) nil) (deftest format.%.6 (loop for i from 0 to (min (- call-arguments-limit 3) 100) - for args = (make-list i) - for s1 = (make-string i :initial-element #\Newline) - for s2 = (apply #'format nil "~#%" args) - unless (string= s1 s2) - collect i) + for args = (make-list i) + for s1 = (make-string i :initial-element #\Newline) + for s2 = (apply #'format nil "~#%" args) + unless (string= s1 s2) + collect i) nil) (deftest formatter.%.6 (let ((fn (formatter "~#%"))) (loop for i from 0 to (min (- call-arguments-limit 3) 100) - for args = (make-list i) - for s1 = (make-string i :initial-element #\Newline) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream args) args))) - unless (string= s1 s2) - collect i)) + for args = (make-list i) + for s1 = (make-string i :initial-element #\Newline) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream args) args))) + unless (string= s1 s2) + collect i)) nil) diff --git a/ansi-tests/format-r.lsp b/ansi-tests/format-r.lsp index 6273f6fe..81b6cff6 100644 --- a/ansi-tests/format-r.lsp +++ b/ansi-tests/format-r.lsp @@ -15,13 +15,13 @@ for s = (format nil "~~~dR" i) nconc (loop for x = (let ((bound (ash 1 (+ 2 (random 40))))) - (- (random (* bound 2)) bound)) - for s1 = (format nil s x) - for s2 = (with-standard-io-syntax - (write-to-string x :base i :readably nil)) - repeat 100 - unless (string= s1 s2) - collect (list i x s1 s2))) + (- (random (* bound 2)) bound)) + for s1 = (format nil s x) + for s2 = (with-standard-io-syntax + (write-to-string x :base i :readably nil)) + repeat 100 + unless (string= s1 s2) + collect (list i x s1 s2))) nil) (deftest formatter.r.1 @@ -31,13 +31,13 @@ for fn = (eval `(formatter ,s)) nconc (loop for x = (let ((bound (ash 1 (+ 2 (random 40))))) - (- (random (* bound 2)) bound)) - for s1 = (formatter-call-to-string fn x) - for s2 = (with-standard-io-syntax - (write-to-string x :base i :readably nil)) - repeat 100 - unless (string= s1 s2) - collect (list i x s1 s2))) + (- (random (* bound 2)) bound)) + for s1 = (formatter-call-to-string fn x) + for s2 = (with-standard-io-syntax + (write-to-string x :base i :readably nil)) + repeat 100 + unless (string= s1 s2) + collect (list i x s1 s2))) nil) (def-format-test format.r.2 @@ -48,87 +48,87 @@ (deftest format.r.4 (loop for base from 2 to 36 - nconc - (loop for mincol from 0 to 20 - for fmt = (format nil "~~~D,~DR" base mincol) - for s = (format nil fmt base) - unless (if (<= mincol 2) - (string= s "10") - (string= (concatenate - 'string - (make-string (- mincol 2) - :initial-element #\Space) - "10") - s)) - collect (list base mincol s))) + nconc + (loop for mincol from 0 to 20 + for fmt = (format nil "~~~D,~DR" base mincol) + for s = (format nil fmt base) + unless (if (<= mincol 2) + (string= s "10") + (string= (concatenate + 'string + (make-string (- mincol 2) + :initial-element #\Space) + "10") + s)) + collect (list base mincol s))) nil) (deftest formatter.r.4 (loop for base from 2 to 36 - nconc - (loop for mincol from 0 to 20 - for fmt = (format nil "~~~D,~DR" base mincol) - for fn = (eval `(formatter ,fmt)) - for s = (formatter-call-to-string fn base) - unless (if (<= mincol 2) - (string= s "10") - (string= (concatenate - 'string - (make-string (- mincol 2) - :initial-element #\Space) - "10") - s)) - collect (list base mincol s))) + nconc + (loop for mincol from 0 to 20 + for fmt = (format nil "~~~D,~DR" base mincol) + for fn = (eval `(formatter ,fmt)) + for s = (formatter-call-to-string fn base) + unless (if (<= mincol 2) + (string= s "10") + (string= (concatenate + 'string + (make-string (- mincol 2) + :initial-element #\Space) + "10") + s)) + collect (list base mincol s))) nil) (deftest format.r.5 (loop for base from 2 to 36 - nconc - (loop for mincol from 0 to 20 - for fmt = (format nil "~~~D,~D,'*r" base mincol) - for s = (format nil fmt base) - unless (if (<= mincol 2) - (string= s "10") - (string= (concatenate - 'string - (make-string (- mincol 2) - :initial-element #\*) - "10") - s)) - collect (list base mincol s))) + nconc + (loop for mincol from 0 to 20 + for fmt = (format nil "~~~D,~D,'*r" base mincol) + for s = (format nil fmt base) + unless (if (<= mincol 2) + (string= s "10") + (string= (concatenate + 'string + (make-string (- mincol 2) + :initial-element #\*) + "10") + s)) + collect (list base mincol s))) nil) (deftest formatter.r.5 (loop for base from 2 to 36 - nconc - (loop for mincol from 0 to 20 - for fmt = (format nil "~~~D,~D,'*r" base mincol) - for fn = (eval `(formatter ,fmt)) - for s = (formatter-call-to-string fn base) - unless (if (<= mincol 2) - (string= s "10") - (string= (concatenate - 'string - (make-string (- mincol 2) - :initial-element #\*) - "10") - s)) - collect (list base mincol s))) + nconc + (loop for mincol from 0 to 20 + for fmt = (format nil "~~~D,~D,'*r" base mincol) + for fn = (eval `(formatter ,fmt)) + for s = (formatter-call-to-string fn base) + unless (if (<= mincol 2) + (string= s "10") + (string= (concatenate + 'string + (make-string (- mincol 2) + :initial-element #\*) + "10") + s)) + collect (list base mincol s))) nil) (deftest format.r.6 (loop for base from 2 to 36 - for s = (format nil "~vr" base (1+ base)) - unless (string= s "11") - collect (list base s)) + for s = (format nil "~vr" base (1+ base)) + unless (string= s "11") + collect (list base s)) nil) (deftest formatter.r.6 (let ((fn (formatter "~vr"))) (loop for base from 2 to 36 - for s = (formatter-call-to-string fn base (1+ base)) - unless (string= s "11") - collect (list base s))) + for s = (formatter-call-to-string fn base (1+ base)) + unless (string= s "11") + collect (list base s))) nil) (defparameter *english-number-names* @@ -155,29 +155,29 @@ (deftest format.r.7 (loop for i from 0 to 100 - for s1 = (format nil "~r" i) - for s2 in *english-number-names* - unless (string= s1 s2) - collect (list i s1 s2)) + for s1 = (format nil "~r" i) + for s2 in *english-number-names* + unless (string= s1 s2) + collect (list i s1 s2)) nil) (deftest formatter.r.7 (let ((fn (formatter "~r"))) (loop for i from 0 to 100 - for s1 = (formatter-call-to-string fn i) - for s2 in *english-number-names* - unless (string= s1 s2) - collect (list i s1 s2))) + for s1 = (formatter-call-to-string fn i) + for s2 in *english-number-names* + unless (string= s1 s2) + collect (list i s1 s2))) nil) (deftest format.r.7a (loop for i from 1 to 100 - for s1 = (format nil "~r" (- i)) - for s2 in (cdr *english-number-names*) - for s3 = (concatenate 'string "negative " s2) - for s4 = (concatenate 'string "minus " s2) - unless (or (string= s1 s3) (string= s1 s4)) - collect (list i s1 s3 s4)) + for s1 = (format nil "~r" (- i)) + for s2 in (cdr *english-number-names*) + for s3 = (concatenate 'string "negative " s2) + for s4 = (concatenate 'string "minus " s2) + unless (or (string= s1 s3) (string= s1 s4)) + collect (list i s1 s3 s4)) nil) (def-format-test format.r.8 @@ -197,8 +197,8 @@ (with-standard-io-syntax (let ((*print-radix* t)) (values - (format nil fn 123) - (formatter-call-to-string fn 123))))) + (format nil fn 123) + (formatter-call-to-string fn 123))))) "123" "123") @@ -217,12 +217,12 @@ for s = (format nil "~~~d:R" i) nconc (loop for x = (let ((bound (ash 1 (+ 2 (random 40))))) - (- (random (* bound 2)) bound)) - for s1 = (remove #\, (format nil s x)) - for y = (let ((*read-base* i)) (read-from-string s1)) - repeat 100 - unless (= x y) - collect (list i x s1 y))) + (- (random (* bound 2)) bound)) + for s1 = (remove #\, (format nil s x)) + for y = (let ((*read-base* i)) (read-from-string s1)) + repeat 100 + unless (= x y) + collect (list i x s1 y))) nil) (deftest format.r.15 @@ -230,16 +230,16 @@ for i = (+ 2 (random 35)) for interval = (1+ (random 20)) for comma = (loop for c = (random-from-seq +standard-chars+) - unless (alphanumericp c) - return c) + unless (alphanumericp c) + return c) for s = (format nil "~~~d,,,'~c,~d:R" i comma interval) for x = (let ((bound (ash 1 (+ 2 (random 40))))) - (- (random (* bound 2)) bound)) + (- (random (* bound 2)) bound)) for s1 = (remove comma (format nil s x)) for y = (let ((*read-base* i)) (read-from-string s1)) repeat 1000 unless (or (and (eql comma #\-) (< x 0)) - (= x y)) + (= x y)) collect (list i interval comma x s1 y)) nil) @@ -273,46 +273,46 @@ (deftest format.r.18 (loop for i from 0 to 100 - for s1 = (format nil "~:r" i) - for s2 in *english-ordinal-names* - unless (string= s1 s2) - collect (list i s1 s2)) + for s1 = (format nil "~:r" i) + for s2 in *english-ordinal-names* + unless (string= s1 s2) + collect (list i s1 s2)) nil) (deftest formatter.r.18 (let ((fn (formatter "~:r"))) (loop for i from 0 to 100 - for s1 = (formatter-call-to-string fn i) - for s2 in *english-ordinal-names* - unless (string= s1 s2) - collect (list i s1 s2))) + for s1 = (formatter-call-to-string fn i) + for s2 in *english-ordinal-names* + unless (string= s1 s2) + collect (list i s1 s2))) nil) (deftest format.r.18a (loop for i from 1 to 100 - for s1 = (format nil "~:r" (- i)) - for s2 in (cdr *english-ordinal-names*) - for s3 = (concatenate 'string "negative " s2) - for s4 = (concatenate 'string "minus " s2) - unless (or (string= s1 s3) (string= s1 s4)) - collect (list i s1 s3 s4)) + for s1 = (format nil "~:r" (- i)) + for s2 in (cdr *english-ordinal-names*) + for s3 = (concatenate 'string "negative " s2) + for s4 = (concatenate 'string "minus " s2) + unless (or (string= s1 s3) (string= s1 s4)) + collect (list i s1 s3 s4)) nil) (deftest format.r.19 (loop for i from 1 - for s1 in *roman-numerals* - for s2 = (format nil "~@R" i) - unless (string= s1 s2) - collect (list i s1 s2)) + for s1 in *roman-numerals* + for s2 = (format nil "~@R" i) + unless (string= s1 s2) + collect (list i s1 s2)) nil) (deftest formatter.r.19 (let ((fn (formatter "~@r"))) (loop for i from 1 - for s1 in *roman-numerals* - for s2 = (formatter-call-to-string fn i) - unless (string= s1 s2) - collect (list i s1 s2))) + for s1 in *roman-numerals* + for s2 = (formatter-call-to-string fn i) + unless (string= s1 s2) + collect (list i s1 s2))) nil) ;;; Old roman numerals @@ -320,12 +320,12 @@ (defun old-roman-numeral (x) (assert (typep x '(integer 1))) (let ((n-m 0) - (n-d 0) - (n-c 0) - (n-l 0) - (n-x 0) - (n-v 0) - ) + (n-d 0) + (n-c 0) + (n-l 0) + (n-x 0) + (n-v 0) + ) (loop while (>= x 1000) do (incf n-m) (decf x 1000)) (when (>= x 500) (incf n-d) (decf x 500)) (loop while (>= x 100) do (incf n-c) (decf x 100)) @@ -333,37 +333,37 @@ (loop while (>= x 10) do (incf n-x) (decf x 10)) (when (>= x 5) (incf n-v) (decf x 5)) (concatenate 'string - (make-string n-m :initial-element #\M) - (make-string n-d :initial-element #\D) - (make-string n-c :initial-element #\C) - (make-string n-l :initial-element #\L) - (make-string n-x :initial-element #\X) - (make-string n-v :initial-element #\V) - (make-string x :initial-element #\I)))) + (make-string n-m :initial-element #\M) + (make-string n-d :initial-element #\D) + (make-string n-c :initial-element #\C) + (make-string n-l :initial-element #\L) + (make-string n-x :initial-element #\X) + (make-string n-v :initial-element #\V) + (make-string x :initial-element #\I)))) (deftest format.r.20 (loop for i from 1 to 4999 - for s1 = (format nil "~:@r" i) - for s2 = (old-roman-numeral i) - unless (string= s1 s2) - collect (list i s1 s2)) + for s1 = (format nil "~:@r" i) + for s2 = (old-roman-numeral i) + unless (string= s1 s2) + collect (list i s1 s2)) nil) (deftest formatter.r.20 (let ((fn (formatter "~@:R"))) (loop for i from 1 to 4999 - for s1 = (formatter-call-to-string fn i) - for s2 = (old-roman-numeral i) - unless (string= s1 s2) - collect (list i s1 s2))) + for s1 = (formatter-call-to-string fn i) + for s2 = (old-roman-numeral i) + unless (string= s1 s2) + collect (list i s1 s2))) nil) (deftest format.r.21 (loop for i from 1 to 4999 - for s1 = (format nil "~:@r" i) - for s2 = (format nil "~@:R" i) - unless (string= s1 s2) - collect (list i s1 s2)) + for s1 = (format nil "~:@r" i) + for s2 = (format nil "~@:R" i) + unless (string= s1 s2) + collect (list i s1 s2)) nil) ;; Combinations of mincol and comma chars @@ -381,17 +381,17 @@ (deftest format.r.25 (loop for i from 0 to 5 - for s = (format nil "~10,vr" i 12345) - unless (string= s "12345") - collect (list i s)) + for s = (format nil "~10,vr" i 12345) + unless (string= s "12345") + collect (list i s)) nil) (deftest formatter.r.25 (let ((fn (formatter "~10,vr"))) (loop for i from 0 to 5 - for s = (formatter-call-to-string fn i 12345) - unless (string= s "12345") - collect (list i s))) + for s = (formatter-call-to-string fn i 12345) + unless (string= s "12345") + collect (list i s))) nil) (def-format-test format.r.26 @@ -443,24 +443,24 @@ for radix = (+ 2 (random 35)) for mincol = (and (coin) (random 50)) for padchar = (and (coin) - (random-from-seq +standard-chars+)) + (random-from-seq +standard-chars+)) for commachar = (and (coin) - (random-from-seq +standard-chars+)) + (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate - 'string - (format nil "~~~d," radix) - (if mincol (format nil "~d," mincol) ",") - (if padchar (format nil "'~c," padchar) ",") - (if commachar (format nil "'~c," commachar) ",") - (if commaint (format nil "~dr" commaint) "r")) + 'string + (format nil "~~~d," radix) + (if mincol (format nil "~d," mincol) ",") + (if padchar (format nil "'~c," padchar) ",") + (if commachar (format nil "'~c," commachar) ",") + (if commaint (format nil "~dr" commaint) "r")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,v,vr" radix mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn radix mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) - (string= s1 s3)) + (string= s1 s3)) collect (list radix mincol padchar commachar commaint fmt x s1 s2 s3))) nil) diff --git a/ansi-tests/format-s.lsp b/ansi-tests/format-s.lsp index 1e1e9344..75956475 100644 --- a/ansi-tests/format-s.lsp +++ b/ansi-tests/format-s.lsp @@ -8,13 +8,13 @@ (deftest format.s.1 (let ((*print-readably* nil) - (*print-case* :upcase)) + (*print-case* :upcase)) (format nil "~s" nil)) "NIL") (deftest formatter.s.1 (let ((*print-readably* nil) - (*print-case* :upcase)) + (*print-case* :upcase)) (formatter-call-to-string (formatter "~s") nil)) "NIL") @@ -23,37 +23,37 @@ (deftest format.s.3 (let ((*print-readably* nil) - (*print-case* :upcase)) + (*print-case* :upcase)) (format nil "~:s" '(nil))) "(NIL)") (deftest formatter.s.3 (let ((*print-readably* nil) - (*print-case* :upcase)) + (*print-case* :upcase)) (formatter-call-to-string (formatter "~:s") '(nil))) "(NIL)") (deftest format.s.4 (let ((*print-readably* nil) - (*print-case* :downcase)) + (*print-case* :downcase)) (format nil "~s" 'nil)) "nil") (deftest formatter.s.4 (let ((*print-readably* nil) - (*print-case* :downcase)) + (*print-case* :downcase)) (formatter-call-to-string (formatter "~s") 'nil)) "nil") (deftest format.s.5 (let ((*print-readably* nil) - (*print-case* :capitalize)) + (*print-case* :capitalize)) (format nil "~s" 'nil)) "Nil") (deftest formatter.s.5 (let ((*print-readably* nil) - (*print-case* :capitalize)) + (*print-case* :capitalize)) (formatter-call-to-string (formatter "~s") 'nil)) "Nil") @@ -65,11 +65,11 @@ (with-standard-io-syntax (let ((*print-readably* nil)) (loop for c across +standard-chars+ - for s = (format nil "~S" c) - for s2 = (formatter-call-to-string fn c) - for c2 = (read-from-string s) - unless (and (eql c c2) (string= s s2)) - collect (list c s c2 s2))))) + for s = (format nil "~S" c) + for s2 = (formatter-call-to-string fn c) + for c2 = (read-from-string s) + unless (and (eql c c2) (string= s s2)) + collect (list c s c2 s2))))) nil) (deftest format.s.8 @@ -77,18 +77,18 @@ (with-standard-io-syntax (let ((*print-readably* nil)) (loop with count = 0 - for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s1 = (and c (format nil "#\\~:c" c)) - for s2 = (and c (format nil "~S" c)) - for s3 = (formatter-call-to-string fn c) - unless (or (null c) - (graphic-char-p c) - (and (string= s1 s2) (string= s2 s3))) - do (incf count) and collect (list c s1 s2) - when (> count 100) - collect "count limit exceeded" - and do (loop-finish))))) + for i from 0 below (min #x10000 char-code-limit) + for c = (code-char i) + for s1 = (and c (format nil "#\\~:c" c)) + for s2 = (and c (format nil "~S" c)) + for s3 = (formatter-call-to-string fn c) + unless (or (null c) + (graphic-char-p c) + (and (string= s1 s2) (string= s2 s3))) + do (incf count) and collect (list c s1 s2) + when (> count 100) + collect "count limit exceeded" + and do (loop-finish))))) nil) (deftest format.s.9 @@ -97,12 +97,12 @@ (apply #'values (loop for i from 1 to 10 - for fmt = (format nil "~~~d@s" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s)))) + for fmt = (format nil "~~~d@s" i) + for s = (format nil fmt nil) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn nil) + do (assert (string= s s2)) + collect s)))) "NIL" "NIL" "NIL" @@ -120,12 +120,12 @@ (apply #'values (loop for i from 1 to 10 - for fmt = (format nil "~~~dS" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s)))) + for fmt = (format nil "~~~dS" i) + for s = (format nil fmt nil) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn nil) + do (assert (string= s s2)) + collect s)))) "NIL" "NIL" "NIL" @@ -143,12 +143,12 @@ (apply #'values (loop for i from 1 to 10 - for fmt = (format nil "~~~d@:S" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s)))) + for fmt = (format nil "~~~d@:S" i) + for s = (format nil fmt nil) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn nil) + do (assert (string= s s2)) + collect s)))) "()" "()" " ()" @@ -166,12 +166,12 @@ (apply #'values (loop for i from 1 to 10 - for fmt = (format nil "~~~d:s" i) - for s = (format nil fmt nil) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn nil) - do (assert (string= s s2)) - collect s)))) + for fmt = (format nil "~~~d:s" i) + for s = (format nil fmt nil) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn nil) + do (assert (string= s s2)) + collect s)))) "()" "()" "() " @@ -186,14 +186,14 @@ (deftest format.s.13 (with-standard-io-syntax (let ((*print-readably* nil) - (fn (formatter "~V:s"))) + (fn (formatter "~V:s"))) (apply #'values (loop for i from 1 to 10 - for s = (format nil "~v:S" i nil) - for s2 = (formatter-call-to-string fn i nil) - do (assert (string= s s2)) - collect s)))) + for s = (format nil "~v:S" i nil) + for s2 = (formatter-call-to-string fn i nil) + do (assert (string= s s2)) + collect s)))) "()" "()" "() " @@ -208,14 +208,14 @@ (deftest format.s.14 (with-standard-io-syntax (let ((*print-readably* nil) - (fn (formatter "~V@:s"))) + (fn (formatter "~V@:s"))) (apply #'values (loop for i from 1 to 10 - for s = (format nil "~v:@s" i nil) - for s2 = (formatter-call-to-string fn i nil) - do (assert (string= s s2)) - collect s)))) + for s = (format nil "~v:@s" i nil) + for s2 = (formatter-call-to-string fn i nil) + do (assert (string= s s2)) + collect s)))) "()" "()" " ()" @@ -276,13 +276,13 @@ (deftest format.s.29 (with-standard-io-syntax (let ((*print-readably* nil) - (*package* (find-package :cl-test)) - (fn (formatter "~V,,2s"))) + (*package* (find-package :cl-test)) + (fn (formatter "~V,,2s"))) (loop for i from -4 to 10 - for s = (format nil "~v,,2S" i 'ABC) - for s2 = (formatter-call-to-string fn i 'ABC) - do (assert (string= s s2)) - collect s))) + for s = (format nil "~v,,2S" i 'ABC) + for s2 = (formatter-call-to-string fn i 'ABC) + do (assert (string= s s2)) + collect s))) ("ABC " "ABC " "ABC " @@ -348,13 +348,13 @@ (deftest format.s.44 (with-standard-io-syntax (let ((*print-readably* nil) - (*package* (find-package :cl-test)) - (fn (formatter "~3,,vs"))) + (*package* (find-package :cl-test)) + (fn (formatter "~3,,vs"))) (loop for i from 0 to 6 - for s = (format nil "~3,,vS" i 'ABC) - for s2 = (formatter-call-to-string fn i 'ABC) - do (assert (string= s s2)) - collect s))) + for s = (format nil "~3,,vS" i 'ABC) + for s2 = (formatter-call-to-string fn i 'ABC) + do (assert (string= s s2)) + collect s))) ("ABC" "ABC " "ABC " @@ -366,13 +366,13 @@ (deftest format.s.44a (with-standard-io-syntax (let ((*print-readably* nil) - (*package* (find-package :cl-test)) - (fn (formatter "~3,,V@S"))) + (*package* (find-package :cl-test)) + (fn (formatter "~3,,V@S"))) (loop for i from 0 to 6 - for s = (format nil "~3,,v@S" i 'ABC) - for s2 = (formatter-call-to-string fn i 'ABC) - do (assert (string= s s2)) - collect s))) + for s = (format nil "~3,,v@S" i 'ABC) + for s2 = (formatter-call-to-string fn i 'ABC) + do (assert (string= s s2)) + collect s))) ("ABC" " ABC" " ABC" diff --git a/ansi-tests/format-slash.lsp b/ansi-tests/format-slash.lsp index 8af0f3d4..aa6e9739 100644 --- a/ansi-tests/format-slash.lsp +++ b/ansi-tests/format-slash.lsp @@ -92,14 +92,14 @@ (def-pprint-test format./.19 (progn (setf (symbol-function 'function-for-format-slash-19) - #'(lambda (stream &rest args) - (assert (= (length args) (length *expected-args*))) - (assert (equal (car args) (car *expected-args*))) - (assert (if (cadr args) (cadr *expected-args*) - (not (cadr *expected-args*)))) - (assert (if (caddr args) (caddr *expected-args*) - (not (caddr *expected-args*)))) - (apply #'pprint-fill stream (subseq args 0 3)))) + #'(lambda (stream &rest args) + (assert (= (length args) (length *expected-args*))) + (assert (equal (car args) (car *expected-args*))) + (assert (if (cadr args) (cadr *expected-args*) + (not (cadr *expected-args*)))) + (assert (if (caddr args) (caddr *expected-args*) + (not (caddr *expected-args*)))) + (apply #'pprint-fill stream (subseq args 0 3)))) (list (let ((*expected-args* '(1 nil nil))) (format nil "~/cl-test::function-for-format-slash-19/" 1)) diff --git a/ansi-tests/format-t.lsp b/ansi-tests/format-t.lsp index 3be57dda..0446e17c 100644 --- a/ansi-tests/format-t.lsp +++ b/ansi-tests/format-t.lsp @@ -21,72 +21,72 @@ (def-pprint-test format.t.4 (loop for i from 0 to 20 - for s = (format nil "~0,vT" i) - unless (string= s (make-string i :initial-element #\Space)) - collect (list i s)) + for s = (format nil "~0,vT" i) + unless (string= s (make-string i :initial-element #\Space)) + collect (list i s)) nil) (def-pprint-test format.t.5 (loop for i from 0 to 20 - for s = (format nil "~v,0T" i) - unless (string= s (make-string i :initial-element #\Space)) - collect (list i s)) + for s = (format nil "~v,0T" i) + unless (string= s (make-string i :initial-element #\Space)) + collect (list i s)) nil) (def-pprint-test format.t.6 (loop for n1 = (random 30) - for s1 = (make-string n1 :initial-element #\X) - for n2 = (random 30) - for inc = (random 20) - for s2 = (cond - ((< n1 n2) - (concatenate 'string s1 (make-string (- n2 n1) - :initial-element #\Space))) - ((= inc 0) s1) - (t (loop do (incf n2 inc) while (<= n2 n1)) - (concatenate 'string s1 (make-string (- n2 n1) - :initial-element #\Space)))) - for pretty = (coin) - for result = (let ((*print-pretty* pretty)) - (format nil (format nil "~A~~~D,~DT" s1 n2 inc))) - repeat 100 - unless (string= s2 result) - collect (list n1 n2 inc pretty s2 result)) + for s1 = (make-string n1 :initial-element #\X) + for n2 = (random 30) + for inc = (random 20) + for s2 = (cond + ((< n1 n2) + (concatenate 'string s1 (make-string (- n2 n1) + :initial-element #\Space))) + ((= inc 0) s1) + (t (loop do (incf n2 inc) while (<= n2 n1)) + (concatenate 'string s1 (make-string (- n2 n1) + :initial-element #\Space)))) + for pretty = (coin) + for result = (let ((*print-pretty* pretty)) + (format nil (format nil "~A~~~D,~DT" s1 n2 inc))) + repeat 100 + unless (string= s2 result) + collect (list n1 n2 inc pretty s2 result)) nil) (def-pprint-test format.t.7 (loop for n1 = (random 30) - for s1 = (make-string n1 :initial-element #\X) - for n2 = (random 30) - for inc = (random 20) - for s2 = (cond - ((< n1 n2) - (concatenate 'string s1 (make-string (- n2 n1) - :initial-element #\Space))) - ((= inc 0) s1) - (t (loop do (incf n2 inc) while (<= n2 n1)) - (concatenate 'string s1 (make-string (- n2 n1) - :initial-element #\Space)))) - for pretty = (coin) - for result = (let ((*print-pretty* pretty)) - (format nil "~A~v,vt" s1 n2 inc)) - repeat 100 - unless (string= s2 result) - collect (list n1 n2 inc pretty s2 result)) + for s1 = (make-string n1 :initial-element #\X) + for n2 = (random 30) + for inc = (random 20) + for s2 = (cond + ((< n1 n2) + (concatenate 'string s1 (make-string (- n2 n1) + :initial-element #\Space))) + ((= inc 0) s1) + (t (loop do (incf n2 inc) while (<= n2 n1)) + (concatenate 'string s1 (make-string (- n2 n1) + :initial-element #\Space)))) + for pretty = (coin) + for result = (let ((*print-pretty* pretty)) + (format nil "~A~v,vt" s1 n2 inc)) + repeat 100 + unless (string= s2 result) + collect (list n1 n2 inc pretty s2 result)) nil) (def-pprint-test format.t.8 (loop for i from 1 to 20 - for s = (format nil " ~v,vT" nil i) - unless (string= s (make-string (1+ i) :initial-element #\Space)) - collect (list i s)) + for s = (format nil " ~v,vT" nil i) + unless (string= s (make-string (1+ i) :initial-element #\Space)) + collect (list i s)) nil) (def-pprint-test format.t.9 (loop for i from 1 to 20 - for s = (format nil "~v,vT" i nil) - unless (string= s (make-string i :initial-element #\Space)) - collect (list i s)) + for s = (format nil "~v,vT" i nil) + unless (string= s (make-string i :initial-element #\Space)) + collect (list i s)) nil) (def-pprint-test format.t.10 @@ -101,45 +101,45 @@ (def-pprint-test format.@t.2 (loop for colnum from 0 to 20 - for s1 = (format nil "~v,1@t" colnum) - for s2 = (make-string colnum :initial-element #\Space) - unless (string= s1 s2) - collect (list colnum s1 s2)) + for s1 = (format nil "~v,1@t" colnum) + for s2 = (make-string colnum :initial-element #\Space) + unless (string= s1 s2) + collect (list colnum s1 s2)) nil) (def-pprint-test format.@t.3 (loop for colnum = (random 50) - for colinc = (1+ (random 20)) - for s1 = (format nil "~v,v@t" colnum colinc) - for s2 = (make-string (* colinc (ceiling colnum colinc)) - :initial-element #\Space) - repeat 100 - unless (string= s1 s2) - collect (list colnum colinc s1 s2)) + for colinc = (1+ (random 20)) + for s1 = (format nil "~v,v@t" colnum colinc) + for s2 = (make-string (* colinc (ceiling colnum colinc)) + :initial-element #\Space) + repeat 100 + unless (string= s1 s2) + collect (list colnum colinc s1 s2)) nil) (def-pprint-test format.@t.4 (loop for colnum = (random 50) - for colinc = (1+ (random 20)) - for s1 = (format nil "~v,1@T~0,v@t" colnum colinc) - for s2 = (make-string (* colinc (ceiling colnum colinc)) - :initial-element #\Space) - repeat 100 - unless (string= s1 s2) - collect (list colnum colinc s1 s2)) + for colinc = (1+ (random 20)) + for s1 = (format nil "~v,1@T~0,v@t" colnum colinc) + for s2 = (make-string (* colinc (ceiling colnum colinc)) + :initial-element #\Space) + repeat 100 + unless (string= s1 s2) + collect (list colnum colinc s1 s2)) nil) (def-pprint-test format.@t.5 (loop for colnum = (random 50) - for colinc = (1+ (random 20)) - for pretty = (coin) - for s1 = (let ((*pretty* pretty)) - (format nil (format nil "~~~d,~d@t" colnum colinc))) - for s2 = (make-string (* colinc (ceiling colnum colinc)) - :initial-element #\Space) - repeat 100 - unless (string= s1 s2) - collect (list colnum colinc pretty s1 s2)) + for colinc = (1+ (random 20)) + for pretty = (coin) + for s1 = (let ((*pretty* pretty)) + (format nil (format nil "~~~d,~d@t" colnum colinc))) + for s2 = (make-string (* colinc (ceiling colnum colinc)) + :initial-element #\Space) + repeat 100 + unless (string= s1 s2) + collect (list colnum colinc pretty s1 s2)) nil) ;;; Pretty printing (colon modifier) @@ -198,16 +198,16 @@ (def-pprint-test format.\:t.7 (loop for i from 0 to 20 - for s = (format nil "~<X~;~0,v:T~;Y~:>" (list i)) - unless (string= s (concatenate 'string "X" (make-string i :initial-element #\Space) "Y")) - collect (list i s)) + for s = (format nil "~<X~;~0,v:T~;Y~:>" (list i)) + unless (string= s (concatenate 'string "X" (make-string i :initial-element #\Space) "Y")) + collect (list i s)) nil) (def-pprint-test format.\:t.8 (loop for i from 0 to 20 - for s = (format nil "~<ABC~;~v,0:T~;DEF~:>" (list i)) - unless (string= s (concatenate 'string "ABC" (make-string i :initial-element #\Space) "DEF")) - collect (list i s)) + for s = (format nil "~<ABC~;~v,0:T~;DEF~:>" (list i)) + unless (string= s (concatenate 'string "ABC" (make-string i :initial-element #\Space) "DEF")) + collect (list i s)) nil) (def-pprint-test format.\:t.9 @@ -219,13 +219,13 @@ for n2 = (random 30) for inc = (random 20) for s2 = (cond - ((< n1 n2) - (concatenate 'string s0 s1 (make-string (- n2 n1) - :initial-element #\Space))) - ((= inc 0) (concatenate 'string s0 s1)) - (t (loop do (incf n2 inc) while (<= n2 n1)) - (concatenate 'string s0 s1 (make-string (- n2 n1) - :initial-element #\Space)))) + ((< n1 n2) + (concatenate 'string s0 s1 (make-string (- n2 n1) + :initial-element #\Space))) + ((= inc 0) (concatenate 'string s0 s1)) + (t (loop do (incf n2 inc) while (<= n2 n1)) + (concatenate 'string s0 s1 (make-string (- n2 n1) + :initial-element #\Space)))) for result = (format nil (format nil "~A~~<~A~~~D,~D:T~~:>" s0 s1 n2 inc) '(a)) repeat 100 unless (string= s2 result) @@ -242,23 +242,23 @@ (def-pprint-test format.\:t.12 (loop for n0 = (random 20) - for s0 = (make-string n0 :initial-element #\Space) - for n1 = (random 30) - for s1 = (make-string n1 :initial-element #\X) - for n2 = (random 30) - for inc = (random 20) - for s2 = (cond - ((< n1 n2) - (concatenate 'string s0 s1 (make-string (- n2 n1) - :initial-element #\Space))) - ((= inc 0) (concatenate 'string s0 s1)) - (t (loop do (incf n2 inc) while (<= n2 n1)) - (concatenate 'string s0 s1 (make-string (- n2 n1) - :initial-element #\Space)))) - for result = (format nil "~A~<~A~v,v:t~:>" s0 (list s1 n2 inc)) - repeat 100 - unless (string= s2 result) - collect (list n1 n2 inc s2 result)) + for s0 = (make-string n0 :initial-element #\Space) + for n1 = (random 30) + for s1 = (make-string n1 :initial-element #\X) + for n2 = (random 30) + for inc = (random 20) + for s2 = (cond + ((< n1 n2) + (concatenate 'string s0 s1 (make-string (- n2 n1) + :initial-element #\Space))) + ((= inc 0) (concatenate 'string s0 s1)) + (t (loop do (incf n2 inc) while (<= n2 n1)) + (concatenate 'string s0 s1 (make-string (- n2 n1) + :initial-element #\Space)))) + for result = (format nil "~A~<~A~v,v:t~:>" s0 (list s1 n2 inc)) + repeat 100 + unless (string= s2 result) + collect (list n1 n2 inc s2 result)) nil) ;;; see 22.3.5.2 @@ -299,24 +299,24 @@ (def-pprint-test format.\:@t.2 (loop for colnum from 0 to 20 - for s1 = (format nil "~<XXXX~;~v,1:@t~:>" (list colnum)) - for s2 = (concatenate 'string "XXXX" (make-string colnum :initial-element #\Space)) - unless (string= s1 s2) - collect (list colnum s1 s2)) + for s1 = (format nil "~<XXXX~;~v,1:@t~:>" (list colnum)) + for s2 = (concatenate 'string "XXXX" (make-string colnum :initial-element #\Space)) + unless (string= s1 s2) + collect (list colnum s1 s2)) nil) (def-pprint-test format.\:@t.3 (loop for s0 = (make-string (random 20) :initial-element #\M) - for colnum = (random 50) - for colinc = (1+ (random 20)) - for s1 = (format nil "~A~<~v,v:@t~:>" s0 (list colnum colinc)) - for s2 = (concatenate 'string - s0 - (make-string (* colinc (ceiling colnum colinc)) - :initial-element #\Space)) - repeat 100 - unless (string= s1 s2) - collect (list colnum colinc s1 s2)) + for colnum = (random 50) + for colinc = (1+ (random 20)) + for s1 = (format nil "~A~<~v,v:@t~:>" s0 (list colnum colinc)) + for s2 = (concatenate 'string + s0 + (make-string (* colinc (ceiling colnum colinc)) + :initial-element #\Space)) + repeat 100 + unless (string= s1 s2) + collect (list colnum colinc s1 s2)) nil) ;;; Turned off if not pretty printing diff --git a/ansi-tests/format-tilde.lsp b/ansi-tests/format-tilde.lsp index 4c7c5982..470c2ccf 100644 --- a/ansi-tests/format-tilde.lsp +++ b/ansi-tests/format-tilde.lsp @@ -11,21 +11,21 @@ (deftest format.~.2 (loop for i from 0 to 100 - for s = (make-string i :initial-element #\~) - for format-string = (format nil "~~~D~~" i) - for s2 = (format nil format-string) - unless (string= s s2) - collect (list i s s2)) + for s = (make-string i :initial-element #\~) + for format-string = (format nil "~~~D~~" i) + for s2 = (format nil format-string) + unless (string= s s2) + collect (list i s s2)) nil) (deftest formatter.~.2 (loop for i from 0 to 100 - for s = (make-string i :initial-element #\~) - for format-string = (format nil "~~~D~~" i) - for fn = (eval `(formatter ,format-string)) - for s2 = (formatter-call-to-string fn) - unless (string= s s2) - collect (list i s s2)) + for s = (make-string i :initial-element #\~) + for format-string = (format nil "~~~D~~" i) + for fn = (eval `(formatter ,format-string)) + for s2 = (formatter-call-to-string fn) + unless (string= s s2) + collect (list i s s2)) nil) (def-format-test format.~.3 @@ -33,38 +33,38 @@ (deftest format.~.4 (loop for i from 0 to 100 - for s = (make-string i :initial-element #\~) - for s2 = (format nil "~V~" i) - unless (string= s s2) - collect (list i s s2)) + for s = (make-string i :initial-element #\~) + for s2 = (format nil "~V~" i) + unless (string= s s2) + collect (list i s s2)) nil) (deftest formatter.~.4 (let ((fn (formatter "~v~"))) (loop for i from 0 to 100 - for s = (make-string i :initial-element #\~) - for s2 = (formatter-call-to-string fn i) - unless (string= s s2) - collect (list i s s2))) + for s = (make-string i :initial-element #\~) + for s2 = (formatter-call-to-string fn i) + unless (string= s s2) + collect (list i s s2))) nil) (deftest format.~.5 (loop for i from 0 to (min (- call-arguments-limit 3) 100) - for s = (make-string i :initial-element #\~) - for args = (make-list i) - for s2 = (apply #'format nil "~#~" args) - unless (string= s s2) - collect (list i s s2)) + for s = (make-string i :initial-element #\~) + for args = (make-list i) + for s2 = (apply #'format nil "~#~" args) + unless (string= s s2) + collect (list i s s2)) nil) (deftest formatter.~.5 (let ((fn (formatter "~#~"))) (loop for i from 0 to (min (- call-arguments-limit 3) 100) - for s = (make-string i :initial-element #\~) - for args = (make-list i) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream args) args))) - unless (string= s s2) - collect (list i s s2))) + for s = (make-string i :initial-element #\~) + for args = (make-list i) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream args) args))) + unless (string= s s2) + collect (list i s s2))) nil) diff --git a/ansi-tests/format-underscore.lsp b/ansi-tests/format-underscore.lsp index 21ef4df4..a6c6e8e6 100644 --- a/ansi-tests/format-underscore.lsp +++ b/ansi-tests/format-underscore.lsp @@ -73,10 +73,10 @@ A (def-ppblock-test format._.8 (progn (pprint-logical-block (*standard-output* nil) - (format t "A ~_A ~_A ~_A ~_")) + (format t "A ~_A ~_A ~_A ~_")) (format t "~_") (pprint-logical-block (*standard-output* nil) - (format t "A ~_A ~_A ~_A ~_"))) + (format t "A ~_A ~_A ~_A ~_"))) "A A A A A A A A " :margin 10) @@ -86,20 +86,20 @@ A A A A " (s) (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* nil)) + (*print-escape* nil) + (*print-pretty* t) + (*print-right-margin* 4) + (*print-miser-width* nil)) (format s "A ~_A ~_A ~_A ~_A ~_")))) "A A A A A ") (deftest formatter._.9 (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* nil)) + (*print-escape* nil) + (*print-pretty* t) + (*print-right-margin* 4) + (*print-miser-width* nil)) (formatter-call-to-string (formatter "A ~_A ~_A ~_A ~_A ~_")))) "A A A A A ") @@ -189,20 +189,20 @@ A A A A " (s) (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* 4)) + (*print-escape* nil) + (*print-pretty* t) + (*print-right-margin* 4) + (*print-miser-width* 4)) (format s "A ~@_A ~@_A ~@_A ~@_A ~@_")))) "A A A A A ") (deftest formatter.@_.10 (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* 4)) + (*print-escape* nil) + (*print-pretty* t) + (*print-right-margin* 4) + (*print-miser-width* 4)) (formatter-call-to-string (formatter "A ~@_A ~@_A ~@_A ~@_A ~@_")))) "A A A A A ") @@ -256,11 +256,11 @@ A (def-ppblock-test format.\:_.6 (format t "~W~W~:_~W~W~:_~W~W~:_~W~W~:_~W~W~:_" - '(A B) #\Space - '(A B) #\Space - '(A B) #\Space - '(A B) #\Space - '(A B) #\Space) + '(A B) #\Space + '(A B) #\Space + '(A B) #\Space + '(A B) #\Space + '(A B) #\Space) "(A B) (A B) (A B) (A B) (A B) " @@ -271,20 +271,20 @@ A (s) (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-right-margin* 4) - (*print-pretty* t) - (*print-miser-width* nil)) + (*print-escape* nil) + (*print-right-margin* 4) + (*print-pretty* t) + (*print-miser-width* nil)) (format s "A ~:_A ~:_A ~:_A ~:_A ~:_")))) "A A A A A ") (deftest formatter.\:_.7 (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-right-margin* 4) - (*print-pretty* t) - (*print-miser-width* nil)) + (*print-escape* nil) + (*print-right-margin* 4) + (*print-pretty* t) + (*print-miser-width* nil)) (formatter-call-to-string (formatter "A ~:_A ~:_A ~:_A ~:_A ~:_")))) "A A A A A ") @@ -324,19 +324,19 @@ A " (s) (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* nil)) + (*print-escape* nil) + (*print-pretty* t) + (*print-right-margin* 4) + (*print-miser-width* nil)) (format s "A ~:@_A ~:@_A ~:@_A ~:@_A ~:@_")))) "A A A A A ") (deftest formatter.\:@_.5 (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* nil)) + (*print-escape* nil) + (*print-pretty* t) + (*print-right-margin* 4) + (*print-miser-width* nil)) (formatter-call-to-string (formatter "A ~:@_A ~:@_A ~:@_A ~:@_A ~:@_")))) "A A A A A ") diff --git a/ansi-tests/format-x.lsp b/ansi-tests/format-x.lsp index 2002b2ee..7c73b3bd 100644 --- a/ansi-tests/format-x.lsp +++ b/ansi-tests/format-x.lsp @@ -11,197 +11,197 @@ (let ((fn (formatter "~x"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~X" i) - for s2 = (formatter-call-to-string fn i) - for j = (let ((*read-base* 16)) (read-from-string s1)) - repeat 1000 - when (or (/= i j) - (not (string= s1 s2)) - (find #\. s1) - (find #\+ s1) - (loop for c across s1 - thereis (and (not (eql c #\-)) - (not (digit-char-p c 16))))) - collect (list i s1 j s2)))) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~X" i) + for s2 = (formatter-call-to-string fn i) + for j = (let ((*read-base* 16)) (read-from-string s1)) + repeat 1000 + when (or (/= i j) + (not (string= s1 s2)) + (find #\. s1) + (find #\+ s1) + (loop for c across s1 + thereis (and (not (eql c #\-)) + (not (digit-char-p c 16))))) + collect (list i s1 j s2)))) nil) (deftest format.x.2 (let ((fn (formatter "~@X"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@x" i) - for s2 = (formatter-call-to-string fn i) - for j = (let ((*read-base* 16)) (read-from-string s1)) - repeat 1000 - when (or (/= i j) - (not (string= s1 s2)) - (find #\. s1) - ;; (find #\+ s1) - (loop for c across s1 - thereis (and - (not (find c "-+")) - (not (digit-char-p c 16))))) - collect (list i s1 j s2)))) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@x" i) + for s2 = (formatter-call-to-string fn i) + for j = (let ((*read-base* 16)) (read-from-string s1)) + repeat 1000 + when (or (/= i j) + (not (string= s1 s2)) + (find #\. s1) + ;; (find #\+ s1) + (loop for c across s1 + thereis (and + (not (find c "-+")) + (not (digit-char-p c 16))))) + collect (list i s1 j s2)))) nil) (deftest format.x.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~x" i) - for fmt = (format nil "~~~d~c" mincol (random-from-seq "xX")) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~x" i) + for fmt = (format nil "~~~d~c" mincol (random-from-seq "xX")) + for s2 = (format nil fmt i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest formatter.x.3 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~x" i) - for fmt = (format nil "~~~d~c" mincol (random-from-seq "xX")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~x" i) + for fmt = (format nil "~~~d~c" mincol (random-from-seq "xX")) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn i) + for pos = (search s1 s2) + repeat 100 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest format.x.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@X" i) - for fmt = (format nil "~~~d@~c" mincol (random-from-seq "xX")) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@X" i) + for fmt = (format nil "~~~d@~c" mincol (random-from-seq "xX")) + for s2 = (format nil fmt i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (and (>= i 0) (not (eql (elt s1 0) #\+))) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest formatter.x.4 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@X" i) - for fmt = (format nil "~~~d@~c" mincol (random-from-seq "xX")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (not (eql (position #\Space s2 :test-not #'eql) - (- (length s2) (length s1))))))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@X" i) + for fmt = (format nil "~~~d@~c" mincol (random-from-seq "xX")) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn i) + for pos = (search s1 s2) + repeat 100 + when (or (null pos) + (and (>= i 0) (not (eql (elt s1 0) #\+))) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (not (eql (position #\Space s2 :test-not #'eql) + (- (length s2) (length s1))))))) + collect (list i mincol s1 s2 pos))) nil) (deftest format.x.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~x" i) - for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "xX")) - for s2 = (format nil fmt i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~x" i) + for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "xX")) + for s2 = (format nil fmt i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 pos))) nil) (deftest formatter.x.5 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~x" i) - for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "xX")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - for pos = (search s1 s2) - repeat 100 - when (or (null pos) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 pos))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~x" i) + for fmt = (format nil "~~~d,'~c~c" mincol padchar (random-from-seq "xX")) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn i) + for pos = (search s1 s2) + repeat 100 + when (or (null pos) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 pos))) nil) (deftest format.x.6 (let ((fn (formatter "~V,vx"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~x" i) - for s2 = (format nil "~v,vX" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~x" i) + for s2 = (format nil "~v,vX" mincol padchar i) + for s3 = (formatter-call-to-string fn mincol padchar i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (not (string= s2 s3)) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 s3 pos)))) nil) (deftest format.x.7 (let ((fn (formatter "~v,V@X"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for mincol = (random 30) - for padchar = (random-from-seq +standard-chars+) - for i = (- (random (+ x x)) x) - for s1 = (format nil "~@x" i) - for s2 = (format nil "~v,v@x" mincol padchar i) - for s3 = (formatter-call-to-string fn mincol padchar i) - for pos = (search s1 s2) - repeat 1000 - when (or (null pos) - (not (string= s2 s3)) - (and (>= i 0) (not (eql (elt s1 0) #\+))) - (and (> mincol (length s1)) - (or (/= (length s2) mincol) - (find padchar s2 :end (- (length s2) (length s1)) - :test-not #'eql)))) - collect (list i mincol s1 s2 s3 pos)))) + for mincol = (random 30) + for padchar = (random-from-seq +standard-chars+) + for i = (- (random (+ x x)) x) + for s1 = (format nil "~@x" i) + for s2 = (format nil "~v,v@x" mincol padchar i) + for s3 = (formatter-call-to-string fn mincol padchar i) + for pos = (search s1 s2) + repeat 1000 + when (or (null pos) + (not (string= s2 s3)) + (and (>= i 0) (not (eql (elt s1 0) #\+))) + (and (> mincol (length s1)) + (or (/= (length s2) mincol) + (find padchar s2 :end (- (length s2) (length s1)) + :test-not #'eql)))) + collect (list i mincol s1 s2 s3 pos)))) nil) ;;; Comma tests @@ -209,153 +209,153 @@ (deftest format.x.8 (let ((fn (formatter "~:X"))) (loop for i from -999 to 999 - for s1 = (format nil "~x" i) - for s2 = (format nil "~:x" i) - for s3 = (formatter-call-to-string fn i) - unless (and (string= s1 s2) (string= s2 s3)) - collect (list i s1 s2 s3))) + for s1 = (format nil "~x" i) + for s2 = (format nil "~:x" i) + for s3 = (formatter-call-to-string fn i) + unless (and (string= s1 s2) (string= s2 s3)) + collect (list i s1 s2 s3))) nil) (deftest format.x.9 (let ((fn (formatter "~:x"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = #\, - for s1 = (format nil "~x" i) - for s2 = (format nil "~:X" i) - for s3 = (formatter-call-to-string fn i) - repeat 1000 - unless (and (string= s1 (remove commachar s2)) - (string= s2 s3) - (not (eql (elt s2 0) commachar)) - (or (>= i 0) (not (eql (elt s2 1) commachar))) - (let ((len (length s2)) - (ci+1 4)) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (find (elt s2 i) "0123456789ABCDEF" :test #'char-equal))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = #\, + for s1 = (format nil "~x" i) + for s2 = (format nil "~:X" i) + for s3 = (formatter-call-to-string fn i) + repeat 1000 + unless (and (string= s1 (remove commachar s2)) + (string= s2 s3) + (not (eql (elt s2 0) commachar)) + (or (>= i 0) (not (eql (elt s2 1) commachar))) + (let ((len (length s2)) + (ci+1 4)) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (find (elt s2 i) "0123456789ABCDEF" :test #'char-equal))))) + collect (list x i commachar s1 s2 s3)))) nil) (deftest format.x.10 (let ((fn (formatter "~,,V:x"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~x" i) - for s2 = (format nil "~,,v:X" commachar i) - for s3 = (formatter-call-to-string fn commachar i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (string= s2 s3) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for s1 = (format nil "~x" i) + for s2 = (format nil "~,,v:X" commachar i) + for s3 = (formatter-call-to-string fn commachar i) + repeat 1000 + unless (and + (eql (elt s1 0) (elt s2 0)) + (string= s2 s3) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 4) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2 s3)))) nil) (deftest format.x.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~x" i) - for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "xX")) - for s2 = (format nil fmt i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for s1 = (format nil "~x" i) + for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "xX")) + for s2 = (format nil fmt i) + repeat 1000 + unless (and + (eql (elt s1 0) (elt s2 0)) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 4) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2))) nil) (deftest formatter.x.11 (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for s1 = (format nil "~x" i) - for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "xX")) - for fn = (eval `(formatter ,fmt)) - for s2 = (formatter-call-to-string fn i) - repeat 100 - unless (and - (eql (elt s1 0) (elt s2 0)) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 4) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for s1 = (format nil "~x" i) + for fmt = (format nil "~~,,'~c:~c" commachar (random-from-seq "xX")) + for fn = (eval `(formatter ,fmt)) + for s2 = (formatter-call-to-string fn i) + repeat 100 + unless (and + (eql (elt s1 0) (elt s2 0)) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 4) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2))) nil) (deftest format.x.12 (let ((fn (formatter "~,,v,v:X"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~x" i) - for s2 = (format nil "~,,v,v:X" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (string= s2 s3) - (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j (if (< i 0) 1 0))) - (loop for i from (if (< i 0) 2 1) below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for commaint = (1+ (random 20)) + for s1 = (format nil "~x" i) + for s2 = (format nil "~,,v,v:X" commachar commaint i) + for s3 = (formatter-call-to-string fn commachar commaint i) + repeat 1000 + unless (and + (eql (elt s1 0) (elt s2 0)) + (string= s2 s3) + (if (< i 0) (eql (elt s1 1) (elt s2 1)) t) + (let ((len (length s2)) + (ci+1 (1+ commaint)) + (j (if (< i 0) 1 0))) + (loop for i from (if (< i 0) 2 1) below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2 s3)))) nil) (deftest format.x.13 (let ((fn (formatter "~,,v,V:@x"))) (with-standard-io-syntax (loop for x = (ash 1 (+ 2 (random 80))) - for i = (- (random (+ x x)) x) - for commachar = (random-from-seq +standard-chars+) - for commaint = (1+ (random 20)) - for s1 = (format nil "~@x" i) - for s2 = (format nil "~,,v,v:@x" commachar commaint i) - for s3 = (formatter-call-to-string fn commachar commaint i) - repeat 1000 - unless (and - (eql (elt s1 0) (elt s2 0)) - (eql (elt s1 1) (elt s2 1)) - (string= s2 s3) - (let ((len (length s2)) - (ci+1 (1+ commaint)) - (j 1)) - (loop for i from 2 below len - always (if (= (mod (- len i) ci+1) 0) - (eql (elt s2 i) commachar) - (eql (elt s1 (incf j)) (elt s2 i)))))) - collect (list x i commachar s1 s2 s3)))) + for i = (- (random (+ x x)) x) + for commachar = (random-from-seq +standard-chars+) + for commaint = (1+ (random 20)) + for s1 = (format nil "~@x" i) + for s2 = (format nil "~,,v,v:@x" commachar commaint i) + for s3 = (formatter-call-to-string fn commachar commaint i) + repeat 1000 + unless (and + (eql (elt s1 0) (elt s2 0)) + (eql (elt s1 1) (elt s2 1)) + (string= s2 s3) + (let ((len (length s2)) + (ci+1 (1+ commaint)) + (j 1)) + (loop for i from 2 below len + always (if (= (mod (- len i) ci+1) 0) + (eql (elt s2 i) commachar) + (eql (elt s1 (incf j)) (elt s2 i)))))) + collect (list x i commachar s1 s2 s3)))) nil) ;;; NIL arguments @@ -377,44 +377,44 @@ (deftest format.x.18 (let ((fn (formatter "~x"))) (loop for x in *mini-universe* - for s1 = (format nil "~x" x) - for s2 = (let ((*print-base* 16)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) + for s1 = (format nil "~x" x) + for s2 = (let ((*print-base* 16)) (format nil "~A" x)) + for s3 = (formatter-call-to-string fn x) + unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) + collect (list x s1 s2 s3))) nil) (deftest format.x.19 (let ((fn (formatter "~:x"))) (loop for x in *mini-universe* - for s1 = (format nil "~:x" x) - for s2 = (let ((*print-base* 16)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) + for s1 = (format nil "~:x" x) + for s2 = (let ((*print-base* 16)) (format nil "~A" x)) + for s3 = (formatter-call-to-string fn x) + unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) + collect (list x s1 s2 s3))) nil) (deftest format.x.20 (let ((fn (formatter "~@x"))) (loop for x in *mini-universe* - for s1 = (format nil "~@x" x) - for s2 = (let ((*print-base* 16)) (format nil "~A" x)) - for s3 = (formatter-call-to-string fn x) - unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) + for s1 = (format nil "~@x" x) + for s2 = (let ((*print-base* 16)) (format nil "~A" x)) + for s3 = (formatter-call-to-string fn x) + unless (or (integerp x) (and (string= s1 s2) (string= s2 s3))) + collect (list x s1 s2 s3))) nil) (deftest format.x.21 (let ((fn (formatter "~:@x"))) (loop for x in *mini-universe* - for s1 = (let ((*print-base* 16)) (format nil "~A" x)) - for s2 = (format nil "~@:x" x) - for s3 = (formatter-call-to-string fn x) - for s4 = (let ((*print-base* 16)) (format nil "~A" x)) - unless (or (string/= s1 s4) - (integerp x) - (and (string= s1 s2) (string= s2 s3))) - collect (list x s1 s2 s3))) + for s1 = (let ((*print-base* 16)) (format nil "~A" x)) + for s2 = (format nil "~@:x" x) + for s3 = (formatter-call-to-string fn x) + for s4 = (let ((*print-base* 16)) (format nil "~A" x)) + unless (or (string/= s1 s4) + (integerp x) + (and (string= s1 s2) (string= s2 s3))) + collect (list x s1 s2 s3))) nil) ;;; Must add tests for non-integers when the parameters @@ -428,15 +428,15 @@ (apply #'values (let ((fn (formatter "~#X")) - (n #x1b3fe)) + (n #x1b3fe)) (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~#x" n args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream n args) args))) - do (assert (string= s s2)) - collect (string-upcase s)))) + for args = (make-list i) + for s = (apply #'format nil "~#x" n args) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream n args) args))) + do (assert (string= s s2)) + collect (string-upcase s)))) "1B3FE" "1B3FE" "1B3FE" @@ -453,15 +453,15 @@ (apply #'values (let ((fn (formatter "~,,,#:X")) - (n #x1234567890)) + (n #x1234567890)) (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#:x" n args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream n args) args))) - do (assert (string= s s2)) - collect s))) + for args = (make-list i) + for s = (apply #'format nil "~,,,#:x" n args) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream n args) args))) + do (assert (string= s s2)) + collect s))) "1,2,3,4,5,6,7,8,9,0" "12,34,56,78,90" "1,234,567,890" @@ -478,15 +478,15 @@ (apply #'values (let ((fn (formatter "~,,,#@:X")) - (n #x1234567890)) + (n #x1234567890)) (loop for i from 0 to 10 - for args = (make-list i) - for s = (apply #'format nil "~,,,#@:X" n args) - for s2 = (with-output-to-string - (stream) - (assert (equal (apply fn stream n args) args))) - do (assert (string= s s2)) - collect s))) + for args = (make-list i) + for s = (apply #'format nil "~,,,#@:X" n args) + for s2 = (with-output-to-string + (stream) + (assert (equal (apply fn stream n args) args))) + do (assert (string= s s2)) + collect s))) "+1,2,3,4,5,6,7,8,9,0" "+12,34,56,78,90" "+1,234,567,890" @@ -521,22 +521,22 @@ (loop for mincol = (and (coin) (random 50)) for padchar = (and (coin) - (random-from-seq +standard-chars+)) + (random-from-seq +standard-chars+)) for commachar = (and (coin) - (random-from-seq +standard-chars+)) + (random-from-seq +standard-chars+)) for commaint = (and (coin) (1+ (random 10))) for k = (ash 1 (+ 2 (random 30))) for x = (- (random (+ k k)) k) for fmt = (concatenate - 'string - (if mincol (format nil "~~~d," mincol) "~,") - (if padchar (format nil "'~c," padchar) ",") - (if commachar (format nil "'~c," commachar) ",") - (if commaint (format nil "~dx" commaint) "x")) + 'string + (if mincol (format nil "~~~d," mincol) "~,") + (if padchar (format nil "'~c," padchar) ",") + (if commachar (format nil "'~c," commachar) ",") + (if commaint (format nil "~dx" commaint) "x")) for s1 = (format nil fmt x) for s2 = (format nil "~v,v,v,vx" mincol padchar commachar commaint x) for s3 = (formatter-call-to-string fn mincol padchar commachar commaint x) repeat 2000 unless (and (string= s1 s2) (string= s2 s3)) collect (list mincol padchar commachar commaint fmt x s1 s2 s3))) - nil) \ No newline at end of file + nil) diff --git a/ansi-tests/formatter-c.lsp b/ansi-tests/formatter-c.lsp index 228a3b57..7de05b17 100644 --- a/ansi-tests/formatter-c.lsp +++ b/ansi-tests/formatter-c.lsp @@ -13,13 +13,13 @@ for c across +standard-chars+ when (let* (n - (ignored (loop for i below (random 5) collect i)) - (s (with-output-to-string (stream) - (setq n (multiple-value-list - (apply fn stream c ignored)))))) + (ignored (loop for i below (random 5) collect i)) + (s (with-output-to-string (stream) + (setq n (multiple-value-list + (apply fn stream c ignored)))))) (unless (and (string= s (string c)) - (equal n (list ignored))) - (list s ignored n))) + (equal n (list ignored))) + (list s ignored n))) collect it)) nil) @@ -32,16 +32,16 @@ for ignored = (loop for j below (random 10) collect j) when (and c - (eql (char-code c) (char-int c)) - (let* (n - (s (with-output-to-string - (stream) - (setq n (multiple-value-list - (apply fn stream c ignored)))))) - (unless (and (string= s (string c)) - (equal n (list ignored))) - (incf count) - (list i c s ignored n)))) + (eql (char-code c) (char-int c)) + (let* (n + (s (with-output-to-string + (stream) + (setq n (multiple-value-list + (apply fn stream c ignored)))))) + (unless (and (string= s (string c)) + (equal n (list ignored))) + (incf count) + (list i c s ignored n)))) collect it when (> count 100) collect "count limit exceeded" and do (loop-finish))) nil) @@ -52,15 +52,15 @@ for c across +standard-chars+ when (and (graphic-char-p c) - (not (eql c #\Space)) - (let* (n - (ignored (loop for i below (random 5) collect i)) - (s (with-output-to-string (stream) - (setq n (multiple-value-list - (apply fn stream c ignored)))))) - (unless (and (string= s (string c)) - (equal n (list ignored))) - (list s ignored n)))) + (not (eql c #\Space)) + (let* (n + (ignored (loop for i below (random 5) collect i)) + (s (with-output-to-string (stream) + (setq n (multiple-value-list + (apply fn stream c ignored)))))) + (unless (and (string= s (string c)) + (equal n (list ignored))) + (list s ignored n)))) collect it)) nil) @@ -73,72 +73,72 @@ for ignored = (loop for j below (random 10) collect j) when (and c - (eql (char-code c) (char-int c)) - (graphic-char-p c) - (not (eql c #\Space)) - (let* (n - (s (with-output-to-string - (stream) - (setq n (multiple-value-list - (apply fn stream c ignored)))))) - (unless (and (string= s (string c)) - (equal n (list ignored))) - (incf count) - (list i c s ignored n)))) + (eql (char-code c) (char-int c)) + (graphic-char-p c) + (not (eql c #\Space)) + (let* (n + (s (with-output-to-string + (stream) + (setq n (multiple-value-list + (apply fn stream c ignored)))))) + (unless (and (string= s (string c)) + (equal n (list ignored))) + (incf count) + (list i c s ignored n)))) collect it when (> count 100) collect "count limit exceeded" and do (loop-finish))) nil) (deftest formatter.c.4 (let ((fn (formatter "~:C")) - (n nil)) + (n nil)) (loop for c across +standard-chars+ - for s = (with-output-to-string - (stream) - (setq n (multiple-value-list (funcall fn stream c)))) - unless (or (graphic-char-p c) - (and (string= s (char-name c)) - (equal n '(nil)))) - collect (list c (char-name c) s))) + for s = (with-output-to-string + (stream) + (setq n (multiple-value-list (funcall fn stream c)))) + unless (or (graphic-char-p c) + (and (string= s (char-name c)) + (equal n '(nil)))) + collect (list c (char-name c) s))) nil) (deftest formatter.c.4a (let ((fn (formatter "~:C")) - (n nil)) + (n nil)) (loop for i from 0 below (min #x10000 char-code-limit) - for c = (code-char i) - for s = (and c - (with-output-to-string - (stream) - (setq n (multiple-value-list (funcall fn stream c 5))))) - unless (or (not c) - (graphic-char-p c) - (and (string= s (char-name c)) - (equal n '((5))))) - collect (list c (char-name c) s))) + for c = (code-char i) + for s = (and c + (with-output-to-string + (stream) + (setq n (multiple-value-list (funcall fn stream c 5))))) + unless (or (not c) + (graphic-char-p c) + (and (string= s (char-name c)) + (equal n '((5))))) + collect (list c (char-name c) s))) nil) (deftest formatter.c.5 (let ((fn (formatter "~@C")) - (n nil)) + (n nil)) (loop for c across +standard-chars+ - for s = (with-output-to-string - (stream) - (setq n (multiple-value-list (funcall fn stream c 1 2 3)))) - for c2 = (read-from-string s) - unless (and (eql c c2) - (equal n '((1 2 3)))) - collect (list c s c2))) + for s = (with-output-to-string + (stream) + (setq n (multiple-value-list (funcall fn stream c 1 2 3)))) + for c2 = (read-from-string s) + unless (and (eql c c2) + (equal n '((1 2 3)))) + collect (list c s c2))) nil) (deftest formatter.c.6 (let ((n nil) - (fn (formatter "~@:c"))) + (fn (formatter "~@:c"))) (loop for c across +standard-chars+ - for s1 = (with-output-to-string - (stream) - (setf n (multiple-value-list (funcall fn stream c 1 2)))) - for s2 = (format nil "~:@C" c) - unless (and (eql (search s1 s2) 0) (equal n '((1 2)))) - collect (list c s1 s2 n))) + for s1 = (with-output-to-string + (stream) + (setf n (multiple-value-list (funcall fn stream c 1 2)))) + for s2 = (format nil "~:@C" c) + unless (and (eql (search s1 s2) 0) (equal n '((1 2)))) + collect (list c s1 s2 n))) nil) diff --git a/ansi-tests/fresh-line.lsp b/ansi-tests/fresh-line.lsp index 41542e03..74954111 100644 --- a/ansi-tests/fresh-line.lsp +++ b/ansi-tests/fresh-line.lsp @@ -52,12 +52,12 @@ (s) (write-char #\Space s) (setq result - (list - (multiple-value-list (notnot-mv (fresh-line s))) - (multiple-value-list (fresh-line s)) - (multiple-value-list (fresh-line s))))) + (list + (multiple-value-list (notnot-mv (fresh-line s))) + (multiple-value-list (fresh-line s)) + (multiple-value-list (fresh-line s))))) result)) - " + " " ((t) (nil) (nil))) (deftest fresh-line.6 diff --git a/ansi-tests/fround-aux.lsp b/ansi-tests/fround-aux.lsp index 20e4caf6..c21f093c 100644 --- a/ansi-tests/fround-aux.lsp +++ b/ansi-tests/fround-aux.lsp @@ -7,19 +7,19 @@ (defun fround.1-fn () (loop for n = (- (random 200000) - 100000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (fround n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 100 - unless (and (eql (length vals) 2) - (floatp q) - (= n n2) - (integerp r) - (<= (- (/ d 2)) r (/ d 2)) - (or (/= (abs r) (/ d 2)) - (evenp (floor q)))) - collect (list n d q r n2))) + 100000) + for d = (1+ (random 10000)) + for vals = (multiple-value-list (fround n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 100 + unless (and (eql (length vals) 2) + (floatp q) + (= n n2) + (integerp r) + (<= (- (/ d 2)) r (/ d 2)) + (or (/= (abs r) (/ d 2)) + (evenp (floor q)))) + collect (list n d q r n2))) diff --git a/ansi-tests/fround.lsp b/ansi-tests/fround.lsp index ce6a0bb2..bdf2cd63 100644 --- a/ansi-tests/fround.lsp +++ b/ansi-tests/fround.lsp @@ -26,124 +26,124 @@ (deftest fround.10 (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (fround x x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float 1 x)) - (= q 1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) + for (q r) = (multiple-value-list (fround x x)) + unless (and (floatp q) + (if (floatp x) + (eql q (float 1 x)) + (= q 1)) + (zerop r) + (if (floatp x) + (eql r (float 0 x)) + (= r 0))) + collect x) nil) (deftest fround.11 (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) - for (q r) = (multiple-value-list (fround (- x) x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float -1 x)) - (= q -1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) + for (q r) = (multiple-value-list (fround (- x) x)) + unless (and (floatp q) + (if (floatp x) + (eql q (float -1 x)) + (= q -1)) + (zerop r) + (if (floatp x) + (eql r (float 0 x)) + (= r 0))) + collect x) nil) (deftest fround.12 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 0.5s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 0.5s0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'short-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (fround x)) + unless (and (eql q (coerce i 'short-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest fround.13 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 0.5s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 0.5s0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'short-float)) - (eql r (- rrad))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (fround x)) + unless (and (eql q (coerce i 'short-float)) + (eql r (- rrad))) + collect (list i x q r))) nil) (deftest fround.14 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 0.5f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 0.5f0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'single-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (fround x)) + unless (and (eql q (coerce i 'single-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest fround.15 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 0.5f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 0.5f0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'single-float)) - (eql r (- rrad))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (fround x)) + unless (and (eql q (coerce i 'single-float)) + (eql r (- rrad))) + collect (list i x q r))) nil) (deftest fround.16 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 0.5d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 0.5d0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'double-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (fround x)) + unless (and (eql q (coerce i 'double-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest fround.17 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 0.5d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 0.5d0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'double-float)) - (eql r (- rrad))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (fround x)) + unless (and (eql q (coerce i 'double-float)) + (eql r (- rrad))) + collect (list i x q r))) nil) (deftest fround.18 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 0.5l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 0.5l0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'long-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (fround x)) + unless (and (eql q (coerce i 'long-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest fround.19 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 0.5l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 0.5l0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (fround x)) - unless (and (eql q (coerce i 'long-float)) - (eql r (- rrad))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (fround x)) + unless (and (eql q (coerce i 'long-float)) + (eql r (- rrad))) + collect (list i x q r))) nil) diff --git a/ansi-tests/ftruncate-aux.lsp b/ansi-tests/ftruncate-aux.lsp index 157fe7e0..4cb56398 100644 --- a/ansi-tests/ftruncate-aux.lsp +++ b/ansi-tests/ftruncate-aux.lsp @@ -7,17 +7,17 @@ (defun ftruncate.1-fn () (loop for n = (- (random 200000) - 100000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (ftruncate n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 100 - unless (and (eql (length vals) 2) - (floatp q) - (= n n2) - (integerp r) - (if (>= n 0) - (< -1 r d) - (< -1 (- r) d))) - collect (list n d q r n2))) + 100000) + for d = (1+ (random 10000)) + for vals = (multiple-value-list (ftruncate n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 100 + unless (and (eql (length vals) 2) + (floatp q) + (= n n2) + (integerp r) + (if (>= n 0) + (< -1 r d) + (< -1 (- r) d))) + collect (list n d q r n2))) diff --git a/ansi-tests/ftruncate.lsp b/ansi-tests/ftruncate.lsp index e2c647c0..07430943 100644 --- a/ansi-tests/ftruncate.lsp +++ b/ansi-tests/ftruncate.lsp @@ -26,126 +26,126 @@ (deftest ftruncate.10 (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (ftruncate x x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float 1 x)) - (= q 1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) + for (q r) = (multiple-value-list (ftruncate x x)) + unless (and (floatp q) + (if (floatp x) + (eql q (float 1 x)) + (= q 1)) + (zerop r) + (if (floatp x) + (eql r (float 0 x)) + (= r 0))) + collect x) nil) (deftest ftruncate.11 (loop for x in (remove-if-not #'floatp (remove-if #'zerop *reals*)) - for (q r) = (multiple-value-list (ftruncate (- x) x)) - unless (and (floatp q) - (if (floatp x) - (eql q (float -1 x)) - (= q -1)) - (zerop r) - (if (floatp x) - (eql r (float 0 x)) - (= r 0))) - collect x) + for (q r) = (multiple-value-list (ftruncate (- x) x)) + unless (and (floatp q) + (if (floatp x) + (eql q (float -1 x)) + (= q -1)) + (zerop r) + (if (floatp x) + (eql r (float 0 x)) + (= r 0))) + collect x) nil) (deftest ftruncate.12 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce i 'short-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (ftruncate x)) + unless (and (eql q (coerce i 'short-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ftruncate.13 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce (1- i) 'short-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (ftruncate x)) + unless (and (eql q (coerce (1- i) 'short-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ftruncate.14 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce i 'single-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (ftruncate x)) + unless (and (eql q (coerce i 'single-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ftruncate.15 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce (1- i) 'single-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (ftruncate x)) + unless (and (eql q (coerce (1- i) 'single-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ftruncate.16 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce i 'double-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (ftruncate x)) + unless (and (eql q (coerce i 'double-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ftruncate.17 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce (1- i) 'double-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (ftruncate x)) + unless (and (eql q (coerce (1- i) 'double-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ftruncate.18 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce i 'long-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (ftruncate x)) + unless (and (eql q (coerce i 'long-float)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest ftruncate.19 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (ftruncate x)) - unless (and (eql q (coerce (1- i) 'long-float)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (ftruncate x)) + unless (and (eql q (coerce (1- i) 'long-float)) + (eql r rrad)) + collect (list i x q r))) nil) ;;; To add: tests that involve adding/subtracting EPSILON constants diff --git a/ansi-tests/funcall.lsp b/ansi-tests/funcall.lsp index 5e0a3b80..c253b447 100644 --- a/ansi-tests/funcall.lsp +++ b/ansi-tests/funcall.lsp @@ -37,7 +37,7 @@ (deftest funcall.7 (flet ((xcons (x y) (list y x))) (values (funcall 'xcons 1 2) - (funcall #'xcons 1 2))) + (funcall #'xcons 1 2))) (1 . 2) (2 1)) @@ -55,7 +55,7 @@ (let ((i 0) a b) (values (funcall (progn (setf a (incf i)) #'car) - (progn (setf b (incf i)) '(x . y))) + (progn (setf b (incf i)) '(x . y))) i a b)) x 2 1 2) @@ -63,8 +63,8 @@ (let ((i 0) a b c) (values (funcall (progn (setf a (incf i)) #'cons) - (progn (setf b (incf i)) 'x) - (progn (setf c (incf i)) 'y)) + (progn (setf b (incf i)) 'x) + (progn (setf c (incf i)) 'y)) i a b c)) (x . y) 3 1 2 3) @@ -84,8 +84,8 @@ ;;; called on a symbol with a global definition as a macro (deftest funcall.error.3 (signals-error (funcall 'defconstant '(defconstant x 10)) - undefined-function - :name defconstant) + undefined-function + :name defconstant) t) (deftest funcall.error.4 diff --git a/ansi-tests/function-lambda-expression.lsp b/ansi-tests/function-lambda-expression.lsp index fd242923..137d1343 100644 --- a/ansi-tests/function-lambda-expression.lsp +++ b/ansi-tests/function-lambda-expression.lsp @@ -15,10 +15,10 @@ (let ((x nil)) (flet ((%f () x)) (let ((ret-vals - (multiple-value-list - (function-lambda-expression #'%f)))) - (values (length ret-vals) - (notnot (second ret-vals)))))) + (multiple-value-list + (function-lambda-expression #'%f)))) + (values (length ret-vals) + (notnot (second ret-vals)))))) 3 t) ;;; Verify that it doesn't barf on generic functions diff --git a/ansi-tests/function.lsp b/ansi-tests/function.lsp index 0d1e01e4..6d70881c 100644 --- a/ansi-tests/function.lsp +++ b/ansi-tests/function.lsp @@ -26,15 +26,15 @@ (deftest function.4 (loop for x in *cl-symbol-names* - for s = (find-symbol x "CL") - for f = (and (fboundp s) - (symbol-function s) - (not (special-operator-p s)) - (not (macro-function s)) - (symbol-function s)) - unless (or (null f) - (typep f 'function)) - collect x) + for s = (find-symbol x "CL") + for f = (and (fboundp s) + (symbol-function s) + (not (special-operator-p s)) + (not (macro-function s)) + (symbol-function s)) + unless (or (null f) + (typep f 'function)) + collect x) nil) (deftest function.5 @@ -66,8 +66,8 @@ ;;; In ANSI CL, symbols and cons can no longer also be of type FUNCTION. (deftest function.10 (check-predicate (typef '(not (and (or number character symbol - cons array) - function)))) + cons array) + function)))) nil) (deftest function.11 @@ -112,7 +112,7 @@ (values (%f 'a) (locally (declare (ftype (function (integer) t) %f)) - (%f 10)) + (%f 10)) (%f 'b))) nil nil nil) @@ -153,7 +153,7 @@ (flet ((%f (&key foo) foo)) (declare (ftype (function (&key (:foo t) (:allow-other-keys t)) t) %f)) (values (%f) (%f :foo 'a) (%f :allow-other-keys nil) - (%f :allow-other-keys t :foo 'z))) + (%f :allow-other-keys t :foo 'z))) nil a nil z) (deftest function.21 diff --git a/ansi-tests/functionp.lsp b/ansi-tests/functionp.lsp index 7b3b355a..81d14408 100644 --- a/ansi-tests/functionp.lsp +++ b/ansi-tests/functionp.lsp @@ -26,15 +26,15 @@ (deftest functionp.4 (loop for x in *cl-symbol-names* - for s = (find-symbol x "CL") - for f = (and (fboundp s) - (symbol-function s) - (not (special-operator-p s)) - (not (macro-function s)) - (symbol-function s)) - unless (or (null f) - (functionp f)) - collect x) + for s = (find-symbol x "CL") + for f = (and (fboundp s) + (symbol-function s) + (not (special-operator-p s)) + (not (macro-function s)) + (symbol-function s)) + unless (or (null f) + (functionp f)) + collect x) nil) (deftest functionp.5 @@ -64,10 +64,10 @@ ;;; In ANSI CL, symbols and cons can no longer be functions (deftest functionp.10 (check-predicate #'(lambda (x) - (not (and (or (numberp x) (characterp x) - (symbolp x) (consp x) - (typep x 'array)) - (functionp x))))) + (not (and (or (numberp x) (characterp x) + (symbolp x) (consp x) + (typep x 'array)) + (functionp x))))) nil) (deftest functionp.11 diff --git a/ansi-tests/gcd-aux.lsp b/ansi-tests/gcd-aux.lsp index 1d9d71e4..7e974214 100644 --- a/ansi-tests/gcd-aux.lsp +++ b/ansi-tests/gcd-aux.lsp @@ -21,7 +21,7 @@ (loop (when (zerop x) (return y)) (psetq x (mod y x) - y x))) + y x))) (defun my-lcm (x y) (when (< x 0) (setf x (- x))) @@ -31,4 +31,4 @@ (/ (* x y) (my-gcd x y)))) - + diff --git a/ansi-tests/gcd.lsp b/ansi-tests/gcd.lsp index 409b07c0..88a06a3a 100644 --- a/ansi-tests/gcd.lsp +++ b/ansi-tests/gcd.lsp @@ -22,68 +22,68 @@ (deftest gcd.2 (loop for i = (random-fixnum) - for a = (abs i) - repeat 10000 - unless (and (eql a (gcd i)) - (eql a (gcd 0 i))) - collect i) + for a = (abs i) + repeat 10000 + unless (and (eql a (gcd i)) + (eql a (gcd 0 i))) + collect i) nil) (deftest gcd.3 (loop for i = (random-from-interval 10000000000000000) - for a = (abs i) - repeat 10000 - unless (and (eql a (gcd i)) - (eql a (gcd i 0))) - collect i) + for a = (abs i) + repeat 10000 + unless (and (eql a (gcd i)) + (eql a (gcd i 0))) + collect i) nil) (deftest gcd.4 (loop for i = (random-fixnum) - for j = (random-fixnum) - repeat 1000 - unless (eql (my-gcd i j) (gcd i j)) - collect (list i j)) + for j = (random-fixnum) + repeat 1000 + unless (eql (my-gcd i j) (gcd i j)) + collect (list i j)) nil) (deftest gcd.5 (let ((bound (ash 1 200))) (loop for i = (random-from-interval bound) - for j = (random-from-interval bound) - repeat 1000 - unless (eql (my-gcd i j) (gcd i j)) - collect (list i j))) + for j = (random-from-interval bound) + repeat 1000 + unless (eql (my-gcd i j) (gcd i j)) + collect (list i j))) nil) (deftest gcd.6 (loop for i = (random-fixnum) - for j = (random-fixnum) - for k = (random-fixnum) - repeat 1000 - unless (eql (my-gcd i (my-gcd j k)) (gcd i j k)) - collect (list i j k)) + for j = (random-fixnum) + for k = (random-fixnum) + repeat 1000 + unless (eql (my-gcd i (my-gcd j k)) (gcd i j k)) + collect (list i j k)) nil) (deftest gcd.7 (loop for i = (random-fixnum) - for j = (random-fixnum) - for k = (random-fixnum) - for n = (random-fixnum) - repeat 1000 - unless (eql (my-gcd (my-gcd i j) (my-gcd k n)) (gcd i j k n)) - collect (list i j k)) + for j = (random-fixnum) + for k = (random-fixnum) + for n = (random-fixnum) + repeat 1000 + unless (eql (my-gcd (my-gcd i j) (my-gcd k n)) (gcd i j k n)) + collect (list i j k)) nil) (deftest gcd.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) - always (eql (apply #'gcd (make-list i :initial-element 1)) 1)) + always (eql (apply #'gcd (make-list i :initial-element 1)) 1)) t) (deftest gcd.order.1 (let ((i 0) x y) (values (gcd (progn (setf x (incf i)) 15) - (progn (setf y (incf i)) 25)) + (progn (setf y (incf i)) 25)) i x y)) 5 2 1 2) @@ -91,7 +91,7 @@ (let ((i 0) x y) (values (gcd (progn (setf x (incf i)) 0) - (progn (setf y (incf i)) 10)) + (progn (setf y (incf i)) 10)) i x y)) 10 2 1 2) @@ -102,4 +102,4 @@ i)) 0 1) - \ No newline at end of file + diff --git a/ansi-tests/gensym.lsp b/ansi-tests/gensym.lsp index 9ab82fb8..d3b0f998 100644 --- a/ansi-tests/gensym.lsp +++ b/ansi-tests/gensym.lsp @@ -13,7 +13,7 @@ ;;; Gensym returns symbols with distinct print names (deftest gensym.2 (string= (symbol-name (gensym)) - (symbol-name (gensym))) + (symbol-name (gensym))) nil) ;;; Gensym uses the *gensym-counter* special variable, diff --git a/ansi-tests/gentemp.lsp b/ansi-tests/gentemp.lsp index d288c0a8..5f8176fb 100644 --- a/ansi-tests/gentemp.lsp +++ b/ansi-tests/gentemp.lsp @@ -8,71 +8,71 @@ (deftest gentemp.1 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect - (let* ((pkg (make-package package-name :use nil)) - (gcounter *gensym-counter*) - (sym (let ((*package* pkg)) (gentemp))) - (sym-name (symbol-name sym))) - (values - (=t gcounter *gensym-counter*) ;; wasn't changed - (eqlt (aref sym-name 0) #\T) - (notnot (every #'digit-char-p (subseq sym-name 1))) - (eql (symbol-package sym) pkg) - ;; Not external - (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) - )) + (let* ((pkg (make-package package-name :use nil)) + (gcounter *gensym-counter*) + (sym (let ((*package* pkg)) (gentemp))) + (sym-name (symbol-name sym))) + (values + (=t gcounter *gensym-counter*) ;; wasn't changed + (eqlt (aref sym-name 0) #\T) + (notnot (every #'digit-char-p (subseq sym-name 1))) + (eql (symbol-package sym) pkg) + ;; Not external + (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) + )) (delete-package package-name))) t t t t t) (deftest gentemp.2 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect - (let* ((pkg (make-package package-name :use nil)) - (gcounter *gensym-counter*) - (sym (let ((*package* pkg)) (gentemp "X"))) - (sym-name (symbol-name sym))) - (values - (=t gcounter *gensym-counter*) ;; wasn't changed - (eqlt (aref sym-name 0) #\X) - (notnot (every #'digit-char-p (subseq sym-name 1))) - (eql (symbol-package sym) pkg) - ;; Not external - (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) - )) + (let* ((pkg (make-package package-name :use nil)) + (gcounter *gensym-counter*) + (sym (let ((*package* pkg)) (gentemp "X"))) + (sym-name (symbol-name sym))) + (values + (=t gcounter *gensym-counter*) ;; wasn't changed + (eqlt (aref sym-name 0) #\X) + (notnot (every #'digit-char-p (subseq sym-name 1))) + (eql (symbol-package sym) pkg) + ;; Not external + (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) + )) (delete-package package-name))) t t t t t) (deftest gentemp.3 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect - (let* ((pkg (make-package package-name :use nil)) - (gcounter *gensym-counter*) - (sym (gentemp "X" package-name)) - (sym-name (symbol-name sym))) - (values - (=t gcounter *gensym-counter*) ;; wasn't changed - (eqlt (aref sym-name 0) #\X) - (notnot (every #'digit-char-p (subseq sym-name 1))) - (eql (symbol-package sym) pkg) - ;; Not external - (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) - )) + (let* ((pkg (make-package package-name :use nil)) + (gcounter *gensym-counter*) + (sym (gentemp "X" package-name)) + (sym-name (symbol-name sym))) + (values + (=t gcounter *gensym-counter*) ;; wasn't changed + (eqlt (aref sym-name 0) #\X) + (notnot (every #'digit-char-p (subseq sym-name 1))) + (eql (symbol-package sym) pkg) + ;; Not external + (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) + )) (delete-package package-name))) t t t t t) (deftest gentemp.4 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect - (let* ((pkg (make-package package-name :use nil)) - (gcounter *gensym-counter*) - (sym (gentemp "" (make-symbol package-name))) - (sym-name (symbol-name sym))) - (values - (=t gcounter *gensym-counter*) ;; wasn't changed - (notnot (every #'digit-char-p sym-name)) - (eql (symbol-package sym) pkg) - ;; Not external - (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) - )) + (let* ((pkg (make-package package-name :use nil)) + (gcounter *gensym-counter*) + (sym (gentemp "" (make-symbol package-name))) + (sym-name (symbol-name sym))) + (values + (=t gcounter *gensym-counter*) ;; wasn't changed + (notnot (every #'digit-char-p sym-name)) + (eql (symbol-package sym) pkg) + ;; Not external + (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) + )) (delete-package package-name))) t t t t) @@ -80,27 +80,27 @@ (let* ((package-name "Z")) (safely-delete-package package-name) (unwind-protect - (let* ((pkg (make-package package-name :use nil)) - (gcounter *gensym-counter*) - (sym (gentemp "Y" #\Z)) - (sym-name (symbol-name sym))) - (values - (=t gcounter *gensym-counter*) ;; wasn't changed - (eqlt (aref sym-name 0) #\Y) - (notnot (every #'digit-char-p (subseq sym-name 1))) - (eql (symbol-package sym) pkg) - ;; Not external - (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) - )) + (let* ((pkg (make-package package-name :use nil)) + (gcounter *gensym-counter*) + (sym (gentemp "Y" #\Z)) + (sym-name (symbol-name sym))) + (values + (=t gcounter *gensym-counter*) ;; wasn't changed + (eqlt (aref sym-name 0) #\Y) + (notnot (every #'digit-char-p (subseq sym-name 1))) + (eql (symbol-package sym) pkg) + ;; Not external + (do-external-symbols (s pkg t) (when (eql s sym) (return nil))) + )) (delete-package package-name))) t t t t t) (deftest gentemp.6 (let* ((package-name "GENTEMP-TEST-PACKAGE")) (unwind-protect - (let* ((*package* (make-package package-name :use nil)) - (syms (loop repeat 100 collect (gentemp)))) - (=t (length syms) (length (remove-duplicates syms)))) + (let* ((*package* (make-package package-name :use nil)) + (syms (loop repeat 100 collect (gentemp)))) + (=t (length syms) (length (remove-duplicates syms)))) (delete-package package-name))) t) @@ -108,17 +108,17 @@ (deftest gentemp.error.1 (loop for x in *mini-universe* - unless (or (stringp x) - (eql (eval `(signals-type-error x ',x (gentemp x))) t)) - collect x) + unless (or (stringp x) + (eql (eval `(signals-type-error x ',x (gentemp x))) t)) + collect x) nil) (deftest gentemp.error.2 (loop for x in *mini-universe* - unless (or (typep x 'package) - (string-designator-p x) - (eql (eval `(signals-type-error x ',x (gentemp "T" x))) t)) - collect x) + unless (or (typep x 'package) + (string-designator-p x) + (eql (eval `(signals-type-error x ',x (gentemp "T" x))) t)) + collect x) nil) (deftest gentemp.error.3 diff --git a/ansi-tests/get-internal-time.lsp b/ansi-tests/get-internal-time.lsp index 7eda0681..3eef56cd 100644 --- a/ansi-tests/get-internal-time.lsp +++ b/ansi-tests/get-internal-time.lsp @@ -15,10 +15,10 @@ nil '(lambda () (let ((prev (get-internal-real-time))) - (loop for next = (get-internal-real-time) - repeat 100000 - do (assert (>= next prev)) - do (setf prev next)))))) + (loop for next = (get-internal-real-time) + repeat 100000 + do (assert (>= next prev)) + do (setf prev next)))))) nil) (deftest get-internal-real-time.error.1 @@ -41,10 +41,10 @@ nil '(lambda () (let ((prev (get-internal-run-time))) - (loop for next = (get-internal-run-time) - repeat 100000 - do (assert (>= next prev)) - do (setf prev next)))))) + (loop for next = (get-internal-run-time) + repeat 100000 + do (assert (>= next prev)) + do (setf prev next)))))) nil) (deftest get-internal-run-time.error.1 diff --git a/ansi-tests/get-macro-character.lsp b/ansi-tests/get-macro-character.lsp index 00ce6570..c6d04bf8 100644 --- a/ansi-tests/get-macro-character.lsp +++ b/ansi-tests/get-macro-character.lsp @@ -9,41 +9,41 @@ (def-syntax-test get-macro-character.1 (loop for c across "()';\"`,#" - collect - (let ((vals (multiple-value-list (get-macro-character c)))) - (list - (=t (length vals) 2) - (or (notnot (functionp (car vals))) - (and (symbolp (car vals)) - (notnot (fboundp (car vals))))) - (notnot (cadr vals))))) + collect + (let ((vals (multiple-value-list (get-macro-character c)))) + (list + (=t (length vals) 2) + (or (notnot (functionp (car vals))) + (and (symbolp (car vals)) + (notnot (fboundp (car vals))))) + (notnot (cadr vals))))) ((t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t t))) (def-syntax-test get-macro-character.2 (loop for c across (concatenate - 'string - "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "1234567890!@$%^&*_-+={[}]<>?/~") - for (fn non-term-p) = (multiple-value-list - (get-macro-character c)) - unless (or (null fn) non-term-p) - collect (list c fn non-term-p)) + 'string + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "1234567890!@$%^&*_-+={[}]<>?/~") + for (fn non-term-p) = (multiple-value-list + (get-macro-character c)) + unless (or (null fn) non-term-p) + collect (list c fn non-term-p)) nil) (def-syntax-test get-macro-character.3 (loop for rt in (list nil *readtable* (copy-readtable)) - collect - (loop for c across "()';\"`,#" - collect - (let ((vals (multiple-value-list (get-macro-character c rt)))) - (list - (=t (length vals) 2) - (or (notnot (functionp (car vals))) - (and (symbolp (car vals)) - (notnot (fboundp (car vals))))) - (notnot (cadr vals)))))) + collect + (loop for c across "()';\"`,#" + collect + (let ((vals (multiple-value-list (get-macro-character c rt)))) + (list + (=t (length vals) 2) + (or (notnot (functionp (car vals))) + (and (symbolp (car vals)) + (notnot (fboundp (car vals))))) + (notnot (cadr vals)))))) (((t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t nil) (t t t)) ((t t nil) (t t nil) (t t nil) (t t nil) @@ -53,16 +53,16 @@ (def-syntax-test get-macro-character.4 (loop for rt in (list nil *readtable* (copy-readtable)) - nconc - (loop for c across (concatenate - 'string - "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ" - "1234567890!@$%^&*_-+={[}]<>?/~") - for (fn non-term-p) = (multiple-value-list - (get-macro-character c rt)) - unless (or (null fn) non-term-p) - collect (list rt c fn non-term-p))) + nconc + (loop for c across (concatenate + 'string + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ" + "1234567890!@$%^&*_-+={[}]<>?/~") + for (fn non-term-p) = (multiple-value-list + (get-macro-character c rt)) + unless (or (null fn) non-term-p) + collect (list rt c fn non-term-p))) nil) ;;; Copying a readtable preserves the reader macros @@ -70,44 +70,44 @@ (def-syntax-test get-macro-character.5 (let ((rt (copy-readtable))) (loop for c across +standard-chars+ - for (fn1 ntp1) = (multiple-value-list (get-macro-character c)) - for (fn2 ntp2) = (multiple-value-list (get-macro-character c rt)) - unless (and (or (not (symbolp fn1)) - (not (symbolp fn2)) - (eql fn1 fn2)) - (if ntp1 ntp2 (not ntp2))) - collect (list c fn1 ntp1 fn2 ntp2))) + for (fn1 ntp1) = (multiple-value-list (get-macro-character c)) + for (fn2 ntp2) = (multiple-value-list (get-macro-character c rt)) + unless (and (or (not (symbolp fn1)) + (not (symbolp fn2)) + (eql fn1 fn2)) + (if ntp1 ntp2 (not ntp2))) + collect (list c fn1 ntp1 fn2 ntp2))) nil) (def-syntax-test get-macro-character.6 (let ((rt (copy-readtable))) (loop for i below (min 65536 char-code-limit) - for c = (code-char i) - for (fn1 ntp1) = (if c (multiple-value-list (get-macro-character c)) - '(nil nil)) - for (fn2 ntp2) = (if c (multiple-value-list (get-macro-character c rt)) - '(nil nil)) - unless (and (or (not (symbolp fn1)) - (not (symbolp fn2)) - (eql fn1 fn2)) - (if ntp1 ntp2 (not ntp2))) - collect (list c fn1 ntp1 fn2 ntp2))) + for c = (code-char i) + for (fn1 ntp1) = (if c (multiple-value-list (get-macro-character c)) + '(nil nil)) + for (fn2 ntp2) = (if c (multiple-value-list (get-macro-character c rt)) + '(nil nil)) + unless (and (or (not (symbolp fn1)) + (not (symbolp fn2)) + (eql fn1 fn2)) + (if ntp1 ntp2 (not ntp2))) + collect (list c fn1 ntp1 fn2 ntp2))) nil) (def-syntax-test get-macro-character.7 (let ((rt (copy-readtable))) (loop for i = (random (min char-code-limit (ash 1 24))) - for c = (code-char i) - for (fn1 ntp1) = (if c (multiple-value-list (get-macro-character c)) - '(nil nil)) - for (fn2 ntp2) = (if c (multiple-value-list (get-macro-character c rt)) - '(nil nil)) - repeat 10000 - unless (and (or (not (symbolp fn1)) - (not (symbolp fn2)) - (eql fn1 fn2)) - (if ntp1 ntp2 (not ntp2))) - collect (list c fn1 ntp1 fn2 ntp2))) + for c = (code-char i) + for (fn1 ntp1) = (if c (multiple-value-list (get-macro-character c)) + '(nil nil)) + for (fn2 ntp2) = (if c (multiple-value-list (get-macro-character c rt)) + '(nil nil)) + repeat 10000 + unless (and (or (not (symbolp fn1)) + (not (symbolp fn2)) + (eql fn1 fn2)) + (if ntp1 ntp2 (not ntp2))) + collect (list c fn1 ntp1 fn2 ntp2))) nil) diff --git a/ansi-tests/get-properties.lsp b/ansi-tests/get-properties.lsp index d26f375d..f38831e0 100644 --- a/ansi-tests/get-properties.lsp +++ b/ansi-tests/get-properties.lsp @@ -48,12 +48,12 @@ (deftest get-properties.9 (let* ((x (copy-list '(a b c d e f g h a c))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(x y f g))) - (ycopy (make-scaffold-copy y))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(x y f g))) + (ycopy (make-scaffold-copy y))) (multiple-value-bind - (indicator value tail) - (get-properties x y) + (indicator value tail) + (get-properties x y) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) @@ -66,7 +66,7 @@ (values (multiple-value-list (get-properties (progn (setf x (incf i)) '(a b c d)) - (progn (setf y (incf i)) '(c)))) + (progn (setf y (incf i)) '(c)))) i x y)) (c d (c d)) 2 1 2) diff --git a/ansi-tests/get-setf-expansion.lsp b/ansi-tests/get-setf-expansion.lsp index 61b76c3c..e2b67354 100644 --- a/ansi-tests/get-setf-expansion.lsp +++ b/ansi-tests/get-setf-expansion.lsp @@ -24,7 +24,7 @@ (deftest get-setf-expansion.1 (let* ((fn (gensym)) - (vals (multiple-value-list (get-setf-expansion (list fn))))) + (vals (multiple-value-list (get-setf-expansion (list fn))))) (values (length vals) (first vals) @@ -32,23 +32,23 @@ (length (third vals)) (block done (subst-if nil - #'(lambda (term) - (when (equal term `(function (setf ,fn))) - (return-from done :good))) - (fourth vals))) + #'(lambda (term) + (when (equal term `(function (setf ,fn))) + (return-from done :good))) + (fourth vals))) (if (equal (fifth vals) (list fn)) - :good + :good (fifth vals)))) 5 nil nil 1 :good :good) (deftest get-setf-expansion.2 (let* ((fn (gensym)) - (vals (multiple-value-list (get-setf-expansion (list fn) nil)))) + (vals (multiple-value-list (get-setf-expansion (list fn) nil)))) (length vals)) 5) (deftest get-setf-expansion.3 (let* ((var (gensym)) - (vals (multiple-value-list (get-setf-expansion var)))) + (vals (multiple-value-list (get-setf-expansion var)))) (length vals)) 5) diff --git a/ansi-tests/get-universal-time.lsp b/ansi-tests/get-universal-time.lsp index f79e1ced..76dbccd7 100644 --- a/ansi-tests/get-universal-time.lsp +++ b/ansi-tests/get-universal-time.lsp @@ -14,25 +14,25 @@ (deftest get-universal-time.2 (let* ((time1 (get-universal-time)) - (vals (multiple-value-list (get-decoded-time))) - (time2 (get-universal-time))) + (vals (multiple-value-list (get-decoded-time))) + (time2 (get-universal-time))) (when (= time1 time2) (let ((vals2 (multiple-value-list (decode-universal-time time1)))) - (assert (= (length vals) 9)) - (assert (= (length vals2) 9)) - (assert (equal (subseq vals 0 7) - (subseq vals2 0 7))) - (assert (if (elt vals 7) (elt vals2 7) (not (elt vals2 7)))) - (assert (= (elt vals 8) (elt vals2 8))))) + (assert (= (length vals) 9)) + (assert (= (length vals2) 9)) + (assert (equal (subseq vals 0 7) + (subseq vals2 0 7))) + (assert (if (elt vals 7) (elt vals2 7) (not (elt vals2 7)))) + (assert (= (elt vals 8) (elt vals2 8))))) (values))) (deftest get-universal-time.3 (let* ((first (get-universal-time)) - (prev first)) + (prev first)) (loop for time = (get-universal-time) - do (assert (>= time prev)) - do (setf prev time) - until (>= time (+ 5 first)))) + do (assert (>= time prev)) + do (setf prev time) + until (>= time (+ 5 first)))) nil) ;;; Error tests @@ -55,5 +55,5 @@ - + diff --git a/ansi-tests/get.lsp b/ansi-tests/get.lsp index 04eb3c76..ec5a6ccb 100644 --- a/ansi-tests/get.lsp +++ b/ansi-tests/get.lsp @@ -25,9 +25,9 @@ (deftest get.5 (let ((evaluated nil) - (sym (gensym))) + (sym (gensym))) (assert (equal (multiple-value-list (setf (get sym :foo) 1)) - '(1))) + '(1))) (values (get sym :foo (progn (setf evaluated t) nil)) evaluated)) @@ -35,12 +35,12 @@ (deftest get.6 (let ((evaluated nil) - (sym (gensym))) + (sym (gensym))) (assert (equal (multiple-value-list - (setf (get sym :foo - (progn (setf evaluated t) nil)) - 1)) - '(1))) + (setf (get sym :foo + (progn (setf evaluated t) nil)) + 1)) + '(1))) (values (get sym :foo) evaluated)) @@ -53,7 +53,7 @@ (setf (get sym :foo) t) (values (get (progn (setf a (incf i)) sym) - (progn (setf b (incf i)) :foo)) + (progn (setf b (incf i)) :foo)) a b i)) t 1 2 2) @@ -61,8 +61,8 @@ (let (a b (i 0) (sym (gensym))) (values (setf (get (progn (setf a (incf i)) sym) - (progn (setf b (incf i)) :foo)) - t) + (progn (setf b (incf i)) :foo)) + t) a b i (get sym :foo) )) @@ -73,8 +73,8 @@ (setf (get sym :foo) t) (values (get (progn (setf a (incf i)) sym) - (progn (setf b (incf i)) :foo) - (progn (setf c (incf i)) nil)) + (progn (setf b (incf i)) :foo) + (progn (setf c (incf i)) nil)) a b c i)) t 1 2 3 3) @@ -82,9 +82,9 @@ (let (a b c (i 0) (sym (gensym))) (values (setf (get (progn (setf a (incf i)) sym) - (progn (setf b (incf i)) :foo) - (progn (setf c (incf i)) nil)) - t) + (progn (setf b (incf i)) :foo) + (progn (setf c (incf i)) nil)) + t) a b c i (get sym :foo) )) diff --git a/ansi-tests/getf.lsp b/ansi-tests/getf.lsp index 8195e583..c63feb51 100644 --- a/ansi-tests/getf.lsp +++ b/ansi-tests/getf.lsp @@ -34,16 +34,16 @@ (let ((i 0) x y) (values (getf (progn (setf x (incf i)) '(a b)) - (progn (setf y (incf i)) 'a)) + (progn (setf y (incf i)) 'a)) i x y)) b 2 1 2) - + (deftest getf.order.2 (let ((i 0) x y z) (values (getf (progn (setf x (incf i)) '(a b)) - (progn (setf y (incf i)) 'a) - (setf z (incf i))) + (progn (setf y (incf i)) 'a) + (setf z (incf i))) i x y z)) b 3 1 2 3) @@ -76,7 +76,7 @@ (not (member (car ptr) '(a b)))) 0) t)) - t) + t) (deftest setf-getf.3 (let ((p (copy-list '(a 1 b 2)))) @@ -111,7 +111,7 @@ (deftest setf-getf.5 (let ((p (copy-list '(a 1 b 2))) - (foo nil)) + (foo nil)) (setf (getf p 'a (progn (setf foo t) 0)) 3) ;; Must check that only a, b have properties (and @@ -147,11 +147,11 @@ (deftest setf-getf.order.2 (let ((p (list (copy-list '(a 1 b 2)))) - (i 0) x y z w) + (i 0) x y z w) (setf (getf (car (progn (setf x (incf i)) p)) - (progn (setf y (incf i)) 'c) - (setf z (incf i))) - (progn (setf w (incf i)) 3)) + (progn (setf y (incf i)) 'c) + (setf z (incf i))) + (progn (setf w (incf i)) 3)) ;; Must check that only a, b, c have properties (values i x y z w @@ -159,7 +159,7 @@ (getf (car p) 'b) (getf (car p) 'c) (loop for ptr on (car p) by #'cddr count - (not (member (car ptr) '(a b c)))))) + (not (member (car ptr) '(a b c)))))) 4 1 2 3 4 1 2 3 0) (deftest incf-getf.1 @@ -186,10 +186,10 @@ (eqlt (getf p 'b) 2) (eqlt (getf p 'c) 20) (eqlt - (loop - for ptr on p by #'cddr count - (not (member (car ptr) '(a b c)))) - 0) + (loop + for ptr on p by #'cddr count + (not (member (car ptr) '(a b c)))) + 0) t)) t) diff --git a/ansi-tests/gethash.lsp b/ansi-tests/gethash.lsp index 573b4fca..beab51db 100644 --- a/ansi-tests/gethash.lsp +++ b/ansi-tests/gethash.lsp @@ -22,14 +22,14 @@ (deftest gethash.4 (multiple-value-bind (value present) (gethash 'a (let ((table (make-hash-table))) - (setf (gethash 'a table) 'b) - table)) + (setf (gethash 'a table) 'b) + table)) (values value (notnot present))) b t) (deftest gethash.5 (let ((table (make-hash-table)) - (i 0)) + (i 0)) (values (setf (gethash 'x table (incf i)) 'y) i @@ -38,44 +38,44 @@ (deftest gethash.order.1 (let ((i 0) x y - (table (make-hash-table))) + (table (make-hash-table))) (setf (gethash 'a table) 'b) (values (gethash (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) table)) + (progn (setf y (incf i)) table)) i x y)) b 2 1 2) (deftest gethash.order.2 (let ((i 0) x y z - (table (make-hash-table))) + (table (make-hash-table))) (setf (gethash 'a table) 'b) (values (gethash (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) table) - (progn (setf z (incf i)) 'missing)) + (progn (setf y (incf i)) table) + (progn (setf z (incf i)) 'missing)) i x y z)) b 3 1 2 3) (deftest gethash.order.3 (let ((i 0) x y - (table (make-hash-table))) + (table (make-hash-table))) (values (setf (gethash (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) table)) - 'b) + (progn (setf y (incf i)) table)) + 'b) i x y (gethash 'a table))) b 2 1 2 b) (deftest gethash.order.4 (let ((i 0) x y z - (table (make-hash-table))) + (table (make-hash-table))) (values (setf (gethash (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) table) - (setf z (incf i))) - 'b) + (progn (setf y (incf i)) table) + (setf z (incf i))) + 'b) i x y z (gethash 'a table))) b 3 1 2 3 b) @@ -85,66 +85,66 @@ (deftest gethash.zero.1 (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) - for nz = (- pz) - for result = (let ((table (make-hash-table :test 'eq))) - (list - (setf (gethash pz table) :x) - (gethash pz table) - (gethash nz table) - (setf (gethash nz table) :y) - (gethash pz table) - (gethash nz table))) - unless (or (eql pz nz) - (equal result '(:x :x nil :y :x :y))) - collect (list pz nz result)) + for nz = (- pz) + for result = (let ((table (make-hash-table :test 'eq))) + (list + (setf (gethash pz table) :x) + (gethash pz table) + (gethash nz table) + (setf (gethash nz table) :y) + (gethash pz table) + (gethash nz table))) + unless (or (eql pz nz) + (equal result '(:x :x nil :y :x :y))) + collect (list pz nz result)) nil) (deftest gethash.zero.2 (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) - for nz = (- pz) - for result = (let ((table (make-hash-table :test 'eql))) - (list - (setf (gethash pz table) :x) - (gethash pz table) - (gethash nz table) - (setf (gethash nz table) :y) - (gethash pz table) - (gethash nz table))) - unless (or (eql pz nz) - (equal result '(:x :x nil :y :x :y))) - collect (list pz nz result)) + for nz = (- pz) + for result = (let ((table (make-hash-table :test 'eql))) + (list + (setf (gethash pz table) :x) + (gethash pz table) + (gethash nz table) + (setf (gethash nz table) :y) + (gethash pz table) + (gethash nz table))) + unless (or (eql pz nz) + (equal result '(:x :x nil :y :x :y))) + collect (list pz nz result)) nil) (deftest gethash.zero.3 (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) - for nz = (- pz) - for result = (let ((table (make-hash-table :test 'equal))) - (list - (setf (gethash pz table) :x) - (gethash pz table) - (gethash nz table) - (setf (gethash nz table) :y) - (gethash pz table) - (gethash nz table))) - unless (or (eql pz nz) - (equal result '(:x :x nil :y :x :y))) - collect (list pz nz result)) + for nz = (- pz) + for result = (let ((table (make-hash-table :test 'equal))) + (list + (setf (gethash pz table) :x) + (gethash pz table) + (gethash nz table) + (setf (gethash nz table) :y) + (gethash pz table) + (gethash nz table))) + unless (or (eql pz nz) + (equal result '(:x :x nil :y :x :y))) + collect (list pz nz result)) nil) (deftest gethash.zero.4 (loop for pz in '(0.0s0 0.0f0 0.0d0 0.0l0) - for nz = (- pz) - for result = (let ((table (make-hash-table :test 'equalp))) - (list - (setf (gethash pz table) :x) - (gethash pz table) - (gethash nz table) - (setf (gethash nz table) :y) - (gethash pz table) - (gethash nz table))) - unless (or (eql pz nz) - (equal result '(:x :x :x :y :y :y))) - collect (list pz nz result)) + for nz = (- pz) + for result = (let ((table (make-hash-table :test 'equalp))) + (list + (setf (gethash pz table) :x) + (gethash pz table) + (gethash nz table) + (setf (gethash nz table) :y) + (gethash pz table) + (gethash nz table))) + unless (or (eql pz nz) + (equal result '(:x :x :x :y :y :y))) + collect (list pz nz result)) nil) ;;;; Error tests diff --git a/ansi-tests/handler-bind.lsp b/ansi-tests/handler-bind.lsp index bd5a345d..24c20904 100644 --- a/ansi-tests/handler-bind.lsp +++ b/ansi-tests/handler-bind.lsp @@ -26,7 +26,7 @@ (deftest handler-bind.5 (block foo (handler-bind ((error #'(lambda (c) (return-from foo 'good)))) - (error "an error"))) + (error "an error"))) good) (deftest handler-bind.6 @@ -34,8 +34,8 @@ (handler-bind ((error #'(lambda (c) (return-from foo 'good)))) (handler-bind ((error #'(lambda (c) (error c))) - (error #'(lambda (c) (return-from foo 'bad)))) - (error "an error")))) + (error #'(lambda (c) (return-from foo 'bad)))) + (error "an error")))) good) (defun handler-bind.7-handler-fn (c) @@ -45,30 +45,30 @@ (deftest handler-bind.7 (catch 'foo (handler-bind ((simple-error #'handler-bind.7-handler-fn)) - (error "simple error"))) + (error "simple error"))) good) (deftest handler-bind.8 (catch 'foo (handler-bind ((simple-error 'handler-bind.7-handler-fn)) - (error "simple error"))) + (error "simple error"))) good) (deftest handler-bind.9 (catch 'foo (handler-bind ((simple-error #.(symbol-function - 'handler-bind.7-handler-fn))) - (error "simple error"))) + 'handler-bind.7-handler-fn))) + (error "simple error"))) good) (deftest handler-bind.10 (block done (flet ((%foo () (signal "A simple condition")) - (%succeed (c) (declare (ignore c)) (return-from done 'good)) - (%fail (c) (declare (ignore c)) (return-from done 'bad))) + (%succeed (c) (declare (ignore c)) (return-from done 'good)) + (%fail (c) (declare (ignore c)) (return-from done 'bad))) (handler-bind ((error #'%fail) - (simple-condition #'%succeed)) + (simple-condition #'%succeed)) (%foo)))) good) @@ -92,7 +92,7 @@ (deftest handler-bind.13 (handler-bind ((error #'(lambda (c) (declare (ignore c)) - (throw 'done 'good)))) + (throw 'done 'good)))) (catch 'done (error "an error"))) good) @@ -102,7 +102,7 @@ (handler-bind ((symbol #'identity) ;; can never succeed (error #'(lambda (c) (declare (ignore c)) - (throw 'done 'good)))) + (throw 'done 'good)))) (error "an error"))) good) @@ -110,9 +110,9 @@ (catch 'done (handler-bind ((nil #'(lambda (c) (declare (ignore c)) - (throw 'done 'bad))) + (throw 'done 'bad))) (error #'(lambda (c) (declare (ignore c)) - (throw 'done 'good)))) + (throw 'done 'good)))) (error "an error"))) good) @@ -122,7 +122,7 @@ (((not error) #'identity) (error #'(lambda (c) (declare (ignore c)) - (throw 'done 'good)))) + (throw 'done 'good)))) (error "an error"))) good) @@ -130,8 +130,8 @@ (catch 'done (handler-bind ((#.(find-class 'error) - #'(lambda (c) (declare (ignore c)) - (throw 'done 'good)))) + #'(lambda (c) (declare (ignore c)) + (throw 'done 'good)))) (error "an error"))) good) @@ -139,8 +139,8 @@ - - - - + + + + diff --git a/ansi-tests/handler-case.lsp b/ansi-tests/handler-case.lsp index 813c977c..456f1678 100644 --- a/ansi-tests/handler-case.lsp +++ b/ansi-tests/handler-case.lsp @@ -44,7 +44,7 @@ (deftest handler-case.6 (handler-case (values) - (error () nil))) + (error () nil))) (deftest handler-case.7 (handler-case 'foo (condition () 'bar)) @@ -66,46 +66,46 @@ (deftest handler-case.11 (labels ((%f () (declare (special *c*)) - (and (typep *c* 'condition) t)) - (%g () - (let ((*c* nil)) - (declare (special *c*)) - (%h))) - (%h () - (handler-case - (error "foo") - (error (*c*) (declare (special *c*)) - (%f))))) + (and (typep *c* 'condition) t)) + (%g () + (let ((*c* nil)) + (declare (special *c*)) + (%h))) + (%h () + (handler-case + (error "foo") + (error (*c*) (declare (special *c*)) + (%f))))) (%g)) t) (deftest handler-case.12 (handler-case (error "foo") - (nil () nil) - (error (c) (notnot-mv (typep c 'simple-error)))) + (nil () nil) + (error (c) (notnot-mv (typep c 'simple-error)))) t) (deftest handler-case.13 (handler-case (error "foo") - (error (c) (values)))) + (error (c) (values)))) (deftest handler-case.14 (handler-case (error "foo") - (error (c) - (values 1 2 3 4 5 6 7 8))) + (error (c) + (values 1 2 3 4 5 6 7 8))) 1 2 3 4 5 6 7 8) (deftest handler-case.15 (handler-case (handler-case (error "foo") - (warning () 'bad)) + (warning () 'bad)) (error () 'good)) good) (deftest handler-case.16 (handler-case (handler-case (error "foo") - (error () 'good)) + (error () 'good)) (error () 'bad)) good) @@ -114,7 +114,7 @@ (values (handler-case (handler-case (error "foo") - (error () (incf i) (error "bar"))) + (error () (incf i) (error "bar"))) (error () 'good)) i)) good 1) @@ -124,7 +124,7 @@ (values (handler-case (handler-case (error "foo") - (error (c) (incf i) (error c))) + (error (c) (incf i) (error c))) (error () 'good)) i)) good 1) @@ -133,11 +133,11 @@ (handler-case (error "foo") (error (c) - ;; Test that declarations can go here - (declare (optimize (safety 3))) - (declare (type condition c)) - (declare (ignore c)) - t)) + ;; Test that declarations can go here + (declare (optimize (safety 3))) + (declare (type condition c)) + (declare (ignore c)) + t)) t) (deftest handler-case.20 @@ -184,12 +184,12 @@ (values 1 'a 1.0) (error () 'bad) (:no-error (a b c) - ;; Test that declarations can go here - (declare (type integer a)) - (declare (type symbol b)) - (declare (type number c)) - (declare (ignore a c)) - b)) + ;; Test that declarations can go here + (declare (type integer a)) + (declare (type symbol b)) + (declare (type number c)) + (declare (ignore a c)) + b)) a) (deftest handler-case.27 @@ -207,7 +207,7 @@ (declare (special x)) (let ((x :good)) (handler-case nil - (:no-error (z &aux (y x)) - (declare (special x) (ignore z)) - y)))) + (:no-error (z &aux (y x)) + (declare (special x) (ignore z)) + y)))) :good) diff --git a/ansi-tests/hash-table-aux.lsp b/ansi-tests/hash-table-aux.lsp index 88c53ae7..6bf3d068 100644 --- a/ansi-tests/hash-table-aux.lsp +++ b/ansi-tests/hash-table-aux.lsp @@ -12,7 +12,7 @@ (defun test-hash-table-1 (&rest args) (let ((table (apply #'make-hash-table args)) - (test (or (getf args :test) 'eql))) + (test (or (getf args :test) 'eql))) (assert (member test '(eq eql equal equalp))) (assert (hash-table-p table)) (assert (typep table 'hash-table)) @@ -20,74 +20,74 @@ ;; Perform *hash-table-test-iters* iterations of ;; random hash table operations (let* ((universe-vec (coerce *universe* 'vector)) - ;; (universe-size (length universe-vec)) - (mapping nil) - (count 0)) + ;; (universe-size (length universe-vec)) + (mapping nil) + (count 0)) (loop for i from 0 below *hash-table-test-iters* do (assert (eql (hash-table-count table) count)) do (assert (let ((size (hash-table-size table))) - (and (integerp size) (>= size 0)))) + (and (integerp size) (>= size 0)))) do (flet ((%remove-pair - (rpair) - (decf count) - (let ((key (car rpair)) - (expected-value (cdr rpair))) - (multiple-value-bind (value present-p) - (gethash key table) - (assert present-p) - (assert (eql expected-value value)) - (setf mapping - (remove rpair mapping :count 1 :test 'eq))) - (assert (remhash key table)) - (multiple-value-bind (value present-p) - (gethash key table) - (assert (not present-p)) - (assert (null value)) - )))) - - (rcase - (1 ;; Insert - (let* ((new-elem (random-from-seq universe-vec)) - (pair (assoc new-elem mapping :test test))) - (cond - (pair - (multiple-value-bind - (value present-p) - (gethash new-elem table) - (assert present-p) - (assert (eql (cdr pair) value)) - (setf (cdr pair) i - (gethash new-elem table) i))) - (t - (assert - (equal (multiple-value-list (gethash new-elem table)) - '(nil nil))) - (incf count) - (push (cons new-elem i) mapping) - (setf (gethash new-elem table) i))))) - (1 ;; Delete element in the set - (when mapping - (%remove-pair (random-from-seq mapping)))) - (1 ;; Delete random element from universe - (let* ((key (random-from-seq universe-vec)) - (pair (assoc key mapping :test test))) - (cond - (pair (%remove-pair pair)) - (t - ;; Not present -- check that this is true - (assert (equal (multiple-value-list (gethash key table)) - '(nil nil))) - (assert (not (remhash key table))) - (assert (equal (multiple-value-list (gethash key table)) - '(nil nil))))) - )) - )))))) + (rpair) + (decf count) + (let ((key (car rpair)) + (expected-value (cdr rpair))) + (multiple-value-bind (value present-p) + (gethash key table) + (assert present-p) + (assert (eql expected-value value)) + (setf mapping + (remove rpair mapping :count 1 :test 'eq))) + (assert (remhash key table)) + (multiple-value-bind (value present-p) + (gethash key table) + (assert (not present-p)) + (assert (null value)) + )))) + + (rcase + (1 ;; Insert + (let* ((new-elem (random-from-seq universe-vec)) + (pair (assoc new-elem mapping :test test))) + (cond + (pair + (multiple-value-bind + (value present-p) + (gethash new-elem table) + (assert present-p) + (assert (eql (cdr pair) value)) + (setf (cdr pair) i + (gethash new-elem table) i))) + (t + (assert + (equal (multiple-value-list (gethash new-elem table)) + '(nil nil))) + (incf count) + (push (cons new-elem i) mapping) + (setf (gethash new-elem table) i))))) + (1 ;; Delete element in the set + (when mapping + (%remove-pair (random-from-seq mapping)))) + (1 ;; Delete random element from universe + (let* ((key (random-from-seq universe-vec)) + (pair (assoc key mapping :test test))) + (cond + (pair (%remove-pair pair)) + (t + ;; Not present -- check that this is true + (assert (equal (multiple-value-list (gethash key table)) + '(nil nil))) + (assert (not (remhash key table))) + (assert (equal (multiple-value-list (gethash key table)) + '(nil nil))))) + )) + )))))) + + + + + - - - - - diff --git a/ansi-tests/hash-table-count.lsp b/ansi-tests/hash-table-count.lsp index 8fc619e3..53f12af0 100644 --- a/ansi-tests/hash-table-count.lsp +++ b/ansi-tests/hash-table-count.lsp @@ -43,17 +43,17 @@ (deftest hash-table-count.10 (hash-table-count (let ((table (make-hash-table))) - (setf (gethash 'x table) 1) - table)) + (setf (gethash 'x table) 1) + table)) 1) (deftest hash-table-count.11 (let ((table (make-hash-table))) (setf (gethash 'x table) 1) (values (hash-table-count table) - (progn - (remhash 'x table) - (hash-table-count table)))) + (progn + (remhash 'x table) + (hash-table-count table)))) 1 0) ;; This function is mostly tested by calls to test-hash-table-1 @@ -64,5 +64,5 @@ (deftest hash-table-count.error.2 (signals-error (hash-table-count (make-hash-table) nil) - program-error) + program-error) t) diff --git a/ansi-tests/hash-table-p.lsp b/ansi-tests/hash-table-p.lsp index 1fa211f0..de3b9492 100644 --- a/ansi-tests/hash-table-p.lsp +++ b/ansi-tests/hash-table-p.lsp @@ -7,10 +7,10 @@ (deftest hash-table-p.1 (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 - #0aNIL #2a((a b)(c d)) #p"foo" - "bar" #\a 3/5 #c(1.0 2.0)) - when (hash-table-p e) - collect e) + #0aNIL #2a((a b)(c d)) #p"foo" + "bar" #\a 3/5 #c(1.0 2.0)) + when (hash-table-p e) + collect e) nil) (deftest hash-table-p.2 @@ -36,6 +36,6 @@ (deftest hash-table-p.error.2 (signals-error (let ((h (make-hash-table))) (hash-table-p h nil)) - program-error) + program-error) t) diff --git a/ansi-tests/hash-table-rehash-size.lsp b/ansi-tests/hash-table-rehash-size.lsp index b189b0b0..9c4f22cb 100644 --- a/ansi-tests/hash-table-rehash-size.lsp +++ b/ansi-tests/hash-table-rehash-size.lsp @@ -7,22 +7,22 @@ (deftest hash-table-rehash-size.1 (typep* (hash-table-rehash-size (make-hash-table)) - '(or (integer 1 *) (float (1.0) *))) + '(or (integer 1 *) (float (1.0) *))) t) (deftest hash-table-rehash-size.2 (loop for test in '(eq eql equal equalp) - unless (typep* (hash-table-rehash-size (make-hash-table :test test)) - '(or (integer 1 *) (float (1.0) *))) - collect test) + unless (typep* (hash-table-rehash-size (make-hash-table :test test)) + '(or (integer 1 *) (float (1.0) *))) + collect test) nil) (deftest hash-table-rehash-size.3 (loop for test in '(eq eql equal equalp) - for fn = (symbol-function test) - unless (typep* (hash-table-rehash-size (make-hash-table :test fn)) - '(or (integer 1 *) (float (1.0) *))) - collect test) + for fn = (symbol-function test) + unless (typep* (hash-table-rehash-size (make-hash-table :test fn)) + '(or (integer 1 *) (float (1.0) *))) + collect test) nil) (deftest hash-table-rehash-size.error.1 @@ -31,7 +31,7 @@ (deftest hash-table-rehash-size.error.2 (signals-error (hash-table-rehash-size (make-hash-table) nil) - program-error) + program-error) t) (deftest hash-table-rehash-size.error.3 diff --git a/ansi-tests/hash-table-rehash-threshold.lsp b/ansi-tests/hash-table-rehash-threshold.lsp index 4577e63a..87a09aa9 100644 --- a/ansi-tests/hash-table-rehash-threshold.lsp +++ b/ansi-tests/hash-table-rehash-threshold.lsp @@ -7,22 +7,22 @@ (deftest hash-table-rehash-threshold.1 (typep* (hash-table-rehash-threshold (make-hash-table)) - '(real 0 1)) + '(real 0 1)) t) (deftest hash-table-rehash-threshold.2 (loop for test in '(eq eql equal equalp) - unless (typep* (hash-table-rehash-threshold (make-hash-table :test test)) - '(real 0 1)) - collect test) + unless (typep* (hash-table-rehash-threshold (make-hash-table :test test)) + '(real 0 1)) + collect test) nil) (deftest hash-table-rehash-threshold.3 (loop for test in '(eq eql equal equalp) - for fn = (symbol-function test) - unless (typep* (hash-table-rehash-threshold (make-hash-table :test fn)) - '(real 0 1)) - collect test) + for fn = (symbol-function test) + unless (typep* (hash-table-rehash-threshold (make-hash-table :test fn)) + '(real 0 1)) + collect test) nil) (deftest hash-table-rehash-threshold.error.1 @@ -31,7 +31,7 @@ (deftest hash-table-rehash-threshold.error.2 (signals-error (hash-table-rehash-threshold (make-hash-table) nil) - program-error) + program-error) t) (deftest hash-table-rehash-threshold.error.3 diff --git a/ansi-tests/hash-table-size.lsp b/ansi-tests/hash-table-size.lsp index e486eced..9ce1a55a 100644 --- a/ansi-tests/hash-table-size.lsp +++ b/ansi-tests/hash-table-size.lsp @@ -11,7 +11,7 @@ (deftest hash-table-size.error.2 (signals-error (hash-table-size (make-hash-table) nil) - program-error) + program-error) t) (deftest hash-table-size.error.3 diff --git a/ansi-tests/hash-table-test.lsp b/ansi-tests/hash-table-test.lsp index fea19a49..ab6b082c 100644 --- a/ansi-tests/hash-table-test.lsp +++ b/ansi-tests/hash-table-test.lsp @@ -11,24 +11,24 @@ (deftest hash-table-test.2 (loop for test in '(eq eql equal equalp) - unless (eq (hash-table-test (make-hash-table :test test)) test) - collect test) + unless (eq (hash-table-test (make-hash-table :test test)) test) + collect test) nil) (deftest hash-table-test.3 (loop for test in '(eq eql equal equalp) - unless (eq (hash-table-test (make-hash-table - :test (symbol-function test))) - test) - collect test) + unless (eq (hash-table-test (make-hash-table + :test (symbol-function test))) + test) + collect test) nil) (deftest hash-table-test.4 (loop for test in '(eq eql equal equalp) - unless (eq (hash-table-test (make-hash-table - :test (eval `(function ,test)))) - test) - collect test) + unless (eq (hash-table-test (make-hash-table + :test (eval `(function ,test)))) + test) + collect test) nil) ;;; Error cases diff --git a/ansi-tests/hash-table.lsp b/ansi-tests/hash-table.lsp index fdac7494..e87cb736 100644 --- a/ansi-tests/hash-table.lsp +++ b/ansi-tests/hash-table.lsp @@ -11,19 +11,19 @@ (deftest hash-table.2 (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 - #0aNIL #2a((a b)(c d)) #p"foo" - "bar" #\a 3/5 #c(1.0 2.0)) - when (typep e 'hash-table) - collect e) + #0aNIL #2a((a b)(c d)) #p"foo" + "bar" #\a 3/5 #c(1.0 2.0)) + when (typep e 'hash-table) + collect e) nil) (deftest hash-table.3 (let ((c (find-class 'hash-table))) (loop for e in '(nil t 1 10.0 (a b c) #(a b c) #*1011 - #0aNIL #2a((a b)(c d)) #p"foo" - "bar" #\a 3/5 #c(1.0 2.0)) - when (typep e c) - collect e)) + #0aNIL #2a((a b)(c d)) #p"foo" + "bar" #\a 3/5 #c(1.0 2.0)) + when (typep e c) + collect e)) nil) (deftest hash-table.4 @@ -36,6 +36,6 @@ - + diff --git a/ansi-tests/host-namestring.lsp b/ansi-tests/host-namestring.lsp index 274b1f5a..221a01ae 100644 --- a/ansi-tests/host-namestring.lsp +++ b/ansi-tests/host-namestring.lsp @@ -7,14 +7,14 @@ (deftest host-namestring.1 (let* ((vals (multiple-value-list - (host-namestring "host-namestring.lsp"))) - (s (first vals))) + (host-namestring "host-namestring.lsp"))) + (s (first vals))) (if (and (null (cdr vals)) - (or (null s) - (stringp s) - ;; (equal (host-namestring s) s) - )) - :good + (or (null s) + (stringp s) + ;; (equal (host-namestring s) s) + )) + :good vals)) :good) @@ -30,10 +30,10 @@ (deftest host-namestring.3 (let* ((name "host-namestring.lsp") - (pn (merge-pathnames (pathname name))) - (name2 (with-open-file (s pn :direction :input) - (host-namestring s))) - (name3 (host-namestring pn))) + (pn (merge-pathnames (pathname name))) + (name2 (with-open-file (s pn :direction :input) + (host-namestring s))) + (name3 (host-namestring pn))) (or (equalt name2 name3) (list name2 name3))) t) diff --git a/ansi-tests/if.lsp b/ansi-tests/if.lsp index b4fe98e5..6f529742 100644 --- a/ansi-tests/if.lsp +++ b/ansi-tests/if.lsp @@ -33,39 +33,39 @@ (deftest if.8 (macrolet ((%m (z) z)) - (if (expand-in-current-env (%m t)) :good :bad)) + (if (expand-in-current-env (%m t)) :good :bad)) :good) (deftest if.9 (macrolet ((%m (z) z)) - (if (expand-in-current-env (%m nil)) :bad)) + (if (expand-in-current-env (%m nil)) :bad)) nil) (deftest if.10 (macrolet ((%m (z) z)) - (if (expand-in-current-env (%m t)) :good)) + (if (expand-in-current-env (%m t)) :good)) :good) (deftest if.11 (macrolet ((%m (z) z)) - (if (expand-in-current-env (%m nil)) :bad :good)) + (if (expand-in-current-env (%m nil)) :bad :good)) :good) (deftest if.12 (macrolet ((%m (z) z)) (flet ((%f (x y) (if x (expand-in-current-env (%m y))))) - (declare (notinline %f)) - (values (%f t :good) (%f nil :bad)))) + (declare (notinline %f)) + (values (%f t :good) (%f nil :bad)))) :good nil) - + (deftest if.13 (macrolet ((%m (z) z)) (flet ((%f (x y z) (if x y (expand-in-current-env (%m z))))) - (declare (notinline %f)) - (values (%f t :good :bad) (%f nil :bad :good)))) - :good :good) + (declare (notinline %f)) + (values (%f t :good :bad) (%f nil :bad :good)))) + :good :good) (deftest if.order.1 (let ((i 0)) diff --git a/ansi-tests/ignorable.lsp b/ansi-tests/ignorable.lsp index 9f1b3c06..f8b59620 100644 --- a/ansi-tests/ignorable.lsp +++ b/ansi-tests/ignorable.lsp @@ -17,7 +17,7 @@ (flet ((%f () 'foo)) (declare (ignorable (function %f)))) nil) - + (deftest ignorable.4 (flet ((%f () 'foo)) (declare (ignorable (function %f))) @@ -28,28 +28,28 @@ (deftest ignorable.5 (flet (((setf %f) (x y) nil)) - (declare (ignorable (function (setf %f)))) - :good) + (declare (ignorable (function (setf %f)))) + :good) :good) (deftest ignorable.6 (flet (((setf %f) (x y) (setf (car y) x))) - (declare (ignorable (function (setf %f)))) - (let ((z (cons 'a 'b))) - (values (setf (%f z) 'c) z))) + (declare (ignorable (function (setf %f)))) + (let ((z (cons 'a 'b))) + (values (setf (%f z) 'c) z))) c (c . b)) (deftest ignorable.7 (labels (((setf %f) (x y) nil)) - (declare (ignorable (function (setf %f)))) - :good) + (declare (ignorable (function (setf %f)))) + :good) :good) (deftest ignorable.8 (labels (((setf %f) (x y) (setf (car y) x))) - (declare (ignorable (function (setf %f)))) - (let ((z (cons 'a 'b))) - (values (setf (%f z) 'c) z))) + (declare (ignorable (function (setf %f)))) + (let ((z (cons 'a 'b))) + (values (setf (%f z) 'c) z))) c (c . b)) diff --git a/ansi-tests/ignore-errors.lsp b/ansi-tests/ignore-errors.lsp index b01223fc..ae2f54c4 100644 --- a/ansi-tests/ignore-errors.lsp +++ b/ansi-tests/ignore-errors.lsp @@ -21,8 +21,8 @@ (multiple-value-bind (val cond) (ignore-errors (error "foo")) (and (null val) - (typep cond 'simple-error) - t)) + (typep cond 'simple-error) + t)) t) (deftest ignore-errors.5 diff --git a/ansi-tests/ignore.lsp b/ansi-tests/ignore.lsp index 596241f7..066a3283 100644 --- a/ansi-tests/ignore.lsp +++ b/ansi-tests/ignore.lsp @@ -17,7 +17,7 @@ (flet ((%f () 'foo)) (declare (ignore (function %f)))) nil) - + (deftest ignore.4 (flet ((%f () 'foo)) (declare (ignore (function %f))) @@ -26,12 +26,12 @@ (deftest ignore.5 (flet (((setf %f) (x y) (setf (car y) x))) - (declare (ignore (function (setf %f)))) - :good) + (declare (ignore (function (setf %f)))) + :good) :good) (deftest ignore.6 (labels (((setf %f) (x y) (setf (car y) x))) - (declare (ignore (function (setf %f)))) - :good) + (declare (ignore (function (setf %f)))) + :good) :good) diff --git a/ansi-tests/imagpart.lsp b/ansi-tests/imagpart.lsp index b5fdcd13..823c7236 100644 --- a/ansi-tests/imagpart.lsp +++ b/ansi-tests/imagpart.lsp @@ -19,33 +19,33 @@ (deftest imagpart.1 (loop for x in *reals* - for c = (complex 0 x) - for ip = (imagpart c) - unless (eql x ip) - collect (list x c ip)) + for c = (complex 0 x) + for ip = (imagpart c) + unless (eql x ip) + collect (list x c ip)) nil) (deftest imagpart.2 (loop for x in *reals* - for c = (complex 1 x) - for ip = (imagpart c) - unless (eql x ip) - collect (list x c ip)) + for c = (complex 1 x) + for ip = (imagpart c) + unless (eql x ip) + collect (list x c ip)) nil) (deftest imagpart.3 (loop for x in *reals* - for c = (complex x x) - for ip = (imagpart c) - unless (eql x ip) - collect (list x c ip)) + for c = (complex x x) + for ip = (imagpart c) + unless (eql x ip) + collect (list x c ip)) nil) (deftest imagpart.4 (loop for x in *reals* - for ip = (imagpart x) - unless (eql (* 0 x) ip) - collect (list x ip (* 0 x))) + for ip = (imagpart x) + unless (eql (* 0 x) ip) + collect (list x ip (* 0 x))) nil) diff --git a/ansi-tests/import.lsp b/ansi-tests/import.lsp index 8edbe2f2..43dabf51 100644 --- a/ansi-tests/import.lsp +++ b/ansi-tests/import.lsp @@ -11,14 +11,14 @@ ;;; name or nickname (defvar *import-package-test-name* (loop for i from 1 - for name = (format nil "ITP-~A" i) - unless (find-package name) return name)) + for name = (format nil "ITP-~A" i) + unless (find-package name) return name)) (deftest import.1 (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) + (sym 'foo)) (values (multiple-value-list (import sym pkg)) (eqlt (find-symbol (symbol-name sym) pkg) sym) @@ -31,7 +31,7 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) + (sym 'foo)) (values (multiple-value-list (import (list sym) pkg)) (eqlt (find-symbol (symbol-name sym) pkg) sym) @@ -44,7 +44,7 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((*package* (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) + (sym 'foo)) (values (multiple-value-list (import sym)) (eqlt (find-symbol (symbol-name sym)) sym) @@ -57,13 +57,13 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (syms '(foo bar baz))) + (syms '(foo bar baz))) (values (multiple-value-list (import syms pkg)) (loop for sym in syms always - (eqlt (find-symbol (symbol-name sym) pkg) sym)) + (eqlt (find-symbol (symbol-name sym) pkg) sym)) (loop for sym in syms always - (eqlt (symbol-package sym) (find-package :cl-test))) + (eqlt (symbol-package sym) (find-package :cl-test))) (external-symbols-in-package pkg) ))) (t) t t nil) @@ -72,7 +72,7 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym (make-symbol (symbol-name :foo)))) + (sym (make-symbol (symbol-name :foo)))) (values (multiple-value-list (import sym pkg)) (eqlt (symbol-package sym) pkg) @@ -85,7 +85,7 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym (intern (symbol-name :foo) pkg))) + (sym (intern (symbol-name :foo) pkg))) (values (multiple-value-list (import sym pkg)) (eqlt (symbol-package sym) pkg) @@ -98,7 +98,7 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use) (:export #:foo)))) - (sym (intern (symbol-name :foo) pkg))) + (sym (intern (symbol-name :foo) pkg))) (values (multiple-value-list (import sym pkg)) (eqlt (symbol-package sym) pkg) @@ -112,7 +112,7 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) + (sym 'foo)) (values (multiple-value-list (import sym pkg-name)) (eqlt (find-symbol (symbol-name sym) pkg) sym) @@ -125,7 +125,7 @@ (let ((pkg-name "Z")) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) + (sym 'foo)) (values (multiple-value-list (import sym #\Z)) (eqlt (find-symbol (symbol-name sym) pkg) sym) @@ -138,11 +138,11 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) + (sym 'foo)) (values (let ((pname (make-array (length pkg-name) :element-type 'base-char - :initial-contents pkg-name))) - (multiple-value-list (import sym pname))) + :initial-contents pkg-name))) + (multiple-value-list (import sym pname))) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) @@ -153,13 +153,13 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) + (sym 'foo)) (values (let ((pname (make-array (+ 3 (length pkg-name)) - :element-type 'base-char - :fill-pointer (length pkg-name) - :initial-contents (concatenate 'string pkg-name "XYZ")))) - (multiple-value-list (import sym pname))) + :element-type 'base-char + :fill-pointer (length pkg-name) + :initial-contents (concatenate 'string pkg-name "XYZ")))) + (multiple-value-list (import sym pname))) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) @@ -170,16 +170,16 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo)) + (sym 'foo)) (values (let* ((pname0 (make-array (+ 4 (length pkg-name)) - :element-type 'base-char - :fill-pointer (length pkg-name) - :initial-contents (concatenate 'string " " pkg-name "XY"))) - (pname (make-array (length pkg-name) :element-type 'base-char - :displaced-to pname0 - :displaced-index-offset 2))) - (multiple-value-list (import sym pname))) + :element-type 'base-char + :fill-pointer (length pkg-name) + :initial-contents (concatenate 'string " " pkg-name "XY"))) + (pname (make-array (length pkg-name) :element-type 'base-char + :displaced-to pname0 + :displaced-index-offset 2))) + (multiple-value-list (import sym pname))) (eqlt (find-symbol (symbol-name sym) pkg) sym) (eqlt (symbol-package sym) (find-package :cl-test)) (external-symbols-in-package pkg) @@ -203,8 +203,8 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo) - (name (symbol-name sym))) + (sym 'foo) + (name (symbol-name sym))) (intern name pkg) (import sym pkg))) package-error) @@ -214,31 +214,31 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo) - (name (symbol-name sym)) - (isym (intern name pkg)) - (outer-restarts (compute-restarts))) + (sym 'foo) + (name (symbol-name sym)) + (isym (intern name pkg)) + (outer-restarts (compute-restarts))) (block done - (and - (handler-bind - ((package-error - #'(lambda (c) - ;; There should be at least one restart - ;; associated with this condition that was - ;; not a preexisting restart - (let ((my-restarts - (remove 'abort - (set-difference (compute-restarts c) - outer-restarts) - :key #'restart-name))) - (assert my-restarts) - ; (unintern isym pkg) - ; (when (find 'continue my-restarts :key #'restart-name) (continue c)) - (return-from done :good))))) - (import sym pkg)) - (eqlt (find-symbol name pkg) sym) - (eqlt (symbol-package sym) (find-package "CL-TEST")) - :good)))) + (and + (handler-bind + ((package-error + #'(lambda (c) + ;; There should be at least one restart + ;; associated with this condition that was + ;; not a preexisting restart + (let ((my-restarts + (remove 'abort + (set-difference (compute-restarts c) + outer-restarts) + :key #'restart-name))) + (assert my-restarts) + ; (unintern isym pkg) + ; (when (find 'continue my-restarts :key #'restart-name) (continue c)) + (return-from done :good))))) + (import sym pkg)) + (eqlt (find-symbol name pkg) sym) + (eqlt (symbol-package sym) (find-package "CL-TEST")) + :good)))) :good) @@ -246,29 +246,29 @@ (let ((pkg-name *import-package-test-name*)) (safely-delete-package pkg-name) (let* ((pkg (eval `(defpackage ,pkg-name (:use)))) - (sym 'foo) - (name (symbol-name sym)) - (isym (shadow name pkg)) ;; shadow instead of intern - (outer-restarts (compute-restarts))) + (sym 'foo) + (name (symbol-name sym)) + (isym (shadow name pkg)) ;; shadow instead of intern + (outer-restarts (compute-restarts))) (block done - (and - (handler-bind - ((package-error - #'(lambda (c) - ;; There should be at least one restart - ;; associated with this condition that was - ;; not a preexisting restart - (let ((my-restarts - (remove 'abort - (set-difference (compute-restarts c) - outer-restarts) - :key #'restart-name))) - (assert my-restarts) - ; (unintern isym pkg) - ; (when (find 'continue my-restarts :key #'restart-name) (continue c)) - (return-from done :good))))) - (import sym pkg)) - (eqlt (find-symbol name pkg) sym) - (eqlt (symbol-package sym) (find-package "CL-TEST")) - :good)))) + (and + (handler-bind + ((package-error + #'(lambda (c) + ;; There should be at least one restart + ;; associated with this condition that was + ;; not a preexisting restart + (let ((my-restarts + (remove 'abort + (set-difference (compute-restarts c) + outer-restarts) + :key #'restart-name))) + (assert my-restarts) + ; (unintern isym pkg) + ; (when (find 'continue my-restarts :key #'restart-name) (continue c)) + (return-from done :good))))) + (import sym pkg)) + (eqlt (find-symbol name pkg) sym) + (eqlt (symbol-package sym) (find-package "CL-TEST")) + :good)))) :good) diff --git a/ansi-tests/in-package.lsp b/ansi-tests/in-package.lsp index 52fc375b..3f80093d 100644 --- a/ansi-tests/in-package.lsp +++ b/ansi-tests/in-package.lsp @@ -15,7 +15,7 @@ (make-package "H" :use ()) (let ((p2 (in-package "H"))) (and (eqt p2 (find-package "H")) - (eqt *package* p2)))) + (eqt *package* p2)))) t) (deftest in-package.2 @@ -24,7 +24,7 @@ (make-package "H" :use ()) (let ((p2 (in-package |H|))) (and (eqt p2 (find-package "H")) - (eqt *package* p2)))) + (eqt *package* p2)))) t) (deftest in-package.3 @@ -33,7 +33,7 @@ (make-package "H" :use ()) (let ((p2 (in-package :|H|))) (and (eqt p2 (find-package "H")) - (eqt *package* p2)))) + (eqt *package* p2)))) t) (deftest in-package.4 @@ -42,7 +42,7 @@ (make-package "H" :use ()) (let ((p2 (in-package #\H))) (and (eqt p2 (find-package "H")) - (eqt *package* p2)))) + (eqt *package* p2)))) t) (deftest in-package.5 @@ -62,12 +62,12 @@ (let ((name ,name-form)) (safely-delete-package name) (prog1 - (let* ((p (make-package name :use nil)) - (*package* *package*) - (p2 (eval `(in-package ,name)))) - (list (eqt p p2) - (eqt p *package*))) - (safely-delete-package name))) + (let* ((p (make-package name :use nil)) + (*package* *package*) + (p2 (eval `(in-package ,name)))) + (list (eqt p p2) + (eqt p *package*))) + (safely-delete-package name))) (t t))) (def-in-package-test in-package.7 @@ -75,32 +75,32 @@ (def-in-package-test in-package.8 (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) + :fill-pointer 5 :element-type 'base-char)) (def-in-package-test in-package.9 (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) + :fill-pointer 5 :element-type 'character)) (def-in-package-test in-package.10 (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) + :adjustable t :element-type 'base-char)) (def-in-package-test in-package.11 (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) + :adjustable t :element-type 'character)) (def-in-package-test in-package.12 (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + :displaced-to name0 + :displaced-index-offset 5))) (def-in-package-test in-package.13 (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) \ No newline at end of file + :displaced-to name0 + :displaced-index-offset 5))) diff --git a/ansi-tests/incf.lsp b/ansi-tests/incf.lsp index fbe79eab..427d4001 100644 --- a/ansi-tests/incf.lsp +++ b/ansi-tests/incf.lsp @@ -44,23 +44,23 @@ (deftest incf.6 (loop for x from 1 to 5 - collect (let ((y x)) - (list (incf y) y))) + collect (let ((y x)) + (list (incf y) y))) ((2 2) (3 3) (4 4) (5 5) (6 6))) (deftest incf.7 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - collect (let ((y x)) - (list (incf y) y))) + collect (let ((y x)) + (list (incf y) y))) ((2.0s0 2.0s0) (2.0f0 2.0f0) (2.0d0 2.0d0) (2.0l0 2.0l0))) (deftest incf.8 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0f0) - for y = (complex x 0) - for z = (incf y) - for x1c = (complex (1+ x) 0) - unless (and (eql y z) (eql x1c y)) - collect (list x y z x1c)) + for y = (complex x 0) + for z = (incf y) + for x1c = (complex (1+ x) 0) + unless (and (eql y z) (eql x1c y)) + collect (list x y z x1c)) nil) (deftest incf.9 @@ -75,31 +75,31 @@ (deftest incf.11 (loop for x in *numbers* - unless (let* ((y x) - (z (incf y))) - (and (eql y (1+ x)) - (eql y z))) - collect x) + unless (let* ((y x) + (z (incf y))) + (and (eql y (1+ x)) + (eql y z))) + collect x) nil) ;;; Increment by other than 1 (deftest incf.12 (loop for x in *numbers* - unless (let* ((y x) (z (incf y 0))) - (and (eql x y) (eql y z))) - collect x) + unless (let* ((y x) (z (incf y 0))) + (and (eql x y) (eql y z))) + collect x) nil) (deftest incf.13 (loop for x in *numbers* - nconc - (loop for r = (random-from-interval 1000000) - repeat 100 - when (let* ((y x) (z (incf y r))) - (and (not (and (eql (+ x r) y) (eql y z))) - (list x y r))) - collect it)) + nconc + (loop for r = (random-from-interval 1000000) + repeat 100 + when (let* ((y x) (z (incf y r))) + (and (not (and (eql (+ x r) y) (eql y z))) + (list x y r))) + collect it)) nil) (deftest incf.14 @@ -165,20 +165,20 @@ (deftest incf.order.2 (let ((a (vector 1 2 3 4)) - (i 0) x y z) + (i 0) x y z) (values (incf (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 0)) - (progn (setf z (incf i)) 17)) + (progn (setf y (incf i)) 0)) + (progn (setf z (incf i)) 17)) i x y z a)) 18 3 1 2 3 #(18 2 3 4)) (deftest incf.order.3 (let ((a (vector 10 2 3 4)) - (i 0) x y) + (i 0) x y) (values (incf (aref (progn (setf x (incf i)) a) - (progn (setf y (incf i)) 0))) + (progn (setf y (incf i)) 0))) i x y a)) 11 2 1 2 #(11 2 3 4)) diff --git a/ansi-tests/input-stream-p.lsp b/ansi-tests/input-stream-p.lsp index ca5f1d0a..bddc96a7 100644 --- a/ansi-tests/input-stream-p.lsp +++ b/ansi-tests/input-stream-p.lsp @@ -15,13 +15,13 @@ (deftest input-stream-p.3 (with-open-file (s "input-stream-p.lsp" :direction :input) - (notnot-mv (input-stream-p s))) + (notnot-mv (input-stream-p s))) t) (deftest input-stream-p.4 (with-open-file (s "foo.txt" :direction :output - :if-exists :supersede) - (input-stream-p s)) + :if-exists :supersede) + (input-stream-p s)) nil) ;;; Error tests @@ -32,7 +32,7 @@ (deftest input-stream-p.error.2 (signals-error (input-stream-p *standard-input* nil) - program-error) + program-error) t) (deftest input-stream-p.error.3 diff --git a/ansi-tests/integer-length.lsp b/ansi-tests/integer-length.lsp index 27b8a2aa..075e800b 100644 --- a/ansi-tests/integer-length.lsp +++ b/ansi-tests/integer-length.lsp @@ -23,36 +23,36 @@ (deftest integer-length.1 (loop for len from 0 to 100 - for i = (1- (ash 1 len)) - for vals = (multiple-value-list (integer-length i)) - for len2 = (car vals) - always (and (= (length vals) 1) - (eql len len2))) + for i = (1- (ash 1 len)) + for vals = (multiple-value-list (integer-length i)) + for len2 = (car vals) + always (and (= (length vals) 1) + (eql len len2))) t) (deftest integer-length.2 (loop for len from 0 to 100 - for i = (ash 1 len) - for vals = (multiple-value-list (integer-length i)) - for len2 = (car vals) - always (and (= (length vals) 1) - (eql (1+ len) len2))) + for i = (ash 1 len) + for vals = (multiple-value-list (integer-length i)) + for len2 = (car vals) + always (and (= (length vals) 1) + (eql (1+ len) len2))) t) (deftest integer-length.3 (loop for len from 0 to 100 - for i = (- (ash 1 len)) - for vals = (multiple-value-list (integer-length i)) - for len2 = (car vals) - always (and (= (length vals) 1) - (eql len len2))) + for i = (- (ash 1 len)) + for vals = (multiple-value-list (integer-length i)) + for len2 = (car vals) + always (and (= (length vals) 1) + (eql len len2))) t) (deftest integer-length.4 (loop for len from 0 to 100 - for i = (- -1 (ash 1 len)) - for vals = (multiple-value-list (integer-length i)) - for len2 = (car vals) - always (and (= (length vals) 1) - (eql (1+ len) len2))) + for i = (- -1 (ash 1 len)) + for vals = (multiple-value-list (integer-length i)) + for len2 = (car vals) + always (and (= (length vals) 1) + (eql (1+ len) len2))) t) diff --git a/ansi-tests/integerp.lsp b/ansi-tests/integerp.lsp index 6a0c678a..9e3350e9 100644 --- a/ansi-tests/integerp.lsp +++ b/ansi-tests/integerp.lsp @@ -19,10 +19,10 @@ (deftest integerp.1 (loop for i in *integers* - for vals = (multiple-value-list (integerp i)) - unless (and (= (length vals) 1) - (first vals)) - collect (cons i vals)) + for vals = (multiple-value-list (integerp i)) + unless (and (= (length vals) 1) + (first vals)) + collect (cons i vals)) nil) (deftest integerp.2 diff --git a/ansi-tests/interactive-stream-p.lsp b/ansi-tests/interactive-stream-p.lsp index e29cb0f1..2b497d77 100644 --- a/ansi-tests/interactive-stream-p.lsp +++ b/ansi-tests/interactive-stream-p.lsp @@ -7,8 +7,8 @@ (deftest interactive-stream-p.1 (let ((streams (list *debug-io* *error-output* *query-io* - *standard-input* *standard-output* - *trace-output* *terminal-io*))) + *standard-input* *standard-output* + *trace-output* *terminal-io*))) (mapc #'interactive-stream-p streams) ;; no error should occur nil) @@ -24,5 +24,5 @@ (deftest interactive-stream-p.error.3 (signals-error (interactive-stream-p *terminal-io* nil) - program-error) + program-error) t) diff --git a/ansi-tests/intern.lsp b/ansi-tests/intern.lsp index 7f5bd0fe..dd85da9a 100644 --- a/ansi-tests/intern.lsp +++ b/ansi-tests/intern.lsp @@ -13,22 +13,22 @@ (progn (safely-delete-package "TEMP1") (let ((p (make-package "TEMP1" :use nil)) - (i 0) x y) + (i 0) x y) (multiple-value-bind* (sym1 status1) - (find-symbol "FOO" p) - (intern (progn (setf x (incf i)) "FOO") - (progn (setf y (incf i)) p)) - (multiple-value-bind* (sym2 status2) - (find-symbol "FOO" p) - (and (eql i 2) - (eql x 1) - (eql y 2) - (null sym1) - (null status1) - (string= (symbol-name sym2) "FOO") - (eqt (symbol-package sym2) p) - (eqt status2 :internal) - (progn (delete-package p) t)))))) + (find-symbol "FOO" p) + (intern (progn (setf x (incf i)) "FOO") + (progn (setf y (incf i)) p)) + (multiple-value-bind* (sym2 status2) + (find-symbol "FOO" p) + (and (eql i 2) + (eql x 1) + (eql y 2) + (null sym1) + (null status1) + (string= (symbol-name sym2) "FOO") + (eqt (symbol-package sym2) p) + (eqt status2 :internal) + (progn (delete-package p) t)))))) t) (deftest intern.2 @@ -36,136 +36,136 @@ (safely-delete-package "TEMP1") (let ((p (make-package "TEMP1" :use nil))) (multiple-value-bind* (sym1 status1) - (find-symbol "FOO" "TEMP1") - (intern "FOO" "TEMP1") - (multiple-value-bind* (sym2 status2) - (find-symbol "FOO" p) - (and (null sym1) - (null status1) - (string= (symbol-name sym2) "FOO") - (eqt (symbol-package sym2) p) - (eqt status2 :internal) - (progn (delete-package p) t)))))) + (find-symbol "FOO" "TEMP1") + (intern "FOO" "TEMP1") + (multiple-value-bind* (sym2 status2) + (find-symbol "FOO" p) + (and (null sym1) + (null status1) + (string= (symbol-name sym2) "FOO") + (eqt (symbol-package sym2) p) + (eqt status2 :internal) + (progn (delete-package p) t)))))) t) (deftest intern.3 :notes (:nil-vectors-are-strings) (let ((cl-user-package (find-package "CL-USER"))) (eqt (intern "" cl-user-package) - (intern (make-array 0 :element-type nil) cl-user-package))) + (intern (make-array 0 :element-type nil) cl-user-package))) t) (deftest intern.4 (let ((cl-user-package (find-package "CL-USER"))) (eqt (intern (make-array 5 :element-type 'character - :initial-contents "XYZZY") cl-user-package) - (intern (make-array 5 :element-type 'base-char - :initial-contents "XYZZY") cl-user-package))) + :initial-contents "XYZZY") cl-user-package) + (intern (make-array 5 :element-type 'base-char + :initial-contents "XYZZY") cl-user-package))) t) ;;; String is a specialized sequence type (defmacro def-intern-test (test-name &key (symbol-name "FOO") - (package-name "TEMP1")) + (package-name "TEMP1")) `(deftest ,test-name (let ((sname ,symbol-name) - (pname ,package-name)) + (pname ,package-name)) (safely-delete-package pname) (let ((p (make-package pname :use nil))) - (multiple-value-bind* - (sym1 status1) - (find-symbol sname pname) - (intern sname pname) - (multiple-value-bind* - (sym2 status2) - (find-symbol sname p) - (and (null sym1) - (null status1) - (string= (symbol-name sym2) sname) - (eqt (symbol-package sym2) p) - (eqt status2 :internal) - (progn (delete-package p) t)))))) + (multiple-value-bind* + (sym1 status1) + (find-symbol sname pname) + (intern sname pname) + (multiple-value-bind* + (sym2 status2) + (find-symbol sname p) + (and (null sym1) + (null status1) + (string= (symbol-name sym2) sname) + (eqt (symbol-package sym2) p) + (eqt status2 :internal) + (progn (delete-package p) t)))))) t)) (def-intern-test intern.5 :symbol-name (make-array 3 :element-type 'base-char - :initial-contents "BAR")) + :initial-contents "BAR")) (def-intern-test intern.6 :symbol-name (make-array 13 :element-type 'base-char - :fill-pointer 3 - :initial-contents "BAR1234567890")) + :fill-pointer 3 + :initial-contents "BAR1234567890")) (def-intern-test intern.7 :symbol-name (make-array 13 :element-type 'character - :fill-pointer 3 - :initial-contents "BAR1234567890")) + :fill-pointer 3 + :initial-contents "BAR1234567890")) (def-intern-test intern.8 :symbol-name (make-array 3 :element-type 'base-char - :adjustable t - :initial-contents "BAR")) + :adjustable t + :initial-contents "BAR")) (def-intern-test intern.9 :symbol-name (make-array 3 :element-type 'character - :adjustable t - :initial-contents "BAR")) + :adjustable t + :initial-contents "BAR")) (def-intern-test intern.10 :symbol-name (let* ((etype 'base-char) - (name0 (make-array 8 :element-type etype - :initial-contents "XBARYYYY"))) + (name0 (make-array 8 :element-type etype + :initial-contents "XBARYYYY"))) (make-array 3 :element-type etype :displaced-to name0 - :displaced-index-offset 1))) + :displaced-index-offset 1))) (def-intern-test intern.11 :symbol-name (let* ((etype 'character) - (name0 (make-array 8 :element-type etype - :initial-contents "XBARYYYY"))) + (name0 (make-array 8 :element-type etype + :initial-contents "XBARYYYY"))) (make-array 3 :element-type etype :displaced-to name0 - :displaced-index-offset 1))) + :displaced-index-offset 1))) (def-intern-test intern.12 :package-name (make-array 3 :element-type 'base-char - :initial-contents "BAR")) + :initial-contents "BAR")) (def-intern-test intern.13 :package-name (make-array 13 :element-type 'base-char - :fill-pointer 3 - :initial-contents "BAR1234567890")) + :fill-pointer 3 + :initial-contents "BAR1234567890")) (def-intern-test intern.14 :package-name (make-array 13 :element-type 'character - :fill-pointer 3 - :initial-contents "BAR1234567890")) + :fill-pointer 3 + :initial-contents "BAR1234567890")) (def-intern-test intern.15 :package-name (make-array 3 :element-type 'base-char - :adjustable t - :initial-contents "BAR")) + :adjustable t + :initial-contents "BAR")) (def-intern-test intern.16 :package-name (make-array 3 :element-type 'character - :adjustable t - :initial-contents "BAR")) + :adjustable t + :initial-contents "BAR")) (def-intern-test intern.17 :package-name (let* ((etype 'base-char) - (name0 (make-array 8 :element-type etype - :initial-contents "XBARYYYY"))) + (name0 (make-array 8 :element-type etype + :initial-contents "XBARYYYY"))) (make-array 3 :element-type etype :displaced-to name0 - :displaced-index-offset 1))) + :displaced-index-offset 1))) (def-intern-test intern.18 :package-name (let* ((etype 'character) - (name0 (make-array 8 :element-type etype - :initial-contents "XBARYYYY"))) + (name0 (make-array 8 :element-type etype + :initial-contents "XBARYYYY"))) (make-array 3 :element-type etype :displaced-to name0 - :displaced-index-offset 1))) + :displaced-index-offset 1))) ;;; Error tests diff --git a/ansi-tests/intersection.lsp b/ansi-tests/intersection.lsp index 2c76fb42..574a405a 100644 --- a/ansi-tests/intersection.lsp +++ b/ansi-tests/intersection.lsp @@ -21,10 +21,10 @@ (deftest intersection.4 (let* ((x (copy-list '(a 1 c 7 b 4 3 z))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(3 y c q z a 18))) - (ycopy (make-scaffold-copy y)) - (result (intersection x y))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(3 y c q z a 18))) + (ycopy (make-scaffold-copy y)) + (result (intersection x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) @@ -32,23 +32,23 @@ (loop for e in x count (and (member e y) - (not (member e result)))) + (not (member e result)))) (loop for e in result count (or (not (member e x)) - (not (member e y)))) + (not (member e y)))) (loop for hd on result count (and (consp hd) - (member (car hd) (cdr hd))))))) + (member (car hd) (cdr hd))))))) 0) (deftest intersection.5 (let* ((x (copy-list '(a a a))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(a a a b b b))) - (ycopy (make-scaffold-copy y)) - (result (intersection x y))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(a a a b b b))) + (ycopy (make-scaffold-copy y)) + (result (intersection x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) @@ -58,47 +58,47 @@ (deftest intersection.6 (intersection (list 1000000000000 'a 'b 'c) - (list (1+ 999999999999) 'd 'e 'f)) + (list (1+ 999999999999) 'd 'e 'f)) (1000000000000)) (deftest intersection.7 (intersection (list 'a 10 'b 17) - (list 'c 'd 4 'e 'f 10 1 13 'z)) + (list 'c 'd 4 'e 'f 10 1 13 'z)) (10)) (deftest intersection.8 (intersection (list 'a (copy-seq "aaa") 'b) - (list 'd (copy-seq "aaa") 'e)) + (list 'd (copy-seq "aaa") 'e)) nil) (deftest intersection.9 (intersection (list 'a (copy-seq "aaa") 'b) - (list 'd (copy-seq "aaa") 'e) - :test #'equal) + (list 'd (copy-seq "aaa") 'e) + :test #'equal) ("aaa")) ;; Same as 9, but with a symbol function designator for :test (deftest intersection.9-a (intersection (list 'a (copy-seq "aaa") 'b) - (list 'd (copy-seq "aaa") 'e) - :test 'equal) + (list 'd (copy-seq "aaa") 'e) + :test 'equal) ("aaa")) (deftest intersection.9-b (intersection (list 'a (copy-seq "aaa") 'b) - (list 'd (copy-seq "aaa") 'e) - :test-not #'(lambda (p q) (not (equal p q)))) + (list 'd (copy-seq "aaa") 'e) + :test-not #'(lambda (p q) (not (equal p q)))) ("aaa")) (deftest intersection.10 (equalt (sort (intersection (loop - for i from 0 to 1000 by 3 - collect i) - (loop - for i from 0 to 1000 by 7 - collect i)) + for i from 0 to 1000 by 3 + collect i) + (loop + for i from 0 to 1000 by 7 + collect i)) #'<) (loop for i from 0 to 1000 by 21 collect i)) t) @@ -107,14 +107,14 @@ (equalt (sort (intersection (loop - for i from 0 to 999 by 5 - collect i) - (loop - for i from 0 to 999 by 7 - collect i) - :test #'(lambda (a b) - (and (eql a b) - (= (mod a 3) 0)))) + for i from 0 to 999 by 5 + collect i) + (loop + for i from 0 to 999 by 7 + collect i) + :test #'(lambda (a b) + (and (eql a b) + (= (mod a 3) 0)))) #'<) (loop for i from 0 to 999 by (* 3 5 7) collect i)) t) @@ -123,15 +123,15 @@ (equalt (sort (intersection (loop - for i from 0 to 999 by 5 - collect i) - (loop - for i from 0 to 999 by 7 - collect i) - :test-not - #'(lambda (a b) - (not (and (eql a b) - (= (mod a 3) 0))))) + for i from 0 to 999 by 5 + collect i) + (loop + for i from 0 to 999 by 7 + collect i) + :test-not + #'(lambda (a b) + (not (and (eql a b) + (= (mod a 3) 0))))) #'<) (loop for i from 0 to 999 by (* 3 5 7) collect i)) t) @@ -151,7 +151,7 @@ (deftest intersection.13 (let ((x (copy-list '(0 5 8 13 31 42))) - (y (copy-list '(3 5 42 0 7 100 312 33)))) + (y (copy-list '(3 5 42 0 7 100 312 33)))) (equalt (sort (copy-list (intersection x y)) #'<) (sort (copy-list (intersection x y :key #'1+)) #'<))) @@ -160,7 +160,7 @@ ;; Same as 13, but with a symbol function designator for :key (deftest intersection.13-a (let ((x (copy-list '(0 5 8 13 31 42))) - (y (copy-list '(3 5 42 0 7 100 312 33)))) + (y (copy-list '(3 5 42 0 7 100 312 33)))) (equalt (sort (copy-list (intersection x y)) #'<) (sort (copy-list (intersection x y :key '1+)) #'<))) @@ -171,8 +171,8 @@ (deftest intersection.14 (let ((result (intersection (copy-list '(a b c d)) - (copy-list '(e c f b g)) - :key nil))) + (copy-list '(e c f b g)) + :key nil))) (and (member 'b result) (member 'c result) @@ -184,52 +184,52 @@ (deftest intersection.15 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (block fail (intersection list1 list2 :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))))) + (when (< y x) (return-from fail 'fail)) + (eql x y))))) (4)) (deftest intersection.16 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (block fail (intersection list1 list2 :key #'identity :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))))) + (when (< y x) (return-from fail 'fail)) + (eql x y))))) (4)) (deftest intersection.17 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (block fail (intersection list1 list2 :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))))) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))))) (4)) (deftest intersection.18 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (block fail (intersection list1 list2 :key #'identity :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))))) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))))) (4)) (defharmless intersection.test-and-test-not.1 @@ -244,7 +244,7 @@ (let ((i 0) x y) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd))) + (progn (setf y (incf i)) (list 'c 'd))) i x y)) nil 2 1 2) @@ -252,8 +252,8 @@ (let ((i 0) x y) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test #'eq) + (progn (setf y (incf i)) (list 'c 'd)) + :test #'eq) i x y)) nil 2 1 2) @@ -261,10 +261,10 @@ (let ((i 0) x y z w) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test (progn (setf z (incf i)) #'eq) - :test (progn (setf w (incf i)) - (complement #'eq))) + (progn (setf y (incf i)) (list 'c 'd)) + :test (progn (setf z (incf i)) #'eq) + :test (progn (setf w (incf i)) + (complement #'eq))) i x y z w)) nil 4 1 2 3 4) @@ -272,9 +272,9 @@ (let ((i 0) x y z w) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test (progn (setf z (incf i)) #'eq) - :key (progn (setf w (incf i)) #'identity)) + (progn (setf y (incf i)) (list 'c 'd)) + :test (progn (setf z (incf i)) #'eq) + :key (progn (setf w (incf i)) #'identity)) i x y z w)) nil 4 1 2 3 4) @@ -282,9 +282,9 @@ (let ((i 0) x y z w) (values (intersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf w (incf i)) #'eq)) + (progn (setf y (incf i)) (list 'c 'd)) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf w (incf i)) #'eq)) i x y z w)) nil 4 1 2 3 4) @@ -293,59 +293,59 @@ (deftest intersection.allow-other-keys.1 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (intersection list1 list2 :bad t :allow-other-keys 1)) (4)) (deftest intersection.allow-other-keys.2 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys :foo :also-bad t)) (4)) (deftest intersectionallow-other-keys.3 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys :foo :also-bad t - :test #'(lambda (x y) (= x (1+ y))))) + :test #'(lambda (x y) (= x (1+ y))))) nil) (deftest intersection.allow-other-keys.4 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys t)) (4)) (deftest intersection.allow-other-keys.5 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys nil)) (4)) (deftest intersection.allow-other-keys.6 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys t - :allow-other-keys nil :bad t)) + :allow-other-keys nil :bad t)) (4)) (deftest intersection.allow-other-keys.7 (sort (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (intersection list1 list2 :allow-other-keys t - :allow-other-keys nil - :test #'(lambda (x y) (eql x (1- y))))) + :allow-other-keys nil + :test #'(lambda (x y) (eql x (1- y))))) #'<) (3 4)) (deftest intersection.keywords.8 (sort (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (intersection list1 list2 - :test #'(lambda (x y) (eql x (1- y))) - :test #'eql)) + :test #'(lambda (x y) (eql x (1- y))) + :test #'eql)) #'<) (3 4)) @@ -375,37 +375,37 @@ (deftest intersection.error.6 (signals-error (intersection nil nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest intersection.error.7 (signals-error (intersection '(a b c) '(d e f) :test #'identity) - program-error) + program-error) t) (deftest intersection.error.8 (signals-error (intersection '(a b c) '(d e f) :test-not #'identity) - program-error) + program-error) t) (deftest intersection.error.9 (signals-error (intersection '(a b c) '(d e f) :key #'cons) - program-error) + program-error) t) (deftest intersection.error.10 (signals-error (intersection '(a b c) '(d e f) :key #'car) - type-error) + type-error) t) (deftest intersection.error.11 (signals-error (intersection '(a b c) '(d e f . g)) - type-error) + type-error) t) (deftest intersection.error.12 (signals-error (intersection '(a b . c) '(d e f)) - type-error) + type-error) t) (deftest intersection.error.13 @@ -414,4 +414,4 @@ (deftest intersection.error.14 (check-type-error #'(lambda (x) (intersection '(a b c) x)) #'listp) - nil) \ No newline at end of file + nil) diff --git a/ansi-tests/invoke-debugger.lsp b/ansi-tests/invoke-debugger.lsp index 32680365..5a7655b0 100644 --- a/ansi-tests/invoke-debugger.lsp +++ b/ansi-tests/invoke-debugger.lsp @@ -12,13 +12,13 @@ (block done (let (fn (cnd (make-condition 'simple-error))) (setq fn #'(lambda (c hook) - (return-from done - (and (null *debugger-hook*) - (eqt hook fn) - (eqt cnd c) - 'good)))) + (return-from done + (and (null *debugger-hook*) + (eqt hook fn) + (eqt cnd c) + 'good)))) (let ((*debugger-hook* fn)) - (invoke-debugger cnd))) + (invoke-debugger cnd))) 'bad) good) @@ -26,8 +26,8 @@ (signals-error (block done (let ((*debugger-hook* #'(lambda (&rest args) - (declare (ignore args)) - (return-from done 'bad)))) + (declare (ignore args)) + (return-from done 'bad)))) (invoke-debugger))) program-error) t) @@ -36,8 +36,8 @@ (signals-error (block done (let ((*debugger-hook* #'(lambda (&rest args) - (declare (ignore args)) - (return-from done 'bad)))) + (declare (ignore args)) + (return-from done 'bad)))) (invoke-debugger (make-condition 'simple-error) nil))) program-error) t) diff --git a/ansi-tests/isqrt.lsp b/ansi-tests/isqrt.lsp index e1b7dcfb..eb3f6617 100644 --- a/ansi-tests/isqrt.lsp +++ b/ansi-tests/isqrt.lsp @@ -27,39 +27,39 @@ (deftest isqrt.error.5 (loop for x in *mini-universe* - unless (or (and (integerp x) (>= x 0)) - (eval `(signals-type-error x ',x (isqrt x)))) - collect x) + unless (or (and (integerp x) (>= x 0)) + (eval `(signals-type-error x ',x (isqrt x)))) + collect x) nil) ;;; Non-error tests (deftest isqrt.1 (loop for i from 0 to 10000 - for i2 = (* i i) - for s = (isqrt i2) - unless (eql s i) - collect i) + for i2 = (* i i) + for s = (isqrt i2) + unless (eql s i) + collect i) nil) (deftest isqrt.2 (loop for i = (random-from-interval most-positive-fixnum 0) - for s = (isqrt i) - repeat 1000 - unless (and (integerp s) - (>= s 0) - (<= (* s s) i) - (> (* (1+ s) (1+ s)) i)) - collect (list i s)) + for s = (isqrt i) + repeat 1000 + unless (and (integerp s) + (>= s 0) + (<= (* s s) i) + (> (* (1+ s) (1+ s)) i)) + collect (list i s)) nil) (deftest isqrt.3 (loop for i = (random-from-interval 1000000000000000 0) - for s = (isqrt i) - repeat 1000 - unless (and (integerp s) - (>= s 0) - (<= (* s s) i) - (> (* (1+ s) (1+ s)) i)) - collect (list i s)) + for s = (isqrt i) + repeat 1000 + unless (and (integerp s) + (>= s 0) + (<= (* s s) i) + (> (* (1+ s) (1+ s)) i)) + collect (list i s)) nil) diff --git a/ansi-tests/keyword.lsp b/ansi-tests/keyword.lsp index 3a66f125..cbc23ab6 100644 --- a/ansi-tests/keyword.lsp +++ b/ansi-tests/keyword.lsp @@ -30,7 +30,7 @@ #| (deftest keyword.4 (let ((name "SYMBOL-NAME-FOR-KEYWORD.4") - (kwp (find-package "KEYWORD"))) + (kwp (find-package "KEYWORD"))) (let ((s (find-symbol name kwp))) (when s (unintern s kwp)) ;; Now, create a symbol with this name @@ -49,11 +49,11 @@ (deftest keyword.5 (let* ((name "SYMBOL-NAME-FOR-KEYWORD.5") - (pkg-name "PACKAGE-FOR-KEYWORD.5") - (kwp (find-package "KEYWORD"))) + (pkg-name "PACKAGE-FOR-KEYWORD.5") + (kwp (find-package "KEYWORD"))) (safely-delete-package pkg-name) (let* ((pkg (make-package pkg-name :use nil)) - (s (find-symbol name kwp))) + (s (find-symbol name kwp))) (when s (unintern s kwp)) ;; Now, create a symbol with this name ;; and import it into the keyword package @@ -71,12 +71,12 @@ (deftest keyword.6 (let* ((name "SYMBOL-NAME-FOR-KEYWORD.6") - (pkg-name "PACKAGE-FOR-KEYWORD.6") - (kwp (find-package "KEYWORD"))) + (pkg-name "PACKAGE-FOR-KEYWORD.6") + (kwp (find-package "KEYWORD"))) (safely-delete-package pkg-name) (let* ((pkg (make-package pkg-name :use nil)) - (s (find-symbol name kwp)) - s2) + (s (find-symbol name kwp)) + s2) (when s (unintern s kwp)) ;; Recreate a symbol with this name in the keyword package ;; shadowing-import will displace this symbol @@ -107,10 +107,10 @@ (deftest keyword.2 (do-symbols (s "KEYWORD" t) (multiple-value-bind (s2 access) - (find-symbol (symbol-name s) "KEYWORD") + (find-symbol (symbol-name s) "KEYWORD") (unless (and (eqt s s2) - (eqt access :external)) - (return (list s2 access))))) + (eqt access :external)) + (return (list s2 access))))) t) ;; Every keyword evaluates to itself @@ -123,5 +123,5 @@ (return (list s (eval s)))))) t) - + diff --git a/ansi-tests/keywordp.lsp b/ansi-tests/keywordp.lsp index c1a49a4b..2f4a43e6 100644 --- a/ansi-tests/keywordp.lsp +++ b/ansi-tests/keywordp.lsp @@ -25,11 +25,11 @@ (deftest keywordp.13 (let ((kwp (find-package "KEYWORD")) - (bad nil)) + (bad nil)) (do-symbols (s "KEYWORD" bad) (when (and (not (eq (symbol-package s) kwp)) - (keywordp s)) - (push s bad)))) + (keywordp s)) + (push s bad)))) nil) (deftest keywordp.order.1 diff --git a/ansi-tests/labels.lsp b/ansi-tests/labels.lsp index b2020ef4..f74af254 100644 --- a/ansi-tests/labels.lsp +++ b/ansi-tests/labels.lsp @@ -25,7 +25,7 @@ (deftest labels.4 (block %f (labels ((%f (&optional (x (return-from %f :good))) - nil)) + nil)) (%f) :bad)) :good) @@ -36,7 +36,7 @@ (deftest labels.4a (block %f (labels ((%f (&key (x (return-from %f :good))) - nil)) + nil)) (%f) :bad)) :good) @@ -51,7 +51,7 @@ (deftest labels.6 (block %f (labels ((%f (&aux (x (return-from %f 10))) - 20)) + 20)) (%f) :bad)) 10) @@ -59,7 +59,7 @@ ;;; The function is visible inside itself (deftest labels.7 (labels ((%f (x n) (cond ((eql n 0) x) - (t (%f (+ x n) (1- n)))))) + (t (%f (+ x n) (1- n)))))) (%f 0 10)) 55) @@ -67,7 +67,7 @@ (deftest labels.7b (labels ((%f (x &aux (b (%g x))) b) - (%g (y) (+ y y))) + (%g (y) (+ y y))) (%f 10)) 20) @@ -75,7 +75,7 @@ (deftest labels.7c (labels ((%f (x &optional (b (%g x))) b) - (%g (y) (+ y y))) + (%g (y) (+ y y))) (%f 10)) 20) @@ -83,7 +83,7 @@ (deftest labels.7d (labels ((%f (x &key (b (%g x))) b) - (%g (y) (+ y y))) + (%g (y) (+ y y))) (%f 10)) 20) @@ -127,19 +127,19 @@ ;;; Too few arguments (section 3.5.1.2) (deftest labels.14 (signals-error (labels ((%f (a) a)) (%f)) - program-error) + program-error) t) ;;; Too many arguments (section 3.5.1.3) (deftest labels.15 (signals-error (labels ((%f (a) a)) (%f 1 2)) - program-error) + program-error) t) ;;; Invalid keyword argument (section 3.5.1.5) (deftest labels.16 (signals-error (labels ((%f (&key a) a)) (%f '(foo))) - program-error) + program-error) t) ;;; Definition of a (setf ...) function @@ -160,39 +160,39 @@ ;;; Can handle at least 50 lambda parameters (deftest labels.19 (labels ((%f (a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 - b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 - c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 - d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 - e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) - (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 - b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 - c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 - d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 - e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) + b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 + c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 + e1 e2 e3 e4 e5 e6 e7 e8 e9 e10) + (+ a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 + b1 b2 b3 b4 b5 b6 b7 b8 b9 b10 + c1 c2 c3 c4 c5 c6 c7 c8 c9 c10 + d1 d2 d3 d4 d5 d6 d7 d8 d9 d10 + e1 e2 e3 e4 e5 e6 e7 e8 e9 e10))) (%f 1 2 3 4 5 6 7 8 9 10 - 11 12 13 14 15 16 17 18 19 20 - 21 22 23 24 25 26 27 28 29 30 - 31 32 33 34 35 36 37 38 39 40 - 41 42 43 44 45 46 47 48 49 50)) + 11 12 13 14 15 16 17 18 19 20 + 21 22 23 24 25 26 27 28 29 30 + 31 32 33 34 35 36 37 38 39 40 + 41 42 43 44 45 46 47 48 49 50)) 1275) ;;; labels works with the maximum number of arguments (if ;;; not too many.) (deftest labels.20 (let* ((n (min (1- lambda-parameters-limit) 1024)) - (vars (loop repeat n collect (gensym)))) + (vars (loop repeat n collect (gensym)))) (eval `(eqlt ,n - (labels ((%f ,vars (+ ,@ vars))) - (%f ,@(loop for e in vars collect 1)))))) + (labels ((%f ,vars (+ ,@ vars))) + (%f ,@(loop for e in vars collect 1)))))) t) ;;; Declarations and documentation strings are ok (deftest labels.21 (labels ((%f (x) - (declare (type fixnum x)) - "Add one to the fixnum x." - (1+ x))) + (declare (type fixnum x)) + "Add one to the fixnum x." + (1+ x))) (declare (ftype (function (fixnum) integer) %f)) (%f 10)) 11) @@ -200,50 +200,50 @@ ;;; Keywords can be function names (deftest labels.22 (labels ((:foo () 10) - (:bar () (1+ (:foo)))) + (:bar () (1+ (:foo)))) (:bar)) 11) (deftest labels.23 (labels ((:foo () 10) - (:bar () (1+ (funcall #':foo)))) + (:bar () (1+ (funcall #':foo)))) (funcall #':bar)) 11) (deftest labels.24 (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors (labels ((,s (x) (foo (1- x))) - (foo (y) - (if (<= y 0) 'a - (,s (1- y))))) - (,s 10))) - unless (eq (eval form) 'a) - collect s) + for form = `(ignore-errors (labels ((,s (x) (foo (1- x))) + (foo (y) + (if (<= y 0) 'a + (,s (1- y))))) + (,s 10))) + unless (eq (eval form) 'a) + collect s) nil) (deftest labels.25 (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors - (labels ((,s (x) (foo (1- x))) - (foo (y) - (if (<= y 0) 'a - (,s (1- y))))) - (declare (ftype (function (integer) symbol) - foo ,s)) - (,s 10))) - unless (eq (eval form) 'a) - collect s) + for form = `(ignore-errors + (labels ((,s (x) (foo (1- x))) + (foo (y) + (if (<= y 0) 'a + (,s (1- y))))) + (declare (ftype (function (integer) symbol) + foo ,s)) + (,s 10))) + unless (eq (eval form) 'a) + collect s) nil) (deftest labels.26 (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors - (labels (((setf ,s) (&rest args) - (declare (ignore args)) - 'a)) - (setf (,s) 10))) - unless (eq (eval form) 'a) - collect s) + for form = `(ignore-errors + (labels (((setf ,s) (&rest args) + (declare (ignore args)) + 'a)) + (setf (,s) 10))) + unless (eq (eval form) 'a) + collect s) nil) ;;; Check that LABELS does not have a tagbody @@ -334,9 +334,9 @@ (declare (special x)) (let ((x :good)) (labels ((%f (&optional (y x)) - (declare (special x)) - y)) - (%f)))) + (declare (special x)) + y)) + (%f)))) :good) (deftest labels.42 @@ -344,9 +344,9 @@ (declare (special x)) (let ((x :good)) (labels ((%f (&key (y x)) - (declare (special x)) - y)) - (%f)))) + (declare (special x)) + y)) + (%f)))) :good) (deftest labels.43 @@ -370,7 +370,7 @@ (declare (special x)) (let ((x :good)) (labels ((%f () (declare (special x)))) - x))) + x))) :good) (deftest labels.46 @@ -378,9 +378,9 @@ (declare (special x)) (let ((x :good)) (labels ((%f (&aux (y x)) - (declare (special x)) - y)) - (%f)))) + (declare (special x)) + y)) + (%f)))) :good) (deftest labels.47 @@ -388,19 +388,19 @@ (declare (special x)) (let ((x :good)) (labels ((%f () x)) - (declare (special x)) - (%f)))) + (declare (special x)) + (%f)))) :good) ;;; Macros are expanded in the appropriate environment (deftest labels.48 (macrolet ((%m (z) z)) - (labels () (expand-in-current-env (%m :good)))) + (labels () (expand-in-current-env (%m :good)))) :good) (deftest labels.49 (macrolet ((%m (z) z)) - (labels ((%f () (expand-in-current-env (%m :good)))) - (%f))) + (labels ((%f () (expand-in-current-env (%m :good)))) + (%f))) :good) diff --git a/ansi-tests/lambda-list-keywords.lsp b/ansi-tests/lambda-list-keywords.lsp index a19ed3ef..12b0c5c7 100644 --- a/ansi-tests/lambda-list-keywords.lsp +++ b/ansi-tests/lambda-list-keywords.lsp @@ -18,10 +18,10 @@ ;;; The standard keywords are present in the list (deftest lambda-list-keywords.3 (and (consp lambda-list-keywords) - (not-mv (set-difference '(&allow-other-keys - &aux &body &environment - &key &optional &rest &whole) - lambda-list-keywords))) + (not-mv (set-difference '(&allow-other-keys + &aux &body &environment + &key &optional &rest &whole) + lambda-list-keywords))) t) ;;; No lambda list keywords are in the keyword package @@ -32,9 +32,9 @@ ;;; Every keyword starts with an ampersand (deftest lambda-list-keywords.5 (notevery #'(lambda (sym) - (and (symbolp sym) - (let ((name (symbol-name sym))) - (and (> (length name) 0) - (eql (aref name 0) #\&))))) - lambda-list-keywords) + (and (symbolp sym) + (let ((name (symbol-name sym))) + (and (> (length name) 0) + (eql (aref name 0) #\&))))) + lambda-list-keywords) nil) diff --git a/ansi-tests/lambda.lsp b/ansi-tests/lambda.lsp index 53620a35..57d9cfdc 100644 --- a/ansi-tests/lambda.lsp +++ b/ansi-tests/lambda.lsp @@ -154,22 +154,22 @@ (deftest lambda.34 ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) - b (notnot b-p) - c (notnot c-p))) + b (notnot b-p) + c (notnot c-p))) :c 5 :a 0) (0 t 2 nil 5 t)) (deftest lambda.35 ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) - b (notnot b-p) - c (notnot c-p))) + b (notnot b-p) + c (notnot c-p))) :c 5 :a nil :a 17 :c 100) (nil t 2 nil 5 t)) (deftest lambda.36 ((lambda (&key (a 1 a-p) (b 2 b-p) (c 3 c-p)) (list a (notnot a-p) - b (notnot b-p) - c (notnot c-p))) + b (notnot b-p) + c (notnot c-p))) :c 5 :a 0 :allow-other-keys t 'b 100) (0 t 2 nil 5 t)) @@ -188,7 +188,7 @@ (declare (ignorable a-p)) ((lambda (&key (a nil a-p) (b a-p)) (list a (notnot a-p) (notnot b))))) (nil nil nil)) - + (deftest lambda.40 (let ((a-p :bad)) (declare (ignorable a-p)) @@ -278,8 +278,8 @@ (deftest lambda.55 (let* ((doc "LMB55") - (fn (eval `#'(lambda () ,doc nil))) - (cfn (compile nil fn))) + (fn (eval `#'(lambda () ,doc nil))) + (cfn (compile nil fn))) (values (or (documentation fn t) doc) (or (documentation cfn t) doc))) @@ -288,8 +288,8 @@ (deftest lambda.56 (let* ((doc "LMB56") - (fn (eval `#'(lambda () ,doc nil))) - (cfn (compile nil fn))) + (fn (eval `#'(lambda () ,doc nil))) + (cfn (compile nil fn))) (values (or (documentation fn 'function) doc) (or (documentation cfn 'function) doc))) @@ -330,10 +330,10 @@ (let ((y :bad2)) (declare (special y)) (flet ((%f () y)) - ((lambda (x &aux (y :good)) - (declare (special y) (ignore x)) - (%f)) - nil)))) + ((lambda (x &aux (y :good)) + (declare (special y) (ignore x)) + (%f)) + nil)))) :good) (deftest lambda.64 @@ -341,8 +341,8 @@ (declare (special x)) (flet ((%f () x)) ((lambda (x &aux (y (%f))) - (declare (type t y) (special x)) - y) + (declare (type t y) (special x)) + y) :good))) :good) @@ -360,15 +360,15 @@ (deftest lambda.error.1 (signals-error (funcall (macro-function 'lambda)) - program-error) + program-error) t) (deftest lambda.error.2 (signals-error (funcall (macro-function 'lambda) '(lambda ())) - program-error) + program-error) t) (deftest lambda.error.3 (signals-error (funcall (macro-function 'lambda) '(lambda ()) nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/last.lsp b/ansi-tests/last.lsp index df2b6801..2323d545 100644 --- a/ansi-tests/last.lsp +++ b/ansi-tests/last.lsp @@ -71,7 +71,7 @@ (let ((i 0) x y) (values (last (progn (setf x (incf i)) (list 'a 'b 'c 'd)) - (setf y (incf i))) + (setf y (incf i))) i x y)) (c d) 2 1 2) @@ -110,6 +110,6 @@ (deftest last.error.8 (signals-error (locally (last (list 'a 'b 'c) 'a) t) - type-error) + type-error) t) diff --git a/ansi-tests/lcm.lsp b/ansi-tests/lcm.lsp index b5a85b24..275abb74 100644 --- a/ansi-tests/lcm.lsp +++ b/ansi-tests/lcm.lsp @@ -18,61 +18,61 @@ (deftest lcm.2 (loop for i = (random-fixnum) - for a = (abs i) - repeat 1000 - unless (and (eql a (lcm i)) - (eql a (lcm 1 i))) - collect i) + for a = (abs i) + repeat 1000 + unless (and (eql a (lcm i)) + (eql a (lcm 1 i))) + collect i) nil) (deftest lcm.3 (loop for i = (random-from-interval 10000000000000000) - for a = (abs i) - repeat 1000 - unless (and (eql a (lcm i)) - (eql a (lcm i 1))) - collect i) + for a = (abs i) + repeat 1000 + unless (and (eql a (lcm i)) + (eql a (lcm i 1))) + collect i) nil) (deftest lcm.4 (loop for i = (random-fixnum) - for j = (random-fixnum) - repeat 1000 - unless (eql (my-lcm i j) (lcm i j)) - collect (list i j)) + for j = (random-fixnum) + repeat 1000 + unless (eql (my-lcm i j) (lcm i j)) + collect (list i j)) nil) (deftest lcm.5 (let ((bound (ash 1 200))) (loop for i = (random-from-interval bound) - for j = (random-from-interval bound) - repeat 1000 - unless (eql (my-lcm i j) (lcm i j)) - collect (list i j))) + for j = (random-from-interval bound) + repeat 1000 + unless (eql (my-lcm i j) (lcm i j)) + collect (list i j))) nil) (deftest lcm.6 (loop for i = (random-fixnum) - for j = (random-fixnum) - for k = (random-fixnum) - repeat 1000 - unless (eql (my-lcm i (my-lcm j k)) (lcm i j k)) - collect (list i j k)) + for j = (random-fixnum) + for k = (random-fixnum) + repeat 1000 + unless (eql (my-lcm i (my-lcm j k)) (lcm i j k)) + collect (list i j k)) nil) (deftest lcm.7 (loop for i = (random-fixnum) - for j = (random-fixnum) - for k = (random-fixnum) - for n = (random-fixnum) - repeat 1000 - unless (eql (my-lcm (my-lcm i j) (my-lcm k n)) (lcm i j k n)) - collect (list i j k n)) + for j = (random-fixnum) + for k = (random-fixnum) + for n = (random-fixnum) + repeat 1000 + unless (eql (my-lcm (my-lcm i j) (my-lcm k n)) (lcm i j k n)) + collect (list i j k n)) nil) (deftest lcm.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) - always (eql (apply #'lcm (make-list i :initial-element 1)) 1)) + always (eql (apply #'lcm (make-list i :initial-element 1)) 1)) t) (deftest lcm.9 @@ -96,7 +96,7 @@ (let ((i 0) x y) (values (lcm (progn (setf x (incf i)) 15) - (progn (setf y (incf i)) 25)) + (progn (setf y (incf i)) 25)) i x y)) 75 2 1 2) @@ -104,7 +104,7 @@ (let ((i 0) x y) (values (lcm (progn (setf x (incf i)) 0) - (progn (setf y (incf i)) 10)) + (progn (setf y (incf i)) 10)) i x y)) 0 2 1 2) diff --git a/ansi-tests/ldb.lsp b/ansi-tests/ldb.lsp index f9712dba..586034e0 100644 --- a/ansi-tests/ldb.lsp +++ b/ansi-tests/ldb.lsp @@ -23,40 +23,40 @@ (deftest ldb.1 (loop for x = (random-fixnum) - for pos = (random 30) - for size = (random 30) - repeat 10000 - unless (eql (ldb (byte size pos) x) - (logand (1- (ash 1 size)) - (ash x (- pos)))) - collect (list x pos size)) + for pos = (random 30) + for size = (random 30) + repeat 10000 + unless (eql (ldb (byte size pos) x) + (logand (1- (ash 1 size)) + (ash x (- pos)))) + collect (list x pos size)) nil) (deftest ldb.2 (let ((bound (ash 1 300))) (loop for x = (random-from-interval bound) - for pos = (random 300) - for size = (random 300) - repeat 1000 - unless (eql (ldb (byte size pos) x) - (logand (1- (ash 1 size)) - (ash x (- pos)))) - collect (list x pos size))) + for pos = (random 300) + for size = (random 300) + repeat 1000 + unless (eql (ldb (byte size pos) x) + (logand (1- (ash 1 size)) + (ash x (- pos)))) + collect (list x pos size))) nil) (deftest ldb.3 (loop for i of-type fixnum from -1000 to 1000 - always (eql (ldb (byte 0 0) i) 0)) + always (eql (ldb (byte 0 0) i) 0)) t) (deftest ldb.order.1 (let ((i 0) a b c d) (values (ldb (progn (setf a (incf i)) - (byte (progn (setf b (incf i)) 3) - (progn (setf c (incf i)) 1))) - (progn (setf d (incf i)) -1)) + (byte (progn (setf b (incf i)) 3) + (progn (setf c (incf i)) 1))) + (progn (setf d (incf i)) -1)) i a b c d)) 7 4 1 2 3 4) @@ -71,23 +71,23 @@ (deftest ldb.place.2 (loop for pos from 0 to 100 - always - (loop for size from 0 to 100 - always - (let ((x 0)) - (and (eql (setf (ldb (byte size pos) x) -1) -1) - (eql x (ash (1- (ash 1 size)) pos)))))) + always + (loop for size from 0 to 100 + always + (let ((x 0)) + (and (eql (setf (ldb (byte size pos) x) -1) -1) + (eql x (ash (1- (ash 1 size)) pos)))))) t) (deftest ldb.place.order.1 (let ((i 0) a b c d e f (x (copy-seq #(63)))) (values (setf (ldb (progn (setf a (incf i)) - (byte (progn (setf b (incf i)) 3) - (progn (setf c (incf i)) 1))) - (aref (progn (setf d (incf i)) x) - (progn (setf e (incf i)) 0))) - (progn (setf f (incf i)) 0)) + (byte (progn (setf b (incf i)) 3) + (progn (setf c (incf i)) 1))) + (aref (progn (setf d (incf i)) x) + (progn (setf e (incf i)) 0))) + (progn (setf f (incf i)) 0)) x i a b c d e f)) 0 #(49) 6 1 2 3 4 5 6) diff --git a/ansi-tests/ldiff.lsp b/ansi-tests/ldiff.lsp index 6f502995..b031d6fe 100644 --- a/ansi-tests/ldiff.lsp +++ b/ansi-tests/ldiff.lsp @@ -9,29 +9,29 @@ (deftest ldiff.1 (let* ((x (copy-tree '(a b c d e f))) - (xcopy (make-scaffold-copy x))) + (xcopy (make-scaffold-copy x))) (let ((result (ldiff x (cdddr x)))) (and (check-scaffold-copy x xcopy) - result))) + result))) (a b c)) (deftest ldiff.2 (let* ((x (copy-tree '(a b c d e f))) - (xcopy (make-scaffold-copy x))) + (xcopy (make-scaffold-copy x))) (let ((result (ldiff x 'a))) (and (check-scaffold-copy x xcopy) (zerop - (loop - for a on x and b on result count - (eqt a b))) + (loop + for a on x and b on result count + (eqt a b))) result))) (a b c d e f)) ;; Works when the end of the dotted list is a symbol (deftest ldiff.3 (let* ((x (copy-tree '(a b c d e . f))) - (xcopy (make-scaffold-copy x))) + (xcopy (make-scaffold-copy x))) (let ((result (ldiff x 'a))) (and (check-scaffold-copy x xcopy) @@ -41,8 +41,8 @@ ;; Works when the end of the dotted list is a fixnum (deftest ldiff.4 (let* ((n 18) - (x (list* 'a 'b 'c 18)) - (xcopy (make-scaffold-copy x))) + (x (list* 'a 'b 'c 18)) + (xcopy (make-scaffold-copy x))) (let ((result (ldiff x n))) (and (check-scaffold-copy x xcopy) @@ -53,8 +53,8 @@ ;; integer (that is eql, but probably not eq). (deftest ldiff.5 (let* ((n 18000000000000) - (x (list* 'a 'b 'c (1- 18000000000001))) - (xcopy (make-scaffold-copy x))) + (x (list* 'a 'b 'c (1- 18000000000001))) + (xcopy (make-scaffold-copy x))) (let ((result (ldiff x n))) (and (check-scaffold-copy x xcopy) @@ -64,24 +64,24 @@ ;; Test works when the end of a dotted list is a string (deftest ldiff.6 (let* ((n (copy-seq "abcde")) - (x (list* 'a 'b 'c n)) - (xcopy (make-scaffold-copy x))) + (x (list* 'a 'b 'c n)) + (xcopy (make-scaffold-copy x))) (let ((result (ldiff x n))) (if (equal result (list 'a 'b 'c)) - (check-scaffold-copy x xcopy) - result))) + (check-scaffold-copy x xcopy) + result))) t) ;; Check that having the cdr of a dotted list be string-equal, but ;; not eql, does not result in success (deftest ldiff.7 (let* ((n (copy-seq "abcde")) - (x (list* 'a 'b 'c n)) - (xcopy (make-scaffold-copy x))) + (x (list* 'a 'b 'c n)) + (xcopy (make-scaffold-copy x))) (let ((result (ldiff x (copy-seq n)))) (if (equal result x) - (check-scaffold-copy x xcopy) - result))) + (check-scaffold-copy x xcopy) + result))) t) ;; Check that on failure, the list returned by ldiff is @@ -91,19 +91,19 @@ (let ((x (list 'a 'b 'c 'd))) (let ((result (ldiff x '(e)))) (and (equal x result) - (loop - for c1 on x - for c2 on result - count (eqt c1 c2))))) + (loop + for c1 on x + for c2 on result + count (eqt c1 c2))))) 0) (deftest ldiff.order.1 (let ((i 0) x y) (values (ldiff (progn (setf x (incf i)) - (list* 'a 'b 'c 'd)) - (progn (setf y (incf i)) - 'd)) + (list* 'a 'b 'c 'd)) + (progn (setf y (incf i)) + 'd)) i x y)) (a b c) 2 1 2) @@ -160,8 +160,8 @@ (loop for x in *universe* count (and (not (listp x)) - (not (eqt 'type-error - (catch-type-error (ldiff x x))))))) + (not (eqt 'type-error + (catch-type-error (ldiff x x))))))) (deftest ldiff-12 (ldiff-12-body) diff --git a/ansi-tests/length.lsp b/ansi-tests/length.lsp index f9dcd7b57e46b817d86e5d0c57f4cf105a24eb2d..3ce5a9cc2cdec98be77aa5c6347ebc4d8701e96f 100644 GIT binary patch delta 395 zcmdlZcUOMHHx>>BD46`6MMDC{L8mt>u{JOwlrCo5gy4K<QJq}P&WT%ZJNq0YYgBj? z5PDsC9GqZwrR5hX<fP^)*eYlMsq~Tzg|gISO)i*pX<klhaj}9%YGDponK?pg@-$wH z$**{15$1C6${{%FypHNHQwUfxxsg`{p>Y~-k07!}pnDW-C;w%Uo$SXeJ~@F;h+Mau KBDsA&-&_DP*jg9> delta 191 zcmcaBzejGvHx@?D$qnqPY?&oooSdAS?N}Qafg;D)Hi5<USb>5H3X^ZM*=%Ovhyy9k z;!yyS>-oecui()FvL5h?i*lCc<)juDD`=z^<|yQ(<|&wKa&b<U=ChdW!z&9^Q^+d^ g)w7mY8=^-HLyw^`L{kq~sXs&+rqQM#RSx`f0cuG!Gynhq diff --git a/ansi-tests/let.lsp b/ansi-tests/let.lsp index 0121404b..a0abb783 100644 --- a/ansi-tests/let.lsp +++ b/ansi-tests/let.lsp @@ -63,26 +63,26 @@ (deftest let.11 (let ((x 1)) (list x - (let (x) - (declare (special x)) - x) - x)) + (let (x) + (declare (special x)) + x) + x)) (1 nil 1)) ;;; (deftest let.12 ;;; (let ((x 0)) ;;; (values ;;; (let ((x 20) -;;; (x (1+ x))) +;;; (x (1+ x))) ;;; x) ;;; x)) ;;; 1 0) ;;; (deftest let.13 ;;; (flet ((%f () (declare (special x)) -;;; (if (boundp 'x) x 10))) +;;; (if (boundp 'x) x 10))) ;;; (let ((x 1) -;;; (x (1+ (%f)))) +;;; (x (1+ (%f)))) ;;; (declare (special x)) ;;; x)) ;;; 11) @@ -90,14 +90,14 @@ ;;; Tests of large number of LET variables (deftest let.14 (let* ((n 100) - (vars (mapcar #'gensym (make-list n :initial-element "G"))) - (expr `(let ,(let ((i 0)) - (mapcar #'(lambda (v) (list v (incf i))) vars)) - ,(let ((sumexpr 0)) - (dolist (v vars) - (setq sumexpr `(+ ,v ,sumexpr))) - sumexpr))) - (val (eval expr))) + (vars (mapcar #'gensym (make-list n :initial-element "G"))) + (expr `(let ,(let ((i 0)) + (mapcar #'(lambda (v) (list v (incf i))) vars)) + ,(let ((sumexpr 0)) + (dolist (v vars) + (setq sumexpr `(+ ,v ,sumexpr))) + sumexpr))) + (val (eval expr))) (or (eqlt val (/ (* n (1+ n)) 2)) (list val))) t) @@ -105,9 +105,9 @@ ;;; in LET forms. (deftest let.15 (loop for s in *cl-non-variable-constant-symbols* - for form = `(ignore-errors (let ((,s 17)) ,s)) - unless (eql (eval form) 17) - collect s) + for form = `(ignore-errors (let ((,s 17)) ,s)) + unless (eql (eval form) 17) + collect s) nil) ;;; Check that LET does not have a tagbody @@ -126,8 +126,8 @@ (declare (special x)) (let ((x :good)) ;; lexical binding (let ((y x)) - (declare (special x)) ;; free declaration - y))) + (declare (special x)) ;; free declaration + y))) :good) (deftest let.17a @@ -136,11 +136,11 @@ nil '(lambda () (let ((x :bad)) - (declare (special x)) - (let ((x :good)) ;; lexical binding - (let ((y x)) - (declare (special x)) ;; free declaration - y)))))) + (declare (special x)) + (let ((x :good)) ;; lexical binding + (let ((y x)) + (declare (special x)) ;; free declaration + y)))))) :good) (deftest let.18 @@ -153,18 +153,18 @@ (deftest let.19 (loop for k in lambda-list-keywords - unless (eql (eval `(let ((,k :foo)) ,k)) :foo) - collect k) + unless (eql (eval `(let ((,k :foo)) ,k)) :foo) + collect k) nil) ;;; Macros are expanded in the appropriate environment (deftest let.20 (macrolet ((%m (z) z)) - (let () (expand-in-current-env (%m :good)))) + (let () (expand-in-current-env (%m :good)))) :good) (deftest let.21 (macrolet ((%m (z) z)) - (let ((x (expand-in-current-env (%m 1)))) (+ x x x))) + (let ((x (expand-in-current-env (%m 1)))) (+ x x x))) 3) diff --git a/ansi-tests/letstar.lsp b/ansi-tests/letstar.lsp index 6237731c..3b917d79 100644 --- a/ansi-tests/letstar.lsp +++ b/ansi-tests/letstar.lsp @@ -57,24 +57,24 @@ (deftest let*.11 (let* ((x 1)) (list x - (let* (x x x) - (declare (special x)) - x) - x)) + (let* (x x x) + (declare (special x)) + x) + x)) (1 nil 1)) (deftest let*.12 (let* ((x 1) - (y (1+ x)) - (x (1+ y)) - (z (+ x y))) + (y (1+ x)) + (x (1+ y)) + (z (+ x y))) (values x y z)) 3 2 5) ;;; (deftest let*.13 ;;; (flet ((%f () (declare (special x)) x)) ;;; (let* ((x 1) -;;; (x (1+ (%f)))) +;;; (x (1+ (%f)))) ;;; (declare (special x)) ;;; x)) ;;; 2) @@ -82,14 +82,14 @@ ;;; Tests of large number of LET* variables (deftest let*.14 (let* ((n 100) - (vars (mapcar #'gensym (make-list n :initial-element "G"))) - (expr `(let* ,(let ((i 0)) - (mapcar #'(lambda (v) (list v (incf i))) vars)) - ,(let ((sumexpr 0)) - (dolist (v vars) - (setq sumexpr `(+ ,v ,sumexpr))) - sumexpr))) - (val (eval expr))) + (vars (mapcar #'gensym (make-list n :initial-element "G"))) + (expr `(let* ,(let ((i 0)) + (mapcar #'(lambda (v) (list v (incf i))) vars)) + ,(let ((sumexpr 0)) + (dolist (v vars) + (setq sumexpr `(+ ,v ,sumexpr))) + sumexpr))) + (val (eval expr))) (or (eqlt val (/ (* n (1+ n)) 2)) (list val))) t) @@ -97,9 +97,9 @@ ;;; in LET* forms. (deftest let*.15 (loop for s in *cl-non-variable-constant-symbols* - for form = `(ignore-errors (let* ((,s 17)) ,s)) - unless (eql (eval form) 17) - collect s) + for form = `(ignore-errors (let* ((,s 17)) ,s)) + unless (eql (eval form) 17) + collect s) nil) ;;; Check that LET* does not have a tagbody @@ -118,8 +118,8 @@ (declare (special x)) (let ((x :good)) ;; lexical binding (let* ((y x)) - (declare (special x)) ;; free declaration - y))) + (declare (special x)) ;; free declaration + y))) :good) (deftest let*.17a @@ -128,23 +128,23 @@ nil '(lambda () (let ((x :bad)) - (declare (special x)) - (let ((x :good)) ;; lexical binding - (let* ((y x)) - (declare (special x)) ;; free declaration - y)))))) + (declare (special x)) + (let ((x :good)) ;; lexical binding + (let* ((y x)) + (declare (special x)) ;; free declaration + y)))))) :good) (deftest let*.18 (let ((x :bad1) - (z :bad2)) + (z :bad2)) (declare (special x z)) (let ((x :good) - (z :good)) ;; lexical bindings + (z :good)) ;; lexical bindings (let* ((y x) - (w z)) - (declare (special x)) ;; free declaration - (values y w)))) + (w z)) + (declare (special x)) ;; free declaration + (values y w)))) :good :good) @@ -158,27 +158,27 @@ (deftest let*.20 (loop for k in lambda-list-keywords - unless (eql (eval `(let* ((,k :foo)) ,k)) :foo) - collect k) + unless (eql (eval `(let* ((,k :foo)) ,k)) :foo) + collect k) nil) ;;; Macros are expanded in the appropriate environment (deftest let*.21 (macrolet ((%m (z) z)) - (let* () (expand-in-current-env (%m :good)))) + (let* () (expand-in-current-env (%m :good)))) :good) (deftest let*.22 (macrolet ((%m (z) z)) - (let* ((x (expand-in-current-env (%m 1)))) (+ x x x))) + (let* ((x (expand-in-current-env (%m 1)))) (+ x x x))) 3) (deftest let*.23 (macrolet ((%m (z) z)) - (let* ((x (expand-in-current-env (%m 1))) - (y (expand-in-current-env (%m 2)))) - (+ x y))) + (let* ((x (expand-in-current-env (%m 1))) + (y (expand-in-current-env (%m 2)))) + (+ x y))) 3) diff --git a/ansi-tests/list-all-packages.lsp b/ansi-tests/list-all-packages.lsp index 797ea7c1..2eb8ca8f 100644 --- a/ansi-tests/list-all-packages.lsp +++ b/ansi-tests/list-all-packages.lsp @@ -21,12 +21,12 @@ (notnot (subsetp (list (find-package "CL") - (find-package "CL-USER") - (find-package "KEYWORD") - (find-package "A") - (find-package "REGRESSION-TEST") - (find-package "CL-TEST") - (find-package "B")) + (find-package "CL-USER") + (find-package "KEYWORD") + (find-package "A") + (find-package "REGRESSION-TEST") + (find-package "CL-TEST") + (find-package "B")) (list-all-packages)))) t) @@ -38,9 +38,9 @@ ;; It returns a list of the same packages each time it is called (deftest list-all-packages.4 (let ((p1 (list-all-packages)) - (p2 (list-all-packages))) + (p2 (list-all-packages))) (and (subsetp p1 p2) - (subsetp p2 p1))) + (subsetp p2 p1))) t) (deftest list-all-packages.error.1 diff --git a/ansi-tests/list-length.lsp b/ansi-tests/list-length.lsp index 36031ea1..ecde7b01 100644 --- a/ansi-tests/list-length.lsp +++ b/ansi-tests/list-length.lsp @@ -23,7 +23,7 @@ (let ((y (list* 1 2 3 4 5 6 7 8 9 x))) (setf (cdr x) y) (let ((z (list* 'a 'b 'c 'd 'e y))) - (list-length z)))) + (list-length z)))) nil) (deftest list-length.order.1 @@ -42,7 +42,7 @@ (deftest list-length.error.1 (loop for x in (list 'a 1 1.0 #\w (make-array '(10)) - '(a b . c) (symbol-package 'cons)) + '(a b . c) (symbol-package 'cons)) count (not (eval `(signals-type-error x ',x (list-length x))))) 0) diff --git a/ansi-tests/list.lsp b/ansi-tests/list.lsp index 2b352632..ee5761e4 100644 --- a/ansi-tests/list.lsp +++ b/ansi-tests/list.lsp @@ -23,15 +23,15 @@ (deftest list.order.2 (let ((i 0)) (list (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i))) + (incf i) (incf i) (incf i) (incf i))) (1 2 3 4 5 6 7 8)) (deftest list.order.3 (let ((i 0)) (list (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i))) + (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i))) (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16)) (def-fold-test list.fold.1 (list 'a)) @@ -64,9 +64,9 @@ (deftest list*.order.2 (let ((i 0)) (list* (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i) - (incf i) (incf i) (incf i) (incf i))) + (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i) + (incf i) (incf i) (incf i) (incf i))) (1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 . 16)) (def-fold-test list*.fold.1 (list* 'a 'b)) diff --git a/ansi-tests/listen.lsp b/ansi-tests/listen.lsp index 148f5527..7e9b8eab 100644 --- a/ansi-tests/listen.lsp +++ b/ansi-tests/listen.lsp @@ -44,7 +44,7 @@ (notnot (listen s)) (handler-case (locally (declare (optimize safety)) - (loop (read-char s))) + (loop (read-char s))) (end-of-file () (listen s))))) t nil) diff --git a/ansi-tests/load-logical-pathname-translations.lsp b/ansi-tests/load-logical-pathname-translations.lsp index c9c11bfa..8c45dfde 100644 --- a/ansi-tests/load-logical-pathname-translations.lsp +++ b/ansi-tests/load-logical-pathname-translations.lsp @@ -17,18 +17,18 @@ (deftest load-logical-pathname-translations.error.1 (handler-case (progn (load-logical-pathname-translations - "THEREHADBETTERNOTBEAHOSTCALLEDTHIS") - nil) + "THEREHADBETTERNOTBEAHOSTCALLEDTHIS") + nil) (error () :good)) :good) (deftest load-logical-pathname-translations.error.2 (signals-error (load-logical-pathname-translations) - program-error) + program-error) t) (deftest load-logical-pathname-translations.error.3 (signals-error (load-logical-pathname-translations "CLTESTROOT" nil) - program-error) + program-error) t) diff --git a/ansi-tests/load.lsp b/ansi-tests/load.lsp index 65a2e08e..731fc513 100644 --- a/ansi-tests/load.lsp +++ b/ansi-tests/load.lsp @@ -6,35 +6,35 @@ (in-package :cl-test) (defun load-file-test (file funname &rest args &key - if-does-not-exist - (print nil print-p) - (verbose nil verbose-p) - (*load-print* nil) - (*load-verbose* nil) - external-format) + if-does-not-exist + (print nil print-p) + (verbose nil verbose-p) + (*load-print* nil) + (*load-verbose* nil) + external-format) (declare (ignorable external-format if-does-not-exist - print print-p verbose verbose-p)) + print print-p verbose verbose-p)) (fmakunbound funname) (let* ((str (make-array '(0) :element-type 'character :adjustable t - :fill-pointer 0)) - (vals (multiple-value-list - (with-output-to-string - (*standard-output* str) - (apply #'load file :allow-other-keys t args)))) - (print? (if print-p print *load-print*)) - (verbose? (if verbose-p verbose *load-verbose*))) + :fill-pointer 0)) + (vals (multiple-value-list + (with-output-to-string + (*standard-output* str) + (apply #'load file :allow-other-keys t args)))) + (print? (if print-p print *load-print*)) + (verbose? (if verbose-p verbose *load-verbose*))) (values (let ((v1 (car vals)) - (v2 (or (and verbose-p (not verbose)) - (and (not verbose-p) (not *load-verbose*)) - (position #\; str))) - (v3 (or (and print-p (not print)) - (and (not print-p) (not *load-print*)) - (> (length str) 0))) - (v4 (if (or print? verbose?) - (> (length str) 0) - t))) - (if (and (= (length vals) 1) v1 v2 v3 v4) t (list vals v2 v3 v4 str))) + (v2 (or (and verbose-p (not verbose)) + (and (not verbose-p) (not *load-verbose*)) + (position #\; str))) + (v3 (or (and print-p (not print)) + (and (not print-p) (not *load-print*)) + (> (length str) 0))) + (v4 (if (or print? verbose?) + (> (length str) 0) + t))) + (if (and (= (length vals) 1) v1 v2 v3 v4) t (list vals v2 v3 v4 str))) (funcall funname)))) (deftest load.1 @@ -53,22 +53,22 @@ (deftest load.4 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :external-format :default) + :external-format :default) t nil) (deftest load.5 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :verbose t) + :verbose t) t nil) (deftest load.6 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :*load-verbose* t) + :*load-verbose* t) t nil) (deftest load.7 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :*load-verbose* t :verbose nil) + :*load-verbose* t :verbose nil) t nil) (deftest load.8 @@ -79,22 +79,22 @@ (deftest load.9 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :print t) + :print t) t nil) (deftest load.10 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :*load-print* t) + :*load-print* t) t nil) (deftest load.11 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :*load-print* t :print nil) + :*load-print* t :print nil) t nil) (deftest load.12 (load-file-test "compile-file-test-file.lsp" 'compile-file-test-fun.1 - :*load-print* nil :print t) + :*load-print* nil :print t) t nil) (deftest load.13 @@ -136,7 +136,7 @@ (deftest load.16a (let ((*readtable* *readtable*) - (*package* (find-package "CL-TEST"))) + (*package* (find-package "CL-TEST"))) (values (with-input-from-string (s "(in-package :cl-test) @@ -156,10 +156,10 @@ (values (notnot (load file)) (let ((p1 (pathname (merge-pathnames file))) - (p2 (funcall 'load-file-test-fun.1))) + (p2 (funcall 'load-file-test-fun.1))) (equalpt-or-report p1 p2)) (let ((p1 (truename file)) - (p2 (funcall 'load-file-test-fun.2))) + (p2 (funcall 'load-file-test-fun.2))) (equalpt-or-report p1 p2)))) t t t) @@ -168,7 +168,7 @@ (deftest load.18 (let* ((file "load-test-file-2.lsp") - (target (enough-namestring (compile-file-pathname file)))) + (target (enough-namestring (compile-file-pathname file)))) (declare (special *load-test-var.1* *load-test-var.2*)) (compile-file file) (makunbound '*load-test-var.1*) @@ -176,20 +176,20 @@ (load target) (values (let ((p1 (pathname (merge-pathnames target))) - (p2 *load-test-var.1*)) + (p2 *load-test-var.1*)) (equalpt-or-report p1 p2)) (let ((p1 (truename target)) - (p2 *load-test-var.2*)) + (p2 *load-test-var.2*)) (equalpt-or-report p1 p2)))) t t) (deftest load.19 (let ((file (logical-pathname "CLTEST:LDTEST.LSP")) - (fn 'load-test-fun-3) - (*package* (find-package "CL-TEST"))) + (fn 'load-test-fun-3) + (*package* (find-package "CL-TEST"))) (with-open-file (s file :direction :output :if-exists :supersede - :if-does-not-exist :create) + :if-does-not-exist :create) (format s "(in-package :cl-test) (defun ~a () :foo)" fn)) (fmakunbound fn) (values @@ -223,5 +223,5 @@ (deftest load.error.3 (signals-error (load "compile-file-test-file.lsp" :bad-key-arg t) - program-error) + program-error) t) diff --git a/ansi-tests/locally.lsp b/ansi-tests/locally.lsp index 7466fc2b..a198d8ba 100644 --- a/ansi-tests/locally.lsp +++ b/ansi-tests/locally.lsp @@ -42,5 +42,5 @@ (deftest locally.8 (macrolet ((%m (z) z)) - (locally (expand-in-current-env (%m :good)))) + (locally (expand-in-current-env (%m :good)))) :good) diff --git a/ansi-tests/log.lsp b/ansi-tests/log.lsp index cfe237ac..dd82d25a 100644 --- a/ansi-tests/log.lsp +++ b/ansi-tests/log.lsp @@ -8,7 +8,7 @@ (deftest log.1 (let ((result (log 1))) (or (eqlt result 0) - (eqlt result 0.0))) + (eqlt result 0.0))) t) (deftest log.2 @@ -17,97 +17,97 @@ (deftest log.3 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (+ (random (coerce 1 type)) (/ 1 1000)) - for rlist = (multiple-value-list (log x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) + nconc + (loop + for x = (+ (random (coerce 1 type)) (/ 1 1000)) + for rlist = (multiple-value-list (log x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y type)) + collect (list x rlist))) nil) (deftest log.4 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (1+ (random (coerce 1000000 type))) - for rlist = (multiple-value-list (log x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) + nconc + (loop + for x = (1+ (random (coerce 1000000 type))) + for rlist = (multiple-value-list (log x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y type)) + collect (list x rlist))) nil) (deftest log.5 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - nconc - (loop - for x = (- (random (coerce 1 type))) - for rlist = (and (/= x zero) (multiple-value-list (log x))) - for y = (car rlist) - repeat 1000 - unless (or (= x zero) - (and (null (cdr rlist)) - (typep y `(complex ,type)))) - collect (list x rlist))) + for zero = (coerce 0 type) + nconc + (loop + for x = (- (random (coerce 1 type))) + for rlist = (and (/= x zero) (multiple-value-list (log x))) + for y = (car rlist) + repeat 1000 + unless (or (= x zero) + (and (null (cdr rlist)) + (typep y `(complex ,type)))) + collect (list x rlist))) nil) (deftest log.6 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - nconc - (loop - for x = (- (random (coerce 1000000 type))) - for rlist = (and (/= x zero) (multiple-value-list (log x))) - for y = (car rlist) - repeat 1000 - unless (or (= x zero) - (and (null (cdr rlist)) - (typep y `(complex ,type)))) - collect (list x rlist))) + for zero = (coerce 0 type) + nconc + (loop + for x = (- (random (coerce 1000000 type))) + for rlist = (and (/= x zero) (multiple-value-list (log x))) + for y = (car rlist) + repeat 1000 + unless (or (= x zero) + (and (null (cdr rlist)) + (typep y `(complex ,type)))) + collect (list x rlist))) nil) (deftest log.7 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - nconc - (loop - for x1 = (- (random (coerce 2000 type)) 1000) - for x2 = (1+ (random (coerce 1000 type))) - for rlist = (and (/= x1 zero) - (multiple-value-list (log (complex x1 x2)))) - for y = (car rlist) - repeat 1000 - unless (or (= x1 zero) - (and (null (cdr rlist)) - (typep y `(complex ,type)))) - collect (list x1 x2 rlist))) + for zero = (coerce 0 type) + nconc + (loop + for x1 = (- (random (coerce 2000 type)) 1000) + for x2 = (1+ (random (coerce 1000 type))) + for rlist = (and (/= x1 zero) + (multiple-value-list (log (complex x1 x2)))) + for y = (car rlist) + repeat 1000 + unless (or (= x1 zero) + (and (null (cdr rlist)) + (typep y `(complex ,type)))) + collect (list x1 x2 rlist))) nil) (deftest log.8 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - nconc - (loop - for x1 = (- (random (coerce 2000 type)) 1000) - for x2 = (- -1 (random (coerce 1000 type))) - for rlist = (and (/= x1 zero) - (multiple-value-list (log (complex x1 x2)))) - for y = (car rlist) - repeat 1000 - unless (or (= x1 zero) - (and (null (cdr rlist)) - (typep y `(complex ,type)))) - collect (list x1 x2 rlist))) + for zero = (coerce 0 type) + nconc + (loop + for x1 = (- (random (coerce 2000 type)) 1000) + for x2 = (- -1 (random (coerce 1000 type))) + for rlist = (and (/= x1 zero) + (multiple-value-list (log (complex x1 x2)))) + for y = (car rlist) + repeat 1000 + unless (or (= x1 zero) + (and (null (cdr rlist)) + (typep y `(complex ,type)))) + collect (list x1 x2 rlist))) nil) ;;; FIXME ;;; Add tests for two-arg calls - + ;;; FIXME ;;; More accuracy tests here diff --git a/ansi-tests/logand.lsp b/ansi-tests/logand.lsp index 5fe31cfe..dc47ccc1 100644 --- a/ansi-tests/logand.lsp +++ b/ansi-tests/logand.lsp @@ -37,57 +37,57 @@ (deftest logand.4 (loop for x in *integers* - always (eql x (logand x))) + always (eql x (logand x))) t) (deftest logand.5 (loop for x in *integers* - always (eql 0 (logand x (lognot x)))) + always (eql 0 (logand x (lognot x)))) t) (deftest logand.6 (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql 0 (logand x xc)) - collect x) + for xc = (lognot x) + repeat 1000 + unless (eql 0 (logand x xc)) + collect x) nil) (deftest logand.7 (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logand x y) - repeat 1000 - unless (and (if (and (< x 0) (< y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (and (logbitp i x) - (logbitp i y)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) + for y = (random-from-interval (ash 1 (random 200))) + for z = (logand x y) + repeat 1000 + unless (and (if (and (< x 0) (< y 0)) + (< z 0) + (>= z 0)) + (loop for i from 1 to 210 + always (if (and (logbitp i x) + (logbitp i y)) + (logbitp i z) + (not (logbitp i z))))) + collect (list x y z)) nil) (deftest logand.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) - for args = (nconc (make-list (1- i) :initial-element -1) - (list 183)) - always (eql (apply #'logand args) 183)) + for args = (nconc (make-list (1- i) :initial-element -1) + (list 183)) + always (eql (apply #'logand args) 183)) t) (deftest logand.9 (loop for i from -1 to 0 always - (loop for j from -1 to 0 always - (locally (declare (type (integer -1 0) i j)) - (eql (logand i j) (if (or (zerop i) (zerop j)) 0 -1))))) + (loop for j from -1 to 0 always + (locally (declare (type (integer -1 0) i j)) + (eql (logand i j) (if (or (zerop i) (zerop j)) 0 -1))))) t) (deftest logand.order.1 (let ((i 0) a b) (values (logand (progn (setf a (incf i)) #b11011) - (progn (setf b (incf i)) #b10110)) + (progn (setf b (incf i)) #b10110)) i a b)) #b10010 2 1 2) @@ -95,7 +95,7 @@ (let ((i 0) a b c) (values (logand (progn (setf a (incf i)) #b11011) - (progn (setf b (incf i)) #b10110) - (progn (setf c (incf i)) #b110101)) + (progn (setf b (incf i)) #b10110) + (progn (setf c (incf i)) #b110101)) i a b c)) #b10000 3 1 2 3) diff --git a/ansi-tests/logandc1.lsp b/ansi-tests/logandc1.lsp index 8f124ec9..295bdf15 100644 --- a/ansi-tests/logandc1.lsp +++ b/ansi-tests/logandc1.lsp @@ -45,40 +45,40 @@ (deftest logandc1.4 (loop for x in *integers* - always (and (eql x (logandc1 0 x)) - (eql 0 (logandc1 x x)) - (eql x (logandc1 (lognot x) x)) - (eql (lognot x) (logandc1 x (lognot x))))) + always (and (eql x (logandc1 0 x)) + (eql 0 (logandc1 x x)) + (eql x (logandc1 (lognot x) x)) + (eql (lognot x) (logandc1 x (lognot x))))) t) (deftest logandc1.5 (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql x (logandc1 xc x)) - collect x) + for xc = (lognot x) + repeat 1000 + unless (eql x (logandc1 xc x)) + collect x) nil) (deftest logandc1.6 (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logandc1 x y) - repeat 1000 - unless (and (if (and (>= x 0) (< y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (and (not (logbitp i x)) - (logbitp i y)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) + for y = (random-from-interval (ash 1 (random 200))) + for z = (logandc1 x y) + repeat 1000 + unless (and (if (and (>= x 0) (< y 0)) + (< z 0) + (>= z 0)) + (loop for i from 1 to 210 + always (if (and (not (logbitp i x)) + (logbitp i y)) + (logbitp i z) + (not (logbitp i z))))) + collect (list x y z)) nil) (deftest logandc1.order.1 (let ((i 0) a b) (values (logandc1 (progn (setf a (incf i)) 0) - (progn (setf b (incf i)) -1)) + (progn (setf b (incf i)) -1)) i a b)) -1 2 1 2) diff --git a/ansi-tests/logandc2.lsp b/ansi-tests/logandc2.lsp index eec05ecf..8bef40f4 100644 --- a/ansi-tests/logandc2.lsp +++ b/ansi-tests/logandc2.lsp @@ -45,40 +45,40 @@ (deftest logandc2.4 (loop for x in *integers* - always (and (eql x (logandc2 x 0)) - (eql 0 (logandc2 x x)) - (eql x (logandc2 x (lognot x))) - (eql (lognot x) (logandc2 (lognot x) x)))) + always (and (eql x (logandc2 x 0)) + (eql 0 (logandc2 x x)) + (eql x (logandc2 x (lognot x))) + (eql (lognot x) (logandc2 (lognot x) x)))) t) (deftest logandc2.5 (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql x (logandc2 x xc)) - collect x) + for xc = (lognot x) + repeat 1000 + unless (eql x (logandc2 x xc)) + collect x) nil) (deftest logandc2.6 (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logandc2 x y) - repeat 1000 - unless (and (if (and (< x 0) (>= y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (and (not (logbitp i y)) - (logbitp i x)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) + for y = (random-from-interval (ash 1 (random 200))) + for z = (logandc2 x y) + repeat 1000 + unless (and (if (and (< x 0) (>= y 0)) + (< z 0) + (>= z 0)) + (loop for i from 1 to 210 + always (if (and (not (logbitp i y)) + (logbitp i x)) + (logbitp i z) + (not (logbitp i z))))) + collect (list x y z)) nil) (deftest logandc2.order.1 (let ((i 0) a b) (values (logandc2 (progn (setf a (incf i)) -1) - (progn (setf b (incf i)) 0)) + (progn (setf b (incf i)) 0)) i a b)) -1 2 1 2) diff --git a/ansi-tests/logbitp.lsp b/ansi-tests/logbitp.lsp index c309a9ae..c2d0d9d4 100644 --- a/ansi-tests/logbitp.lsp +++ b/ansi-tests/logbitp.lsp @@ -33,23 +33,23 @@ (deftest logbitp.1 (loop for x in *integers* - unless (if (logbitp 0 x) (oddp x) (evenp x)) - collect x) + unless (if (logbitp 0 x) (oddp x) (evenp x)) + collect x) nil) (deftest logbitp.2 (loop for len from 0 to 300 - for i = (ash 1 len) - always (and (logbitp len i) - (loop for j from 0 to 300 - always (or (eql j len) - (not (logbitp j i)))))) + for i = (ash 1 len) + always (and (logbitp len i) + (loop for j from 0 to 300 + always (or (eql j len) + (not (logbitp j i)))))) t) (deftest logbitp.3 (logbitp most-positive-fixnum 0) nil) - + (deftest logbitp.4 (notnot-mv (logbitp most-positive-fixnum -1)) t) @@ -57,37 +57,37 @@ (deftest logbitp.5 (logbitp (1+ most-positive-fixnum) 0) nil) - + (deftest logbitp.6 (notnot-mv (logbitp (1+ most-positive-fixnum) -1)) t) (deftest logbitp.7 (loop for len = (random 100) - for i = (random-from-interval (ash 1 len)) - for k = (random (1+ len)) - repeat 1000 - unless (if (ldb-test (byte 1 k) i) - (logbitp k i) - (not (logbitp k i))) - collect (list i k)) + for i = (random-from-interval (ash 1 len)) + for k = (random (1+ len)) + repeat 1000 + unless (if (ldb-test (byte 1 k) i) + (logbitp k i) + (not (logbitp k i))) + collect (list i k)) nil) (deftest logbitp.8 (loop for k from 1 to 1000 - always (logbitp k -1)) + always (logbitp k -1)) t) (deftest logbitp.order.1 (let ((i 0) a b) (values (logbitp (progn (setf a (incf i)) 2) - (progn (setf b (incf i)) #b111010)) + (progn (setf b (incf i)) #b111010)) i a b)) nil 2 1 2) - - + + diff --git a/ansi-tests/logcount.lsp b/ansi-tests/logcount.lsp index dbbfc73f..47a623de 100644 --- a/ansi-tests/logcount.lsp +++ b/ansi-tests/logcount.lsp @@ -43,29 +43,29 @@ (deftest logcount.6 (loop for x = (random-fixnum) - repeat 100 - always (eql (logcount x) (logcount (lognot x)))) + repeat 100 + always (eql (logcount x) (logcount (lognot x)))) t) (deftest logcount.7 (let ((bound (ash 1 300))) (loop for x = (random-from-interval bound) - repeat 100 - always (eql (logcount x) (logcount (lognot x))))) + repeat 100 + always (eql (logcount x) (logcount (lognot x))))) t) (deftest logcount.8 (loop for y = (random (1+ most-positive-fixnum)) - repeat 100 - unless - (let ((cnt 0) - (x y)) - (loop while (> x 0) - do - (when (oddp x) (incf cnt)) - (setf x (ash x -1))) - (eql cnt (logcount y))) - collect y) + repeat 100 + unless + (let ((cnt 0) + (x y)) + (loop while (> x 0) + do + (when (oddp x) (incf cnt)) + (setf x (ash x -1))) + (eql cnt (logcount y))) + collect y) nil) diff --git a/ansi-tests/logeqv.lsp b/ansi-tests/logeqv.lsp index 3bd145eb..b28c2160 100644 --- a/ansi-tests/logeqv.lsp +++ b/ansi-tests/logeqv.lsp @@ -33,62 +33,62 @@ (deftest logeqv.4 (loop for x in *integers* - always (eql x (logeqv x))) + always (eql x (logeqv x))) t) (deftest logeqv.5 (loop for x in *integers* - always (eql 0 (logeqv x (lognot x)))) + always (eql 0 (logeqv x (lognot x)))) t) (deftest logeqv.6 (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql 0 (logeqv x xc)) - collect x) + for xc = (lognot x) + repeat 1000 + unless (eql 0 (logeqv x xc)) + collect x) nil) (deftest logeqv.7 (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logeqv x y) - repeat 1000 - unless (and (if (or (and (< x 0) (< y 0)) - (and (>= x 0) (>= y 0))) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (or (and (logbitp i x) - (logbitp i y)) - (and (not (logbitp i x)) - (not (logbitp i y)))) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) + for y = (random-from-interval (ash 1 (random 200))) + for z = (logeqv x y) + repeat 1000 + unless (and (if (or (and (< x 0) (< y 0)) + (and (>= x 0) (>= y 0))) + (< z 0) + (>= z 0)) + (loop for i from 1 to 210 + always (if (or (and (logbitp i x) + (logbitp i y)) + (and (not (logbitp i x)) + (not (logbitp i y)))) + (logbitp i z) + (not (logbitp i z))))) + collect (list x y z)) nil) (deftest logeqv.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) - for args = (nconc (make-list (1- i) :initial-element -1) - (list 7131)) - always (eql (apply #'logeqv args) 7131)) - t) + for args = (nconc (make-list (1- i) :initial-element -1) + (list 7131)) + always (eql (apply #'logeqv args) 7131)) + t) (deftest logeqv.order.1 (let ((i 0) a b) (values (logeqv (progn (setf a (incf i)) #b11011) - (progn (setf b (incf i)) (lognot #b10110))) + (progn (setf b (incf i)) (lognot #b10110))) i a b)) #b1101 2 1 2) - + (deftest logeqv.order.2 (let ((i 0) a b c) (values (logeqv (progn (setf a (incf i)) #b11011) - (progn (setf b (incf i)) #b10110) - (progn (setf c (incf i)) #b110101)) + (progn (setf b (incf i)) #b10110) + (progn (setf c (incf i)) #b110101)) i a b c)) #b111000 3 1 2 3) diff --git a/ansi-tests/logical-pathname.lsp b/ansi-tests/logical-pathname.lsp index aebbd393..4eed837d 100644 --- a/ansi-tests/logical-pathname.lsp +++ b/ansi-tests/logical-pathname.lsp @@ -7,7 +7,7 @@ (deftest logical-pathname.1 (loop for x in *logical-pathnames* - always (eql x (logical-pathname x))) + always (eql x (logical-pathname x))) t) (deftest logical-pathname.2 @@ -18,11 +18,11 @@ (let ((name "CLTEST:TEMP.DAT.NEWEST")) (with-open-file (s (logical-pathname name) - :direction :output - :if-exists :supersede - :if-does-not-exist :create) + :direction :output + :if-exists :supersede + :if-does-not-exist :create) (or (equalt (logical-pathname s) (logical-pathname name)) - (list (logical-pathname s) (logical-pathname name))))) + (list (logical-pathname s) (logical-pathname name))))) t) @@ -30,7 +30,7 @@ (deftest logical-pathname.error.1 (check-type-error #'logical-pathname - (typef '(or string stream logical-pathname))) + (typef '(or string stream logical-pathname))) nil) (deftest logical-pathname.error.2 @@ -41,7 +41,7 @@ (deftest logical-pathname.error.3 (signals-error (with-open-file (s #p"logical-pathname.lsp" :direction :input) - (logical-pathname s)) + (logical-pathname s)) type-error) t) @@ -79,7 +79,7 @@ (deftest logical-pathname.error.8 (signals-error (with-open-stream (s (make-string-input-stream "foo")) - (logical-pathname s)) type-error) + (logical-pathname s)) type-error) t) (deftest logical-pathname.error.9 diff --git a/ansi-tests/logior.lsp b/ansi-tests/logior.lsp index 77c46d24..317c4406 100644 --- a/ansi-tests/logior.lsp +++ b/ansi-tests/logior.lsp @@ -33,50 +33,50 @@ (deftest logior.4 (loop for x in *integers* - always (eql x (logior x))) + always (eql x (logior x))) t) (deftest logior.5 (loop for x in *integers* - always (eql -1 (logior x (lognot x)))) + always (eql -1 (logior x (lognot x)))) t) (deftest logior.6 (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql -1 (logior x xc)) - collect x) + for xc = (lognot x) + repeat 1000 + unless (eql -1 (logior x xc)) + collect x) nil) (deftest logior.7 (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logior x y) - repeat 1000 - unless (and (if (or (< x 0) (< y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (or (logbitp i x) - (logbitp i y)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) + for y = (random-from-interval (ash 1 (random 200))) + for z = (logior x y) + repeat 1000 + unless (and (if (or (< x 0) (< y 0)) + (< z 0) + (>= z 0)) + (loop for i from 1 to 210 + always (if (or (logbitp i x) + (logbitp i y)) + (logbitp i z) + (not (logbitp i z))))) + collect (list x y z)) nil) (deftest logior.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) - for args = (nconc (make-list (1- i) :initial-element 0) - (list -21231)) - always (eql (apply #'logior args) -21231)) + for args = (nconc (make-list (1- i) :initial-element 0) + (list -21231)) + always (eql (apply #'logior args) -21231)) t) (deftest logior.order.1 (let ((i 0) a b) (values (logior (progn (setf a (incf i)) #b11010) - (progn (setf b (incf i)) #b10110)) + (progn (setf b (incf i)) #b10110)) i a b)) #b11110 2 1 2) @@ -84,8 +84,8 @@ (let ((i 0) a b c) (values (logior (progn (setf a (incf i)) #b10011) - (progn (setf b (incf i)) #b10110) - (progn (setf c (incf i)) #b110101)) + (progn (setf b (incf i)) #b10110) + (progn (setf c (incf i)) #b110101)) i a b c)) #b110111 3 1 2 3) diff --git a/ansi-tests/lognand.lsp b/ansi-tests/lognand.lsp index cb5fbbdb..ca4dabdc 100644 --- a/ansi-tests/lognand.lsp +++ b/ansi-tests/lognand.lsp @@ -45,41 +45,41 @@ (deftest lognand.4 (loop for x in *integers* - always (and (eql -1 (lognand 0 x)) - (eql (lognot x) (lognand x x)) - (eql -1 (lognand (lognot x) x)) - (eql -1 (lognand x (lognot x))))) + always (and (eql -1 (lognand 0 x)) + (eql (lognot x) (lognand x x)) + (eql -1 (lognand (lognot x) x)) + (eql -1 (lognand x (lognot x))))) t) (deftest lognand.5 (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql -1 (lognand xc x)) - collect x) + for xc = (lognot x) + repeat 1000 + unless (eql -1 (lognand xc x)) + collect x) nil) (deftest lognand.6 (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (lognand x y) - repeat 1000 - unless (and (if (or (>= x 0) (>= y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (not (and (logbitp i x) - (logbitp i y))) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) + for y = (random-from-interval (ash 1 (random 200))) + for z = (lognand x y) + repeat 1000 + unless (and (if (or (>= x 0) (>= y 0)) + (< z 0) + (>= z 0)) + (loop for i from 1 to 210 + always (if (not (and (logbitp i x) + (logbitp i y))) + (logbitp i z) + (not (logbitp i z))))) + collect (list x y z)) nil) (deftest lognand.order.1 (let ((i 0) a b) (values (lognand (progn (setf a (incf i)) -2) - (progn (setf b (incf i)) -3)) + (progn (setf b (incf i)) -3)) i a b)) 3 2 1 2) diff --git a/ansi-tests/lognor.lsp b/ansi-tests/lognor.lsp index 24f003b8..9c978f58 100644 --- a/ansi-tests/lognor.lsp +++ b/ansi-tests/lognor.lsp @@ -45,41 +45,41 @@ (deftest lognor.4 (loop for x in *integers* - always (and (eql (lognot x) (lognor 0 x)) - (eql (lognot x) (lognor x x)) - (eql 0 (lognor (lognot x) x)) - (eql 0 (lognor x (lognot x))))) + always (and (eql (lognot x) (lognor 0 x)) + (eql (lognot x) (lognor x x)) + (eql 0 (lognor (lognot x) x)) + (eql 0 (lognor x (lognot x))))) t) (deftest lognor.5 (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql 0 (lognor xc x)) - collect x) + for xc = (lognot x) + repeat 1000 + unless (eql 0 (lognor xc x)) + collect x) nil) (deftest lognor.6 (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (lognor x y) - repeat 1000 - unless (and (if (and (>= x 0) (>= y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (not (or (logbitp i x) - (logbitp i y))) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) + for y = (random-from-interval (ash 1 (random 200))) + for z = (lognor x y) + repeat 1000 + unless (and (if (and (>= x 0) (>= y 0)) + (< z 0) + (>= z 0)) + (loop for i from 1 to 210 + always (if (not (or (logbitp i x) + (logbitp i y))) + (logbitp i z) + (not (logbitp i z))))) + collect (list x y z)) nil) (deftest lognor.order.1 (let ((i 0) a b) (values (lognor (progn (setf a (incf i)) -2) - (progn (setf b (incf i)) -3)) + (progn (setf b (incf i)) -3)) i a b)) 0 2 1 2) diff --git a/ansi-tests/lognot.lsp b/ansi-tests/lognot.lsp index 9015b344..ef41c146 100644 --- a/ansi-tests/lognot.lsp +++ b/ansi-tests/lognot.lsp @@ -37,12 +37,12 @@ (deftest lognot.4 (loop for x = (random-from-interval (ash 1 (random 200))) - for z = (lognot x) - repeat 1000 - unless (and (if (>= x 0) (< z 0) (>= z 0)) - (loop for i from 1 to 210 - always (if (not (logbitp i x)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x z)) + for z = (lognot x) + repeat 1000 + unless (and (if (>= x 0) (< z 0) (>= z 0)) + (loop for i from 1 to 210 + always (if (not (logbitp i x)) + (logbitp i z) + (not (logbitp i z))))) + collect (list x z)) nil) diff --git a/ansi-tests/logorc1.lsp b/ansi-tests/logorc1.lsp index b781b7c0..211d3dcc 100644 --- a/ansi-tests/logorc1.lsp +++ b/ansi-tests/logorc1.lsp @@ -49,41 +49,41 @@ (deftest logorc1.4 (loop for x in *integers* - always (and (eql -1 (logorc1 0 x)) - (eql x (logorc1 -1 x)) - (eql -1 (logorc1 x x)) - (eql x (logorc1 (lognot x) x)) - (eql (lognot x) (logorc1 x (lognot x))))) + always (and (eql -1 (logorc1 0 x)) + (eql x (logorc1 -1 x)) + (eql -1 (logorc1 x x)) + (eql x (logorc1 (lognot x) x)) + (eql (lognot x) (logorc1 x (lognot x))))) t) (deftest logorc1.5 (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql x (logorc1 xc x)) - collect x) + for xc = (lognot x) + repeat 1000 + unless (eql x (logorc1 xc x)) + collect x) nil) (deftest logorc1.6 (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logorc1 x y) - repeat 1000 - unless (and (if (or (>= x 0) (< y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (or (not (logbitp i x)) - (logbitp i y)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) + for y = (random-from-interval (ash 1 (random 200))) + for z = (logorc1 x y) + repeat 1000 + unless (and (if (or (>= x 0) (< y 0)) + (< z 0) + (>= z 0)) + (loop for i from 1 to 210 + always (if (or (not (logbitp i x)) + (logbitp i y)) + (logbitp i z) + (not (logbitp i z))))) + collect (list x y z)) nil) (deftest logorc1.order.1 (let ((i 0) a b) (values (logorc1 (progn (setf a (incf i)) -3) - (progn (setf b (incf i)) 17)) + (progn (setf b (incf i)) 17)) i a b)) 19 2 1 2) diff --git a/ansi-tests/logorc2.lsp b/ansi-tests/logorc2.lsp index d94e8f36..116ba4b3 100644 --- a/ansi-tests/logorc2.lsp +++ b/ansi-tests/logorc2.lsp @@ -49,42 +49,42 @@ (deftest logorc2.4 (loop for x in *integers* - always (and (eql -1 (logorc2 x 0)) - (eql x (logorc2 x -1)) - (eql -1 (logorc2 x x)) - (eql x (logorc2 x (lognot x))) - (eql (lognot x) (logorc2 (lognot x) x)))) + always (and (eql -1 (logorc2 x 0)) + (eql x (logorc2 x -1)) + (eql -1 (logorc2 x x)) + (eql x (logorc2 x (lognot x))) + (eql (lognot x) (logorc2 (lognot x) x)))) t) (deftest logorc2.5 (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql x (logorc2 x xc)) - collect x) + for xc = (lognot x) + repeat 1000 + unless (eql x (logorc2 x xc)) + collect x) nil) (deftest logorc2.6 (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logorc2 x y) - repeat 1000 - unless (and (if (or (< x 0) (>= y 0)) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (or (not (logbitp i y)) - (logbitp i x)) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) + for y = (random-from-interval (ash 1 (random 200))) + for z = (logorc2 x y) + repeat 1000 + unless (and (if (or (< x 0) (>= y 0)) + (< z 0) + (>= z 0)) + (loop for i from 1 to 210 + always (if (or (not (logbitp i y)) + (logbitp i x)) + (logbitp i z) + (not (logbitp i z))))) + collect (list x y z)) nil) (deftest logorc2.order.1 (let ((i 0) a b) (values (logorc2 (progn (setf a (incf i)) 27) - (progn (setf b (incf i)) -1)) + (progn (setf b (incf i)) -1)) i a b)) 27 2 1 2) diff --git a/ansi-tests/logtest.lsp b/ansi-tests/logtest.lsp index 654a9d28..64ca6317 100644 --- a/ansi-tests/logtest.lsp +++ b/ansi-tests/logtest.lsp @@ -31,12 +31,12 @@ (deftest logtest.1 (loop for x = (logand (random-fixnum) (random-fixnum)) - for y = (logand (random-fixnum) (random-fixnum)) - repeat 10000 - unless (if (logtest x y) - (not (zerop (logand x y))) - (zerop (logand x y))) - collect (list x y)) + for y = (logand (random-fixnum) (random-fixnum)) + repeat 10000 + unless (if (logtest x y) + (not (zerop (logand x y))) + (zerop (logand x y))) + collect (list x y)) nil) (deftest logtest.2 @@ -46,6 +46,6 @@ (deftest logtest.3 (notnot-mv (logtest 8 (logior 8 4))) t) - - + + diff --git a/ansi-tests/logxor.lsp b/ansi-tests/logxor.lsp index 933f9809..271edb5e 100644 --- a/ansi-tests/logxor.lsp +++ b/ansi-tests/logxor.lsp @@ -34,65 +34,65 @@ (deftest logxor.4 (loop for x in *integers* - always (eql x (logxor x))) + always (eql x (logxor x))) t) (deftest logxor.5 (loop for x in *integers* - always (and (eql -1 (logxor x (lognot x))) - (eql 0 (logxor x x)) - (eql x (logxor x x x)))) + always (and (eql -1 (logxor x (lognot x))) + (eql 0 (logxor x x)) + (eql x (logxor x x x)))) t) (deftest logxor.6 (loop for x = (random-fixnum) - for xc = (lognot x) - repeat 1000 - unless (eql -1 (logxor x xc)) - collect x) + for xc = (lognot x) + repeat 1000 + unless (eql -1 (logxor x xc)) + collect x) nil) (deftest logxor.7 (loop for x = (random-from-interval (ash 1 (random 200))) - for y = (random-from-interval (ash 1 (random 200))) - for z = (logxor x y) - repeat 1000 - unless (and (if (or (and (< x 0) (>= y 0)) - (and (>= x 0) (< y 0))) - (< z 0) - (>= z 0)) - (loop for i from 1 to 210 - always (if (or (and (logbitp i x) - (not (logbitp i y))) - (and (not (logbitp i x)) - (logbitp i y))) - (logbitp i z) - (not (logbitp i z))))) - collect (list x y z)) + for y = (random-from-interval (ash 1 (random 200))) + for z = (logxor x y) + repeat 1000 + unless (and (if (or (and (< x 0) (>= y 0)) + (and (>= x 0) (< y 0))) + (< z 0) + (>= z 0)) + (loop for i from 1 to 210 + always (if (or (and (logbitp i x) + (not (logbitp i y))) + (and (not (logbitp i x)) + (logbitp i y))) + (logbitp i z) + (not (logbitp i z))))) + collect (list x y z)) nil) (deftest logxor.8 (loop for i from 1 to (min 256 (1- call-arguments-limit)) - for args = (nconc (make-list (1- i) :initial-element 0) - (list 7131)) - always (eql (apply #'logxor args) 7131)) + for args = (nconc (make-list (1- i) :initial-element 0) + (list 7131)) + always (eql (apply #'logxor args) 7131)) t) (deftest logxor.order.1 (let ((i 0) a b) (values (logxor (progn (setf a (incf i)) #b11011) - (progn (setf b (incf i)) #b10110)) + (progn (setf b (incf i)) #b10110)) i a b)) #b1101 2 1 2) - + (deftest logxor.order.2 (let ((i 0) a b c) (values (logxor (progn (setf a (incf i)) #b11011) - (progn (setf b (incf i)) #b10110) - (progn (setf c (incf i)) #b110101)) + (progn (setf b (incf i)) #b10110) + (progn (setf c (incf i)) #b110101)) i a b c)) #b111000 3 1 2 3) diff --git a/ansi-tests/loop.lsp b/ansi-tests/loop.lsp index ce501bc5..a2df304b 100644 --- a/ansi-tests/loop.lsp +++ b/ansi-tests/loop.lsp @@ -36,9 +36,9 @@ (block foo (tagbody (loop - (when (>= i 4) (go a)) - (incf i) - (push 'a x)) + (when (>= i 4) (go a)) + (incf i) + (push 'a x)) a (return-from foo x)))) (a a a a)) @@ -61,23 +61,23 @@ (loop for i from 1 to 10 do (macrolet - ((%m (&environment env) - (let ((mfn (macro-function 'loop-finish env))) - (cond - ((not mfn) '(return-from done :fail1)) - ((not (eval `(signals-error (funcall ,mfn) - program-error))) - '(return-from done :fail2)) - ((not (eval `(signals-error (funcall ,mfn - '(loop-finish)) - program-error))) - '(return-from done :fail3)) - - ((not (eval `(signals-error (funcall ,mfn - '(loop-finish) - nil nil) - program-error))) - '(return-from done :fail4)) - (t '(return-from done :good)))))) - (%m)))) + ((%m (&environment env) + (let ((mfn (macro-function 'loop-finish env))) + (cond + ((not mfn) '(return-from done :fail1)) + ((not (eval `(signals-error (funcall ,mfn) + program-error))) + '(return-from done :fail2)) + ((not (eval `(signals-error (funcall ,mfn + '(loop-finish)) + program-error))) + '(return-from done :fail3)) + + ((not (eval `(signals-error (funcall ,mfn + '(loop-finish) + nil nil) + program-error))) + '(return-from done :fail4)) + (t '(return-from done :good)))))) + (%m)))) :good) diff --git a/ansi-tests/loop1.lsp b/ansi-tests/loop1.lsp index 8cd6355e..36f8f8da 100644 --- a/ansi-tests/loop1.lsp +++ b/ansi-tests/loop1.lsp @@ -92,7 +92,7 @@ (deftest loop.1.20 (let ((a 0) (b 5) (c 1)) (loop for x from a to b by c - collect (progn (incf a) (incf b 2) (incf c 3) x))) + collect (progn (incf a) (incf b 2) (incf c 3) x))) (0 1 2 3 4 5)) (deftest loop.1.21 @@ -131,9 +131,9 @@ (let (a b c (i 0)) (values (loop for x from (progn (setq a (incf i)) 0) - below (progn (setq b (incf i)) 9) - by (progn (setq c (incf i)) 2) - collect x) + below (progn (setq b (incf i)) 9) + by (progn (setq c (incf i)) 2) + collect x) a b c i)) (0 2 4 6 8) 1 2 3 3) @@ -142,9 +142,9 @@ (let (a b c (i 0)) (values (loop for x from (progn (setq a (incf i)) 0) - by (progn (setq c (incf i)) 2) - below (progn (setq b (incf i)) 9) - collect x) + by (progn (setq c (incf i)) 2) + below (progn (setq b (incf i)) 9) + collect x) a b c i)) (0 2 4 6 8) 1 3 2 3) @@ -153,10 +153,10 @@ (let (a b c (i 0)) (values (loop for x - below (progn (setq b (incf i)) 9) - by (progn (setq c (incf i)) 2) - from (progn (setq a (incf i)) 0) - collect x) + below (progn (setq b (incf i)) 9) + by (progn (setq c (incf i)) 2) + from (progn (setq a (incf i)) 0) + collect x) a b c i)) (0 2 4 6 8) 3 1 2 3) @@ -165,10 +165,10 @@ (let (a b c (i 0)) (values (loop for x - by (progn (setq c (incf i)) 2) - below (progn (setq b (incf i)) 9) - from (progn (setq a (incf i)) 0) - collect x) + by (progn (setq c (incf i)) 2) + below (progn (setq b (incf i)) 9) + from (progn (setq a (incf i)) 0) + collect x) a b c i)) (0 2 4 6 8) 3 2 1 3) @@ -280,7 +280,7 @@ (deftest loop.1.54 (let ((i 0)) (loop for nil from 1 to 4 - for nil from 1 to 10 collect (incf i))) + for nil from 1 to 10 collect (incf i))) (1 2 3 4)) (deftest loop.1.55 @@ -318,32 +318,32 @@ (macrolet ((%m (z) z)) (loop for i downfrom (expand-in-current-env (%m 10)) - to 3 - collect i)) + to 3 + collect i)) (10 9 8 7 6 5 4 3)) (deftest loop.1.61 (macrolet ((%m (z) z)) (loop for i downfrom 10 - to (expand-in-current-env (%m 3)) - collect i)) + to (expand-in-current-env (%m 3)) + collect i)) (10 9 8 7 6 5 4 3)) (deftest loop.1.62 (macrolet ((%m (z) z)) (loop for i from (expand-in-current-env (%m 10)) - downto 3 - collect i)) + downto 3 + collect i)) (10 9 8 7 6 5 4 3)) (deftest loop.1.63 (macrolet ((%m (z) z)) (loop for i from 10 - downto (expand-in-current-env (%m 3)) - collect i)) + downto (expand-in-current-env (%m 3)) + collect i)) (10 9 8 7 6 5 4 3)) (deftest loop.1.64 @@ -351,11 +351,11 @@ ((%m (z) z)) (loop for i from (expand-in-current-env (%m 1)) below 5 collect i)) (1 2 3 4)) - + (deftest loop.1.65 (macrolet ((%m (z) z)) (loop for i from 1 below (expand-in-current-env (%m 5)) collect i)) (1 2 3 4)) - + diff --git a/ansi-tests/loop10.lsp b/ansi-tests/loop10.lsp index 5e000d4e..95278c08 100644 --- a/ansi-tests/loop10.lsp +++ b/ansi-tests/loop10.lsp @@ -27,7 +27,7 @@ (let (z) (values (loop for x from 1 to 10 count (< x 5) into foo - finally (setq z foo)) + finally (setq z foo)) z)) nil 4) @@ -36,7 +36,7 @@ (let (z) (values (loop for x from 1 to 10 count (< x 5) into foo fixnum - finally (setq z foo)) + finally (setq z foo)) z)) nil 4) @@ -45,7 +45,7 @@ (let (z) (values (loop for x from 1 to 10 count (< x 5) into foo of-type (integer 0 100) - finally (setq z foo)) + finally (setq z foo)) z)) nil 4) @@ -54,7 +54,7 @@ (let (z) (values (loop for x from 1 to 10 count (< x 5) into foo float - finally (setq z foo)) + finally (setq z foo)) z)) nil 4.0) @@ -62,16 +62,16 @@ (deftest loop.10.9 (signals-error (loop with foo = 10 - for x in '(a b c) count x into foo - finally (return foo)) + for x in '(a b c) count x into foo + finally (return foo)) program-error) t) (deftest loop.10.10 (signals-error (loop with foo = 10 - for x in '(a b c) counting x into foo - finally (return foo)) + for x in '(a b c) counting x into foo + finally (return foo)) program-error) t) @@ -81,26 +81,26 @@ (let ((*loop-count-var* 100)) (values (loop for x in '(a b c d) count x into *loop-count-var* - finally (return *loop-count-var*)) + finally (return *loop-count-var*)) *loop-count-var*)) 4 100) (deftest loop.10.12 (loop for x in '(a b nil d nil e) - count x into foo - collect foo) + count x into foo + collect foo) (1 2 2 3 3 4)) - + (deftest loop.10.13 (loop for x in '(a b nil d nil e) - counting x into foo - collect foo) + counting x into foo + collect foo) (1 2 2 3 3 4)) (deftest loop.10.14 (loop for x in '(a b c) count (return 10)) 10) - + ;;; Tests of MAXIMIZE, MAXIMIZING @@ -181,23 +181,23 @@ (let ((*loop-max-var* 100)) (values (loop for x in '(1 10 4 8) maximize x into *loop-max-var* - finally (return *loop-max-var*)) + finally (return *loop-max-var*)) *loop-max-var*)) 10 100) (deftest loop.10.37 (signals-error (loop with foo = 100 - for i from 1 to 10 maximize i into foo - finally (return foo)) + for i from 1 to 10 maximize i into foo + finally (return foo)) program-error) t) (deftest loop.10.38 (signals-error (loop with foo = 100 - for i from 1 to 10 maximizing i into foo - finally (return foo)) + for i from 1 to 10 maximizing i into foo + finally (return foo)) program-error) t) @@ -285,23 +285,23 @@ (let ((*loop-min-var* 100)) (values (loop for x in '(10 4 8) minimize x into *loop-min-var* - finally (return *loop-min-var*)) + finally (return *loop-min-var*)) *loop-min-var*)) 4 100) (deftest loop.10.57 (signals-error (loop with foo = 100 - for i from 1 to 10 minimize i into foo - finally (return foo)) + for i from 1 to 10 minimize i into foo + finally (return foo)) program-error) t) (deftest loop.10.58 (signals-error (loop with foo = 100 - for i from 1 to 10 minimizing i into foo - finally (return foo)) + for i from 1 to 10 minimizing i into foo + finally (return foo)) program-error) t) @@ -313,22 +313,22 @@ (deftest loop.10.59 (loop for i from 1 to 10 - minimize i - maximize (- i)) + minimize i + maximize (- i)) 1) (deftest loop.10.60 (loop for i from 1 to 10 - maximize (- i) - minimize i) + maximize (- i) + minimize i) -1) (deftest loop.10.61 (loop for i from 5 downto 1 - maximize i - minimize (- i)) + maximize i + minimize (- i)) -1) - + ;;; Tests for SUM, SUMMING @@ -380,55 +380,55 @@ (let (z) (values (loop for i from 1 to 4 sum i into foo of-type (integer 0 10) - finally (setq z foo)) + finally (setq z foo)) z)) nil 10) (deftest loop.10.82 (loop for i from 1 to 4 - sum i fixnum - count t) + sum i fixnum + count t) 14) (deftest loop.10.83 (loop for i from 1 to 4 - sum i fixnum - count t fixnum) + sum i fixnum + count t fixnum) 14) (deftest loop.10.84 (let ((foo 100)) (values (loop for i from 1 to 4 sum i into foo of-type integer - finally (return foo)) + finally (return foo)) foo)) 10 100) (deftest loop.10.85 (signals-error (loop with foo = 100 - for i from 1 to 4 sum i into foo - finally (return foo)) + for i from 1 to 4 sum i into foo + finally (return foo)) program-error) t) (deftest loop.10.86 (signals-error (loop with foo = 100 - for i from 1 to 4 summing i into foo - finally (return foo)) + for i from 1 to 4 summing i into foo + finally (return foo)) program-error) t) (deftest loop.10.87 (loop for i from 1 to 4 - sum (complex i (1+ i)) of-type complex) + sum (complex i (1+ i)) of-type complex) #c(10 14)) (deftest loop.10.88 (loop for i from 1 to 4 - sum (/ i 17) of-type rational) + sum (/ i 17) of-type rational) 10/17) (deftest loop.10.89 @@ -437,16 +437,16 @@ (deftest loop.10.90 (loop for i from 1 to 4 - sum i into foo - sum (1+ i) into bar - finally (return (values foo bar))) + sum i into foo + sum (1+ i) into bar + finally (return (values foo bar))) 10 14) (deftest loop.10.91 (loop for i from 1 to 4 - sum i into foo fixnum - sum (float (1+ i)) into bar float - finally (return (values foo bar))) + sum i into foo fixnum + sum (float (1+ i)) into bar float + finally (return (values foo bar))) 10 14.0) (deftest loop.10.92 diff --git a/ansi-tests/loop11.lsp b/ansi-tests/loop11.lsp index 2175c018..cdeedd1f 100644 --- a/ansi-tests/loop11.lsp +++ b/ansi-tests/loop11.lsp @@ -70,49 +70,49 @@ (deftest loop.11.11 (loop with i = 0 while (if (< i 10) t (return 'good)) - collect (incf i)) + collect (incf i)) good) (deftest loop.11.12 (loop with i = 0 - while (< i 10) collect (incf i) - while (< i 10) collect (incf i) - while (< i 10) collect (incf i)) + while (< i 10) collect (incf i) + while (< i 10) collect (incf i) + while (< i 10) collect (incf i)) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.11.13 (loop with i = 0 while (< i 10) collect (incf i) - finally (return 'done)) + finally (return 'done)) done) (deftest loop.11.14 (loop for i in '(a b c) - while nil - collect i) + while nil + collect i) nil) (deftest loop.11.15 (loop for i in '(a b c) - collect i - while nil) + collect i + while nil) (a)) (deftest loop.11.16 (loop for i in '(a b c) - while t - collect i) + while t + collect i) (a b c)) (deftest loop.11.17 (loop for i in '(a b c) - collect i - while t) + collect i + while t) (a b c)) (deftest loop.11.18 (loop for i from 1 to 10 - while (< i 6) - finally (return i)) + while (< i 6) + finally (return i)) 6) ;;; Tests of UNTIL @@ -123,87 +123,87 @@ (deftest loop.11.21 (loop with i = 0 while (if (< i 10) t (return 'good)) - collect (incf i)) + collect (incf i)) good) (deftest loop.11.22 (loop with i = 0 - until (>= i 10) collect (incf i) - until (>= i 10) collect (incf i) - until (>= i 10) collect (incf i)) + until (>= i 10) collect (incf i) + until (>= i 10) collect (incf i) + until (>= i 10) collect (incf i)) (1 2 3 4 5 6 7 8 9 10)) (deftest loop.11.23 (loop with i = 0 until (>= i 10) collect (incf i) - finally (return 'done)) + finally (return 'done)) done) (deftest loop.11.24 (loop for i in '(a b c) - until t - collect i) + until t + collect i) nil) (deftest loop.11.25 (loop for i in '(a b c) - collect i - until t) + collect i + until t) (a)) (deftest loop.11.26 (loop for i in '(a b c) - until nil - collect i) + until nil + collect i) (a b c)) (deftest loop.11.27 (loop for i in '(a b c) - collect i - until nil) + collect i + until nil) (a b c)) (deftest loop.11.28 (loop for i from 1 to 10 - until (>= i 6) - finally (return i)) + until (>= i 6) + finally (return i)) 6) ;;; More tests of a bug that showed up in c.l.l (deftest loop.11.29 (loop for i in '(4 8 9 A 13) - when (eq i 'a) return :good - while (< i 12) collect i) + when (eq i 'a) return :good + while (< i 12) collect i) :good) (deftest loop.11.30 (loop for i in '(4 8 9 A 13) - unless (numberp i) return :good - while (< i 12) collect i) + unless (numberp i) return :good + while (< i 12) collect i) :good) (deftest loop.11.31 (loop for i in '(4 8 9 A 13) - when (eq i 'a) return :good - until (> i 12) collect i) + when (eq i 'a) return :good + until (> i 12) collect i) :good) (deftest loop.11.32 (loop for i in '(4 8 9 A 13) - unless (numberp i) return :good - until (> i 12) collect i) + unless (numberp i) return :good + until (> i 12) collect i) :good) (deftest loop.11.33 (loop for i in '(4 8 9 A 13) - if (not (numberp i)) return :good end - while (< i 12) collect i) + if (not (numberp i)) return :good end + while (< i 12) collect i) :good) (deftest loop.11.34 (loop for i in '(4 8 9 A 13) - if (not (numberp i)) return :good end - until (> i 12) collect i) + if (not (numberp i)) return :good end + until (> i 12) collect i) :good) ;;; Test that explicit calls to macroexpand in subforms diff --git a/ansi-tests/loop12.lsp b/ansi-tests/loop12.lsp index 1aca66e8..374cacb5 100644 --- a/ansi-tests/loop12.lsp +++ b/ansi-tests/loop12.lsp @@ -21,14 +21,14 @@ (deftest loop.12.4 (loop for i in '(1 2 3 4 5 6 7) - always t - until (> i 5)) + always t + until (> i 5)) t) (deftest loop.12.5 (loop for i in '(1 2 3 4 5 6 7) - always (< i 6) - until (>= i 5)) + always (< i 6) + until (>= i 5)) t) (deftest loop.12.6 @@ -37,44 +37,44 @@ (deftest loop.12.7 (loop for x in '(1 2 3 4 5 6) - always (< x 20) - never (> x 10)) + always (< x 20) + never (> x 10)) t) (deftest loop.12.8 (loop for x in '(1 2 3 4 5 6) - always (< x 20) - never (> x 5)) + always (< x 20) + never (> x 5)) nil) (deftest loop.12.9 (loop for x in '(1 2 3 4 5 6) - never (> x 5) - always (< x 20)) + never (> x 5) + always (< x 20)) nil) (deftest loop.12.10 (loop for x in '(1 2 3 4 5) - always (< x 10) - finally (return 'good)) + always (< x 10) + finally (return 'good)) good) (deftest loop.12.11 (loop for x in '(1 2 3 4 5) - always (< x 3) - finally (return 'bad)) + always (< x 3) + finally (return 'bad)) nil) (deftest loop.12.12 (loop for x in '(1 2 3 4 5 6) - always t - when (= x 4) do (loop-finish)) + always t + when (= x 4) do (loop-finish)) t) (deftest loop.12.13 (loop for x in '(1 2 3 4 5 6) - do (loop-finish) - always nil) + do (loop-finish) + always nil) t) ;;; Tests of NEVER @@ -93,14 +93,14 @@ (deftest loop.12.24 (loop for i in '(1 2 3 4 5 6 7) - never nil - until (> i 5)) + never nil + until (> i 5)) t) (deftest loop.12.25 (loop for i in '(1 2 3 4 5 6 7) - never (>= i 6) - until (>= i 5)) + never (>= i 6) + until (>= i 5)) t) (deftest loop.12.26 @@ -109,44 +109,44 @@ (deftest loop.12.30 (loop for x in '(1 2 3 4 5) - never (>= x 10) - finally (return 'good)) + never (>= x 10) + finally (return 'good)) good) (deftest loop.12.31 (loop for x in '(1 2 3 4 5) - never (>= x 3) - finally (return 'bad)) + never (>= x 3) + finally (return 'bad)) nil) (deftest loop.12.32 (loop for x in '(1 2 3 4 5 6) - never nil - when (= x 4) do (loop-finish)) + never nil + when (= x 4) do (loop-finish)) t) (deftest loop.12.33 (loop for x in '(1 2 3 4 5 6) - do (loop-finish) - never t) + do (loop-finish) + never t) t) ;;; Tests of THEREIS (deftest loop.12.41 (loop for x in '(1 2 3 4 5) - thereis (and (eqlt x 3) 'good)) + thereis (and (eqlt x 3) 'good)) good) (deftest loop.12.42 (loop for x in '(nil nil a nil nil) - thereis x) + thereis x) a) (deftest loop.12.43 (loop for x in '(1 2 3 4 5) - thereis (eql x 4) - when (eql x 2) do (loop-finish)) + thereis (eql x 4) + when (eql x 2) do (loop-finish)) nil) ;;; Error cases @@ -154,48 +154,48 @@ (deftest loop.12.error.50 (signals-error (loop for i from 1 to 10 - collect i - always (< i 20)) + collect i + always (< i 20)) program-error) t) (deftest loop.12.error.50a (signals-error (loop for i from 1 to 10 - always (< i 20) - collect i) + always (< i 20) + collect i) program-error) t) (deftest loop.12.error.51 (signals-error (loop for i from 1 to 10 - collect i - never (> i 20)) + collect i + never (> i 20)) program-error) t) (deftest loop.12.error.51a (signals-error (loop for i from 1 to 10 - never (> i 20) - collect i) + never (> i 20) + collect i) program-error) t) (deftest loop.12.error.52 (signals-error (loop for i from 1 to 10 - collect i - thereis (> i 20)) + collect i + thereis (> i 20)) program-error) t) (deftest loop.12.error.52a (signals-error (loop for i from 1 to 10 - thereis (> i 20) - collect i) + thereis (> i 20) + collect i) program-error) t) @@ -203,38 +203,38 @@ (deftest loop.12.53 (loop for i from 1 to 10 - collect i into foo - always (< i 20)) + collect i into foo + always (< i 20)) t) (deftest loop.12.53a (loop for i from 1 to 10 - always (< i 20) - collect i into foo) + always (< i 20) + collect i into foo) t) (deftest loop.12.54 (loop for i from 1 to 10 - collect i into foo - never (> i 20)) + collect i into foo + never (> i 20)) t) (deftest loop.12.54a (loop for i from 1 to 10 - never (> i 20) - collect i into foo) + never (> i 20) + collect i into foo) t) (deftest loop.12.55 (loop for i from 1 to 10 - collect i into foo - thereis i) + collect i into foo + thereis i) 1) (deftest loop.12.55a (loop for i from 1 to 10 - thereis i - collect i into foo) + thereis i + collect i into foo) 1) ;;; Test that explicit calls to macroexpand in subforms @@ -268,7 +268,7 @@ (macrolet ((%m (z) z)) (loop for i in '(1 2 3 4) - thereis (expand-in-current-env (%m (and (>= i 2) (+ i 1)))))) + thereis (expand-in-current-env (%m (and (>= i 2) (+ i 1)))))) 3) diff --git a/ansi-tests/loop13.lsp b/ansi-tests/loop13.lsp index 73ca72c7..fe664457 100644 --- a/ansi-tests/loop13.lsp +++ b/ansi-tests/loop13.lsp @@ -15,14 +15,14 @@ (deftest loop.13.3 (loop for i from 0 below 100 by 7 - when (> i 50) return i) + when (> i 50) return i) 56) (deftest loop.13.4 (let ((x 0)) (loop do - (incf x) - (when (= x 10) (return x)))) + (incf x) + (when (= x 10) (return x)))) 10) (deftest loop.13.5 @@ -38,9 +38,9 @@ (deftest loop.13.8 (let* ((limit (min 1000 (1- (min call-arguments-limit - multiple-values-limit)))) - (vals (make-list limit :initial-element :a)) - (vals2 (multiple-value-list (eval `(loop return (values ,@vals)))))) + multiple-values-limit)))) + (vals (make-list limit :initial-element :a)) + (vals2 (multiple-value-list (eval `(loop return (values ,@vals)))))) (equalt vals vals2)) t) @@ -67,12 +67,12 @@ (deftest loop.13.13 (loop named foo with b = 1 - and a = (return-from foo :good) return :bad) + and a = (return-from foo :good) return :bad) :good) (deftest loop.13.14 (loop named foo - for a = (return-from foo :good) return :bad) + for a = (return-from foo :good) return :bad) :good) (deftest loop.13.15 @@ -93,12 +93,12 @@ (deftest loop.13.19 (loop named foo for a being the hash-keys of (return-from foo :good) - return :bad) + return :bad) :good) (deftest loop.13.20 (loop named foo for a being the symbols of (return-from foo :good) - return :bad) + return :bad) :good) (deftest loop.13.21 @@ -219,15 +219,15 @@ (deftest loop.13.53 (block nil (loop named foo - with b = 1 - and a = (return :good) return :bad) + with b = 1 + and a = (return :good) return :bad) :bad) :good) (deftest loop.13.54 (block nil (loop named foo - for a = (return :good) return :bad) + for a = (return :good) return :bad) :bad) :good) @@ -258,14 +258,14 @@ (deftest loop.13.59 (block nil (loop named foo for a being the hash-keys of (return :good) - return :bad) + return :bad) :bad) :good) (deftest loop.13.60 (block nil (loop named foo for a being the symbols of (return :good) - return :bad) + return :bad) :bad) :good) @@ -444,7 +444,7 @@ (macrolet ((%m (z) z)) (loop for i from 0 below 100 by 7 - when (> i 50) return (expand-in-current-env (%m i)))) + when (> i 50) return (expand-in-current-env (%m i)))) 56) (deftest loop.13.90 diff --git a/ansi-tests/loop14.lsp b/ansi-tests/loop14.lsp index 76e5d6f8..46d61bb1 100644 --- a/ansi-tests/loop14.lsp +++ b/ansi-tests/loop14.lsp @@ -7,88 +7,88 @@ (deftest loop.14.1 (loop for x from 1 to 6 - when (evenp x) - collect x) + when (evenp x) + collect x) (2 4 6)) (deftest loop.14.2 (loop for x from 1 to 6 - unless (evenp x) - collect x) + unless (evenp x) + collect x) (1 3 5)) (deftest loop.14.3 (loop for x from 1 to 10 - when (evenp x) - collect x into foo - and count t into bar - finally (return (values foo bar))) + when (evenp x) + collect x into foo + and count t into bar + finally (return (values foo bar))) (2 4 6 8 10) 5) (deftest loop.14.4 (loop for x from 1 to 10 - when (evenp x) collect x end) + when (evenp x) collect x end) (2 4 6 8 10)) (deftest loop.14.5 (loop for x from 1 to 10 - when (evenp x) collect x into evens - else collect x into odds - end - finally (return (values evens odds))) + when (evenp x) collect x into evens + else collect x into odds + end + finally (return (values evens odds))) (2 4 6 8 10) (1 3 5 7 9)) (deftest loop.14.6 (loop for x from 1 to 10 - unless (oddp x) - collect x into foo - and count t into bar - finally (return (values foo bar))) + unless (oddp x) + collect x into foo + and count t into bar + finally (return (values foo bar))) (2 4 6 8 10) 5) (deftest loop.14.7 (loop for x from 1 to 10 - unless (oddp x) collect x end) + unless (oddp x) collect x end) (2 4 6 8 10)) (deftest loop.14.8 (loop for x from 1 to 10 - unless (oddp x) collect x into evens - else collect x into odds - end - finally (return (values evens odds))) + unless (oddp x) collect x into evens + else collect x into odds + end + finally (return (values evens odds))) (2 4 6 8 10) (1 3 5 7 9)) (deftest loop.14.9 (loop for x from 1 to 6 - if (evenp x) - collect x) + if (evenp x) + collect x) (2 4 6)) (deftest loop.14.10 (loop for x from 1 to 10 - if (evenp x) - collect x into foo - and count t into bar - finally (return (values foo bar))) + if (evenp x) + collect x into foo + and count t into bar + finally (return (values foo bar))) (2 4 6 8 10) 5) (deftest loop.14.11 (loop for x from 1 to 10 - if (evenp x) collect x end) + if (evenp x) collect x end) (2 4 6 8 10)) (deftest loop.14.12 (loop for x from 1 to 10 - if (evenp x) collect x into evens - else collect x into odds - end - finally (return (values evens odds))) + if (evenp x) collect x into evens + else collect x into odds + end + finally (return (values evens odds))) (2 4 6 8 10) (1 3 5 7 9)) @@ -97,108 +97,108 @@ (deftest loop.14.13 (loop for i from 1 to 20 - if (evenp i) - if (= (mod i 3) 0) - collect i into list1 - else collect i into list2 - finally (return (values list1 list2))) + if (evenp i) + if (= (mod i 3) 0) + collect i into list1 + else collect i into list2 + finally (return (values list1 list2))) (6 12 18) (2 4 8 10 14 16 20)) (deftest loop.14.14 (loop for i from 1 to 20 - when (evenp i) - if (= (mod i 3) 0) - collect i into list1 - else collect i into list2 - finally (return (values list1 list2))) + when (evenp i) + if (= (mod i 3) 0) + collect i into list1 + else collect i into list2 + finally (return (values list1 list2))) (6 12 18) (2 4 8 10 14 16 20)) (deftest loop.14.15 (loop for i from 1 to 20 - if (evenp i) - when (= (mod i 3) 0) - collect i into list1 - else collect i into list2 - finally (return (values list1 list2))) + if (evenp i) + when (= (mod i 3) 0) + collect i into list1 + else collect i into list2 + finally (return (values list1 list2))) (6 12 18) (2 4 8 10 14 16 20)) (deftest loop.14.16 (loop for i from 1 to 20 - if (evenp i) - if (= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) + if (evenp i) + if (= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.17 (loop for i from 1 to 20 - when (evenp i) - if (= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) + when (evenp i) + if (= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.18 (loop for i from 1 to 20 - if (evenp i) - when (= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) + if (evenp i) + when (= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.19 (loop for i from 1 to 20 - when (evenp i) - when (= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) + when (evenp i) + when (= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.20 (loop for i from 1 to 20 - unless (oddp i) - if (= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) + unless (oddp i) + if (= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.21 (loop for i from 1 to 20 - if (evenp i) - unless (/= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) + if (evenp i) + unless (/= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) (deftest loop.14.22 (loop for i from 1 to 20 - unless (oddp i) - unless (/= (mod i 3) 0) - collect i into list1 - end - else collect i into list2 - finally (return (values list1 list2))) + unless (oddp i) + unless (/= (mod i 3) 0) + collect i into list1 + end + else collect i into list2 + finally (return (values list1 list2))) (6 12 18) (1 3 5 7 9 11 13 15 17 19)) @@ -206,12 +206,12 @@ (deftest loop.14.23 (loop for i from 1 to 20 - if (evenp i) - collect i into list1 - else if (= (mod i 3) 0) - collect i into list2 - else collect i into list3 - finally (return (values list1 list2 list3))) + if (evenp i) + collect i into list1 + else if (= (mod i 3) 0) + collect i into list2 + else collect i into list3 + finally (return (values list1 list2 list3))) (2 4 6 8 10 12 14 16 18 20) (3 9 15) (1 5 7 11 13 17 19)) @@ -220,116 +220,116 @@ (deftest loop.14.24 (loop for x in '((a) nil (b) (c) (nil) (d)) - when (car x) collect it) + when (car x) collect it) (a b c d)) (deftest loop.14.25 (loop for x in '((a) nil (b) (c) (nil) (d)) - if (car x) collect it) + if (car x) collect it) (a b c d)) (deftest loop.14.26 (loop for x in '(nil (a) nil (b) (c) (nil) (d)) - when (car x) return it) + when (car x) return it) a) (deftest loop.14.27 (loop for x in '(nil (a) nil (b) (c) (nil) (d)) - if (car x) return it) + if (car x) return it) a) (deftest loop.14.28 (loop for x in '((a) nil (b) (c) (nil) (d)) - when (car x) collect it and collect 'foo) + when (car x) collect it and collect 'foo) (a foo b foo c foo d foo)) (deftest loop.14.29 (let ((it 'z)) (loop for x in '(a b c d) - when x collect it and collect it)) + when x collect it and collect it)) (a z b z c z d z)) (deftest loop.14.30 (let ((it 'z)) (loop for x in '(a b c d) - if x collect it end - collect it)) + if x collect it end + collect it)) (a z b z c z d z)) (deftest loop.14.31 (loop for it on '(a b c d) - when (car it) collect it) + when (car it) collect it) (a b c d)) (deftest loop.14.32 (loop for x in '(a b nil c d nil e) - when x collecting it) + when x collecting it) (a b c d e)) (deftest loop.14.33 (loop for x in '(a b nil c d nil e) - when x append (list x)) + when x append (list x)) (a b c d e)) (deftest loop.14.34 (loop for x in '(a b nil c d nil e) - when x appending (list x)) + when x appending (list x)) (a b c d e)) (deftest loop.14.35 (loop for x in '(a b nil c d nil e) - when x nconc (list x)) + when x nconc (list x)) (a b c d e)) (deftest loop.14.36 (loop for x in '(a b nil c d nil e) - when x nconcing (list x)) + when x nconcing (list x)) (a b c d e)) (deftest loop.14.37 (loop for it on '(a b c d) - when (car it) collect it into foo - finally (return foo)) + when (car it) collect it into foo + finally (return foo)) (a b c d)) (deftest loop.14.38 (loop for x in '(1 2 nil 3 4 nil 5 nil) - when x count it) + when x count it) 5) (deftest loop.14.39 (loop for x in '(1 2 nil 3 4 nil 5 nil) - when x counting it) + when x counting it) 5) (deftest loop.14.40 (loop for x in '(1 2 nil 3 4 nil 6 nil) - when x maximize it) + when x maximize it) 6) (deftest loop.14.41 (loop for x in '(1 2 nil 3 4 nil 6 nil) - when x maximizing it) + when x maximizing it) 6) (deftest loop.14.42 (loop for x in '(1 2 nil 3 4 nil 6 nil) - when x minimize it) + when x minimize it) 1) (deftest loop.14.43 (loop for x in '(1 2 nil 3 4 nil 6 nil) - when x minimizing it) + when x minimizing it) 1) (deftest loop.14.44 (loop for x in '(1 2 nil 3 4 nil 6 nil) - when x sum it) + when x sum it) 16) (deftest loop.14.45 (loop for x in '(1 2 nil 3 4 nil 6 nil) - when x summing it) + when x summing it) 16) ;;; Test that explicit calls to macroexpand in subforms @@ -339,30 +339,30 @@ (macrolet ((%m (z) z)) (loop for x from 1 to 6 - when (expand-in-current-env (%m (evenp x))) - collect x)) + when (expand-in-current-env (%m (evenp x))) + collect x)) (2 4 6)) (deftest loop.14.47 (macrolet ((%m (z) z)) (loop for x from 1 to 6 - unless (expand-in-current-env (%m (evenp x))) - collect x)) + unless (expand-in-current-env (%m (evenp x))) + collect x)) (1 3 5)) (deftest loop.14.48 (macrolet ((%m (z) z)) (loop for x from 1 to 6 - when (expand-in-current-env (%m t)) - sum x)) + when (expand-in-current-env (%m t)) + sum x)) 21) (deftest loop.14.49 (macrolet ((%m (z) z)) (loop for x from 1 to 10 - if (expand-in-current-env (%m (evenp x))) - collect x end)) + if (expand-in-current-env (%m (evenp x))) + collect x end)) (2 4 6 8 10)) diff --git a/ansi-tests/loop15.lsp b/ansi-tests/loop15.lsp index 61c433a0..8e23db57 100644 --- a/ansi-tests/loop15.lsp +++ b/ansi-tests/loop15.lsp @@ -85,62 +85,62 @@ (deftest loop.15.48 (loop :for x :in '(1 2 3 4) :sum x :into foo :of-type fixnum - :finally (return foo)) + :finally (return foo)) 10) (deftest loop.15.49 (loop :for x :upfrom 1 :to 10 - :if (evenp x) :sum x :into foo - :else :sum x :into bar - :end - :finally (return (values foo bar))) + :if (evenp x) :sum x :into foo + :else :sum x :into bar + :end + :finally (return (values foo bar))) 30 25) (deftest loop.15.50 (loop :for x :downfrom 10 :above 0 - :when (evenp x) :sum x :into foo - :else :sum x :into bar - :end - :finally (return (values foo bar))) + :when (evenp x) :sum x :into foo + :else :sum x :into bar + :end + :finally (return (values foo bar))) 30 25) (deftest loop.15.51 (loop :for x :in '(a b nil c d nil) - :unless x :count t) + :unless x :count t) 2) (deftest loop.15.52 (loop :for x :in '(a b nil c d nil) - :unless x :collect x :into bar :and :count t :into foo - :end - finally (return (values bar foo))) + :unless x :collect x :into bar :and :count t :into foo + :end + finally (return (values bar foo))) (nil nil) 2) (deftest loop.15.53 (loop :for x :in '(nil nil a b nil c nil) - :collect x - :until x) + :collect x + :until x) (nil nil a)) (deftest loop.15.54 (loop :for x :in '(a b nil c nil) - :while x :collect x) + :while x :collect x) (a b)) (deftest loop.15.55 (loop :for x :in '(nil nil a b nil c nil) - :thereis x) + :thereis x) a) (deftest loop.15.56 (loop :for x :in '(nil nil a b nil c nil) - :never x) + :never x) nil) (deftest loop.15.57 (loop :for x :in '(a b c d e) - :always x) + :always x) t) (deftest loop.15.58 @@ -161,8 +161,8 @@ (deftest loop.15.62 (loop :for x = '(a b c) :then (cdr x) - :while x - :collect (car x)) + :while x + :collect (car x)) (a b c)) (deftest loop.15.63 @@ -171,34 +171,34 @@ (deftest loop.15.64 (loop :for x :being :the :hash-keys :of (make-hash-table) - :count t) + :count t) 0) (deftest loop.15.65 (loop :for x :being :each :hash-key :in (make-hash-table) - :count t) + :count t) 0) (deftest loop.15.66 (loop :for x :being :each :hash-value :of (make-hash-table) - :count t) + :count t) 0) (deftest loop.15.67 (loop :for x :being :the :hash-values :in (make-hash-table) - :count t) + :count t) 0) (deftest loop.15.68 (loop :for x :being :the :hash-values :in (make-hash-table) - :using (:hash-key k) - :count t) + :using (:hash-key k) + :count t) 0) (deftest loop.15.69 (loop :for x :being :the :hash-keys :in (make-hash-table) - :using (:hash-value v) - :count t) + :using (:hash-value v) + :count t) 0) (deftest loop.15.70 diff --git a/ansi-tests/loop16.lsp b/ansi-tests/loop16.lsp index 303380e2..ba8d1ff9 100644 --- a/ansi-tests/loop16.lsp +++ b/ansi-tests/loop16.lsp @@ -84,62 +84,62 @@ (deftest loop.16.48 (loop #:for x #:in '(1 2 3 4) #:sum x #:into foo #:of-type fixnum - #:finally (return foo)) + #:finally (return foo)) 10) (deftest loop.16.49 (loop #:for x #:upfrom 1 #:to 10 - #:if (evenp x) #:sum x #:into foo - #:else #:sum x #:into bar - #:end - #:finally (return (values foo bar))) + #:if (evenp x) #:sum x #:into foo + #:else #:sum x #:into bar + #:end + #:finally (return (values foo bar))) 30 25) (deftest loop.16.50 (loop #:for x #:downfrom 10 #:above 0 - #:when (evenp x) #:sum x #:into foo - #:else #:sum x #:into bar - #:end - #:finally (return (values foo bar))) + #:when (evenp x) #:sum x #:into foo + #:else #:sum x #:into bar + #:end + #:finally (return (values foo bar))) 30 25) (deftest loop.16.51 (loop #:for x #:in '(a b nil c d nil) - #:unless x #:count t) + #:unless x #:count t) 2) (deftest loop.16.52 (loop #:for x #:in '(a b nil c d nil) - #:unless x #:collect x #:into bar #:and #:count t #:into foo - #:end - finally (return (values bar foo))) + #:unless x #:collect x #:into bar #:and #:count t #:into foo + #:end + finally (return (values bar foo))) (nil nil) 2) (deftest loop.16.53 (loop #:for x #:in '(nil nil a b nil c nil) - #:collect x - #:until x) + #:collect x + #:until x) (nil nil a)) (deftest loop.16.54 (loop #:for x #:in '(a b nil c nil) - #:while x #:collect x) + #:while x #:collect x) (a b)) (deftest loop.16.55 (loop #:for x #:in '(nil nil a b nil c nil) - #:thereis x) + #:thereis x) a) (deftest loop.16.56 (loop #:for x #:in '(nil nil a b nil c nil) - #:never x) + #:never x) nil) (deftest loop.16.57 (loop #:for x #:in '(a b c d e) - #:always x) + #:always x) t) (deftest loop.16.58 @@ -160,8 +160,8 @@ (deftest loop.16.62 (loop #:for x = '(a b c) #:then (cdr x) - #:while x - #:collect (car x)) + #:while x + #:collect (car x)) (a b c)) (deftest loop.16.63 @@ -170,34 +170,34 @@ (deftest loop.16.64 (loop #:for x #:being #:the #:hash-keys #:of (make-hash-table) - #:count t) + #:count t) 0) (deftest loop.16.65 (loop #:for x #:being #:each #:hash-key #:in (make-hash-table) - #:count t) + #:count t) 0) (deftest loop.16.66 (loop #:for x #:being #:each #:hash-value #:of (make-hash-table) - #:count t) + #:count t) 0) (deftest loop.16.67 (loop #:for x #:being #:the #:hash-values #:in (make-hash-table) - #:count t) + #:count t) 0) (deftest loop.16.68 (loop #:for x #:being #:the #:hash-values #:in (make-hash-table) - #:using (#:hash-key k) - #:count t) + #:using (#:hash-key k) + #:count t) 0) (deftest loop.16.69 (loop #:for x #:being #:the #:hash-keys #:in (make-hash-table) - #:using (#:hash-value v) - #:count t) + #:using (#:hash-value v) + #:count t) 0) (deftest loop.16.70 diff --git a/ansi-tests/loop17.lsp b/ansi-tests/loop17.lsp index 6ec68869..68ce53ed 100644 --- a/ansi-tests/loop17.lsp +++ b/ansi-tests/loop17.lsp @@ -139,7 +139,7 @@ (macrolet ((%m (z) z)) (loop with x = 0 - initially (expand-in-current-env (%m (incf x))) - until t - finally (expand-in-current-env (%m (return x))))) + initially (expand-in-current-env (%m (incf x))) + until t + finally (expand-in-current-env (%m (return x))))) 1) diff --git a/ansi-tests/loop2.lsp b/ansi-tests/loop2.lsp index 5ec87da0..cb7d102d 100644 --- a/ansi-tests/loop2.lsp +++ b/ansi-tests/loop2.lsp @@ -12,12 +12,12 @@ (deftest loop.2.2 (loop for x in '(1 2 3 4) - do (when (evenp x) (return x))) + do (when (evenp x) (return x))) 2) (deftest loop.2.3 (signals-error (loop for x in '(a . b) collect x) - type-error) + type-error) t) (deftest loop.2.4 @@ -28,55 +28,55 @@ (deftest loop.2.5 (loop for e in '(a b c d e f) by #'cddr - collect e) + collect e) (a c e)) (deftest loop.2.6 (loop for e in '(a b c d e f g) by #'cddr - collect e) + collect e) (a c e g)) (deftest loop.2.7 (loop for e in '(a b c d e f) - by #'(lambda (l) (and (cdr l) (cons (car l) (cddr l)))) - collect e) + by #'(lambda (l) (and (cdr l) (cons (car l) (cddr l)))) + collect e) (a a a a a a)) (deftest loop.2.8 (loop for (x . y) in '((a . b) (c . d) (e . f)) - collect (list x y)) + collect (list x y)) ((a b) (c d) (e f))) (deftest loop.2.9 (loop for (x nil y) in '((a b c) (d e f) (g h i)) - collect (list x y)) + collect (list x y)) ((a c) (d f) (g i))) (deftest loop.2.10 (loop for (x y) of-type fixnum in '((1 2) (3 4) (5 6)) - collect (+ x y)) + collect (+ x y)) (3 7 11)) (deftest loop.2.11 (loop for (x y) of-type fixnum in '((1 2) (3 4) (5 6)) - collect (+ x y)) + collect (+ x y)) (3 7 11)) (deftest loop.2.12 (loop for (x y) of-type (fixnum fixnum) in '((1 2) (3 4) (5 6)) - collect (+ x y)) + collect (+ x y)) (3 7 11)) (deftest loop.2.13 (loop for (x . y) of-type (fixnum . fixnum) in '((1 . 2) (3 . 4) (5 . 6)) - collect (+ x y)) + collect (+ x y)) (3 7 11)) (deftest loop.2.14 (signals-error (loop for x in '(a b c) - for x in '(d e f) collect x) + for x in '(d e f) collect x) program-error) t) @@ -103,7 +103,7 @@ (deftest loop.2.18 (loop for x of-type (integer 0 10) in '(2 4 6 7) sum x) 19) - + ;;; Tests of the 'AS' form (deftest loop.2.19 @@ -112,29 +112,29 @@ (deftest loop.2.20 (loop as x in '(a b c) - as y in '(1 2 3) - collect (list x y)) + as y in '(1 2 3) + collect (list x y)) ((a 1) (b 2) (c 3))) (deftest loop.2.21 (loop as x in '(a b c) - for y in '(1 2 3) - collect (list x y)) + for y in '(1 2 3) + collect (list x y)) ((a 1) (b 2) (c 3))) (deftest loop.2.22 (loop for x in '(a b c) - as y in '(1 2 3) - collect (list x y)) + as y in '(1 2 3) + collect (list x y)) ((a 1) (b 2) (c 3))) (deftest loop.2.23 (let (a b (i 0)) (values (loop for e in (progn (setf a (incf i)) - '(a b c d e f g)) - by (progn (setf b (incf i)) #'cddr) - collect e) + '(a b c d e f g)) + by (progn (setf b (incf i)) #'cddr) + collect e) a b i)) (a c e g) 1 2 2) @@ -153,11 +153,11 @@ (macrolet ((%m (z) z)) (loop for (x . y) in (expand-in-current-env (%m '((a . b) (c . d) (e . f)))) - collect (list x y))) + collect (list x y))) ((a b) (c d) (e f))) (deftest loop.2.26 (macrolet ((%m (z) z)) (loop as x in (expand-in-current-env (%m '(1 2 3))) sum x)) - 6) \ No newline at end of file + 6) diff --git a/ansi-tests/loop3.lsp b/ansi-tests/loop3.lsp index eca484df..d2dcba2c 100644 --- a/ansi-tests/loop3.lsp +++ b/ansi-tests/loop3.lsp @@ -11,7 +11,7 @@ (deftest loop.3.2 (loop for x on '(1 2 3 4) - do (when (evenp (car x)) (return x))) + do (when (evenp (car x)) (return x))) (2 3 4)) @@ -27,60 +27,60 @@ (deftest loop.3.5 (loop for e on '(a b c d e f) by #'cddr - collect (car e)) + collect (car e)) (a c e)) (deftest loop.3.6 (loop for e on '(a b c d e f g) by #'cddr - collect (car e)) + collect (car e)) (a c e g)) (deftest loop.3.7 (loop for e on '(a b c d e f) - by #'(lambda (l) (and (cdr l) (cons (car l) (cddr l)))) - collect (car e)) + by #'(lambda (l) (and (cdr l) (cons (car l) (cddr l)))) + collect (car e)) (a a a a a a)) (deftest loop.3.8 (loop for ((x . y)) on '((a . b) (c . d) (e . f)) - collect (list x y)) + collect (list x y)) ((a b) (c d) (e f))) (deftest loop.3.9 (loop for ((x nil y)) on '((a b c) (d e f) (g h i)) - collect (list x y)) + collect (list x y)) ((a c) (d f) (g i))) (deftest loop.3.10 (loop for ((x y)) of-type (fixnum) on '((1 2) (3 4) (5 6)) - collect (+ x y)) + collect (+ x y)) (3 7 11)) (deftest loop.3.11 (loop for ((x y)) of-type (fixnum) on '((1 2) (3 4) (5 6)) - collect (+ x y)) + collect (+ x y)) (3 7 11)) (deftest loop.3.12 (loop for ((x y)) of-type ((fixnum fixnum)) on '((1 2) (3 4) (5 6)) - collect (+ x y)) + collect (+ x y)) (3 7 11)) (deftest loop.3.13 (loop for ((x . y)) of-type ((fixnum . fixnum)) on '((1 . 2) (3 . 4) (5 . 6)) - collect (+ x y)) + collect (+ x y)) (3 7 11)) (deftest loop.3.14 (signals-error (loop for x on '(a b c) - for x on '(d e f) collect x) + for x on '(d e f) collect x) program-error) t) (deftest loop.3.15 (signals-error (loop for (x . x) on '((a b) (c d)) collect x) - program-error) + program-error) t) (deftest loop.3.16 @@ -100,7 +100,7 @@ (deftest loop.3.18 (loop for (x) of-type ((integer 0 10)) on '(2 4 6 7) sum x) 19) - + ;;; Tests of the 'AS' form (deftest loop.3.19 @@ -109,29 +109,29 @@ (deftest loop.3.20 (loop as x on '(a b c) - as y on '(1 2 3) - collect (list (car x) (car y))) + as y on '(1 2 3) + collect (list (car x) (car y))) ((a 1) (b 2) (c 3))) (deftest loop.3.21 (loop as x on '(a b c) - for y on '(1 2 3) - collect (list (car x) (car y))) + for y on '(1 2 3) + collect (list (car x) (car y))) ((a 1) (b 2) (c 3))) (deftest loop.3.22 (loop for x on '(a b c) - as y on '(1 2 3) - collect (list (car x) (car y))) + as y on '(1 2 3) + collect (list (car x) (car y))) ((a 1) (b 2) (c 3))) (deftest loop.3.23 (let (a b (i 0)) (values (loop for e on (progn (setf a (incf i)) - '(a b c d e f g)) - by (progn (setf b (incf i)) #'cddr) - collect (car e)) + '(a b c d e f g)) + by (progn (setf b (incf i)) #'cddr) + collect (car e)) a b i)) (a c e g) 1 2 2) @@ -149,15 +149,15 @@ (macrolet ((%m (z) z)) (loop for e on (expand-in-current-env (%m '(a b c d e f))) by #'cddr - collect (car e))) + collect (car e))) (a c e)) (deftest loop.3.26 (macrolet ((%m (z) z)) (loop for e on '(a b c d e f) - by (expand-in-current-env (%m #'cddr)) - collect (car e))) + by (expand-in-current-env (%m #'cddr)) + collect (car e))) (a c e)) (deftest loop.3.27 diff --git a/ansi-tests/loop4.lsp b/ansi-tests/loop4.lsp index 82b15c2c..8e656b7a 100644 --- a/ansi-tests/loop4.lsp +++ b/ansi-tests/loop4.lsp @@ -26,14 +26,14 @@ (deftest loop.4.4 (loop for e on '(a b c d e) - for (x . y) = e - collect x) + for (x . y) = e + collect x) (a b c d e)) (deftest loop.4.5 (loop for (x . y) = '(a b c d e) then y - while x - collect x) + while x + collect x) (a b c d e)) ;;; Error cases @@ -41,21 +41,21 @@ (deftest loop.4.6 (signals-error (loop for (x . x) = '(nil nil nil) - until x count t) + until x count t) program-error) t) (deftest loop.4.7 (signals-error (macroexpand '(loop for (x . x) = '(nil nil nil) - until x count t)) + until x count t)) program-error) t) (deftest loop.4.8 (signals-error (macroexpand '(loop for x = '(nil nil nil) - for x = 1 count x until t)) + for x = 1 count x until t)) program-error) t) diff --git a/ansi-tests/loop5.lsp b/ansi-tests/loop5.lsp index 95dba886..004a94fa 100644 --- a/ansi-tests/loop5.lsp +++ b/ansi-tests/loop5.lsp @@ -23,12 +23,12 @@ (deftest loop.5.5 (loop for e across "abcd" - for i from 1 to 3 collect e) + for i from 1 to 3 collect e) (#\a #\b #\c)) (deftest loop.5.6 (loop for e of-type base-char across "abcd" - for i from 1 to 3 collect e) + for i from 1 to 3 collect e) (#\a #\b #\c)) (deftest loop.5.7 @@ -63,7 +63,7 @@ (deftest loop.5.14 (let ((x #*00010110)) (loop for e of-type bit across x - for i from 1 to 4 collect e)) + for i from 1 to 4 collect e)) (0 0 0 1)) @@ -90,14 +90,14 @@ (deftest loop.5.30 (let ((x (make-array '(5) :initial-contents '(a b c d e) - :adjustable t))) + :adjustable t))) (loop for e across x collect e)) (a b c d e)) (deftest loop.5.32 (let* ((x (make-array '(5) :initial-contents '(a b c d e))) - (y (make-array '(3) :displaced-to x - :displaced-index-offset 1))) + (y (make-array '(3) :displaced-to x + :displaced-index-offset 1))) (loop for e across y collect e)) (b c d)) @@ -113,81 +113,81 @@ (deftest loop.5.35 (loop as e of-type integer across (the simple-vector (coerce '(1 2 3) 'simple-vector)) - sum e) + sum e) 6) ;;; Loop across displaced vectors (deftest loop.5.36 (let* ((a (make-array '(10) :initial-contents '(a b c d e f g h i j))) - (da (make-array '(5) :displaced-to a - :displaced-index-offset 2))) + (da (make-array '(5) :displaced-to a + :displaced-index-offset 2))) (loop for e across da collect e)) (c d e f g)) (deftest loop.5.37 (let* ((a (make-array '(10) :element-type 'base-char - :initial-contents "abcdefghij")) - (da (make-array '(5) :element-type 'base-char - :displaced-to a - :displaced-index-offset 2))) + :initial-contents "abcdefghij")) + (da (make-array '(5) :element-type 'base-char + :displaced-to a + :displaced-index-offset 2))) (loop for e across da collect e)) (#\c #\d #\e #\f #\g)) (deftest loop.5.38 (let* ((a (make-array '(10) :element-type 'bit - :initial-contents '(0 1 1 0 0 1 0 1 1 1))) - (da (make-array '(5) :element-type 'bit - :displaced-to a - :displaced-index-offset 2))) + :initial-contents '(0 1 1 0 0 1 0 1 1 1))) + (da (make-array '(5) :element-type 'bit + :displaced-to a + :displaced-index-offset 2))) (loop for e across da collect e)) (1 0 0 1 0)) (deftest loop.5.39 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 6))) + :fill-pointer 6))) (loop for x across v collect x)) (1 2 3 4 5 6)) (deftest loop.5.40 (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - for v = (make-array '(10) :initial-contents '(0 0 1 1 0 1 1 1 0 0) - :element-type type) - for r = (loop for x across v collect x) - unless (equal r '(0 0 1 1 0 1 1 1 0 0)) - collect (list i r)) + for type = `(unsigned-byte ,i) + for v = (make-array '(10) :initial-contents '(0 0 1 1 0 1 1 1 0 0) + :element-type type) + for r = (loop for x across v collect x) + unless (equal r '(0 0 1 1 0 1 1 1 0 0)) + collect (list i r)) nil) (deftest loop.5.41 (loop for i from 1 to 40 - for type = `(signed-byte ,i) - for v = (make-array '(10) :initial-contents '(0 0 -1 -1 0 -1 -1 -1 0 0) - :element-type type) - for r = (loop for x across v collect x) - unless (equal r '(0 0 -1 -1 0 -1 -1 -1 0 0)) - collect (list i r)) + for type = `(signed-byte ,i) + for v = (make-array '(10) :initial-contents '(0 0 -1 -1 0 -1 -1 -1 0 0) + :element-type type) + for r = (loop for x across v collect x) + unless (equal r '(0 0 -1 -1 0 -1 -1 -1 0 0)) + collect (list i r)) nil) (deftest loop.5.42 (let ((vals '(0 0 1 1 0 1 1 1 0 0))) (loop for type in '(short-float single-float double-float long-float) - for fvals = (loop for v in vals collect (coerce v type)) - for v = (make-array '(10) :initial-contents fvals :element-type type) - for r = (loop for x across v collect x) - unless (equal r fvals) - collect (list fvals r))) + for fvals = (loop for v in vals collect (coerce v type)) + for v = (make-array '(10) :initial-contents fvals :element-type type) + for r = (loop for x across v collect x) + unless (equal r fvals) + collect (list fvals r))) nil) (deftest loop.5.43 (let ((vals '(0 0 1 1 0 1 1 1 0 0))) (loop for etype in '(short-float single-float double-float long-float) - for type = `(complex ,etype) - for fvals = (loop for v in vals collect (coerce v type)) - for v = (make-array '(10) :initial-contents fvals :element-type type) - for r = (loop for x across v collect x) - unless (equal r fvals) - collect (list fvals r))) + for type = `(complex ,etype) + for fvals = (loop for v in vals collect (coerce v type)) + for v = (make-array '(10) :initial-contents fvals :element-type type) + for r = (loop for x across v collect x) + unless (equal r fvals) + collect (list fvals r))) nil) ;;; Test that explicit calls to macroexpand in subforms @@ -219,7 +219,7 @@ (deftest loop.5.error.2 (signals-error (loop for e across (vector '(x . y) '(u . v)) - for e from 1 to 5 collect e) + for e from 1 to 5 collect e) program-error) t) @@ -234,6 +234,6 @@ (signals-error (macroexpand '(loop for e across (vector '(x . y) '(u . v)) - for e from 1 to 5 collect e)) + for e from 1 to 5 collect e)) program-error) t) diff --git a/ansi-tests/loop6.lsp b/ansi-tests/loop6.lsp index 386fe982..422e102b 100644 --- a/ansi-tests/loop6.lsp +++ b/ansi-tests/loop6.lsp @@ -17,43 +17,43 @@ (defparameter *loop.6.hash.1* (let ((table (make-hash-table :test #'eq))) (loop for (key . val) in *loop.6.alist* - do (setf (gethash key table) val)) + do (setf (gethash key table) val)) table)) (defparameter *loop.6.hash.2* (let ((table (make-hash-table :test #'eql))) (loop for (key . val) in *loop.6.alist* - do (setf (gethash key table) val)) + do (setf (gethash key table) val)) table)) (defparameter *loop.6.hash.3* (let ((table (make-hash-table :test #'equal))) (loop for (key . val) in *loop.6.alist.3* - do (setf (gethash key table) val)) + do (setf (gethash key table) val)) table)) ;;; (defparameter *loop.6.hash.4* ;;; (let ((table (make-hash-table :test #'equalp))) ;;; (loop for (key . val) in *loop.6.alist.2* -;;; do (setf (gethash key table) val)) +;;; do (setf (gethash key table) val)) ;;; table)) (defparameter *loop.6.hash.5* (let ((table (make-hash-table :test #'eql))) (loop for (val . key) in *loop.6.alist.3* - do (setf (gethash key table) val)) + do (setf (gethash key table) val)) table)) (defparameter *loop.6.hash.6* (let ((table (make-hash-table :test #'eq))) (loop for (key . val) in *loop.6.alist* - do (setf (gethash key table) (coerce val 'float))) + do (setf (gethash key table) (coerce val 'float))) table)) (defparameter *loop.6.hash.7* (let ((table (make-hash-table :test #'equal))) (loop for (val . key) in *loop.6.alist.3* - do (setf (gethash (coerce key 'float) table) val)) + do (setf (gethash (coerce key 'float) table) val)) table)) (defparameter *loop.6.alist.8* @@ -62,13 +62,13 @@ (defparameter *loop.6.hash.8* (let ((table (make-hash-table :test #'equal))) (loop for (key . val) in *loop.6.alist.8* - do (setf (gethash key table) val)) + do (setf (gethash key table) val)) table)) (defparameter *loop.6.hash.9* (let ((table (make-hash-table :test #'equal))) (loop for (val . key) in *loop.6.alist.8* - do (setf (gethash key table) val)) + do (setf (gethash key table) val)) table)) ;;; being {each | the} {hash-value | hash-values | hash-key | hash-keys} {in | of } @@ -95,69 +95,69 @@ (deftest loop.6.6 (sort (loop for x being the hash-key of *loop.6.hash.1* collect x) - #'symbol<) + #'symbol<) (a b c)) (deftest loop.6.7 (sort (loop for x being the hash-keys of *loop.6.hash.1* collect x) - #'symbol<) + #'symbol<) (a b c)) (deftest loop.6.8 (sort (loop for x being each hash-key of *loop.6.hash.1* collect x) - #'symbol<) + #'symbol<) (a b c)) (deftest loop.6.9 (sort (loop for x being each hash-keys of *loop.6.hash.1* collect x) - #'symbol<) + #'symbol<) (a b c)) (deftest loop.6.10 (sort (loop for x being each hash-keys in *loop.6.hash.1* collect x) - #'symbol<) + #'symbol<) (a b c)) (deftest loop.6.11 (sort (loop for (u . v) being the hash-keys of *loop.6.hash.3* collect u) - #'symbol<) + #'symbol<) (a1 b1 c1)) (deftest loop.6.12 (sort (loop for (u . v) being the hash-keys of *loop.6.hash.3* collect v) - #'symbol<) + #'symbol<) (a2 b2 c2)) (deftest loop.6.13 (sort (loop for (u . v) being the hash-values of *loop.6.hash.5* collect u) - #'symbol<) + #'symbol<) (a1 b1 c1)) (deftest loop.6.14 (sort (loop for (u . v) being the hash-values of *loop.6.hash.5* collect v) - #'symbol<) + #'symbol<) (a2 b2 c2)) (deftest loop.6.15 (sort (loop for k being the hash-keys of *loop.6.hash.1* using (hash-value v) - collect (list k v)) - #'< :key #'second) + collect (list k v)) + #'< :key #'second) ((a 1) (b 2) (c 3))) (deftest loop.6.16 (sort (loop for v being the hash-values of *loop.6.hash.1* using (hash-key k) - collect (list k v)) - #'< :key #'second) + collect (list k v)) + #'< :key #'second) ((a 1) (b 2) (c 3))) (deftest loop.6.17 (sort (loop for (u . nil) being the hash-values of *loop.6.hash.5* collect u) - #'symbol<) + #'symbol<) (a1 b1 c1)) (deftest loop.6.18 (sort (loop for (nil . v) being the hash-values of *loop.6.hash.5* collect v) - #'symbol<) + #'symbol<) (a2 b2 c2)) (deftest loop.6.19 @@ -226,22 +226,22 @@ (deftest loop.6.35 (loop for (k1 . k2) of-type (integer . integer) being the hash-keys - of *loop.6.hash.8* sum (+ k1 k2)) + of *loop.6.hash.8* sum (+ k1 k2)) 21) (deftest loop.6.36 (loop for (v1 . v2) of-type (integer . integer) being the hash-values - of *loop.6.hash.9* sum (+ v1 v2)) + of *loop.6.hash.9* sum (+ v1 v2)) 21) (deftest loop.6.37 (loop for v being the hash-values of *loop.6.hash.8* - using (hash-key (k1 . k2)) sum (+ k1 k2)) + using (hash-key (k1 . k2)) sum (+ k1 k2)) 21) (deftest loop.6.38 (loop for k being the hash-keys of *loop.6.hash.9* - using (hash-value (v1 . v2)) sum (+ v1 v2)) + using (hash-value (v1 . v2)) sum (+ v1 v2)) 21) (deftest loop.6.39 @@ -250,7 +250,7 @@ (deftest loop.6.40 (sort (loop as x being the hash-key of *loop.6.hash.1* collect x) - #'symbol<) + #'symbol<) (a b c)) ;;; Test that explicit calls to macroexpand in subforms @@ -260,15 +260,15 @@ (macrolet ((%m (z) z)) (loop for x being the hash-value of - (expand-in-current-env (%m *loop.6.hash.1*)) sum x)) + (expand-in-current-env (%m *loop.6.hash.1*)) sum x)) 6) (deftest loop.6.42 (macrolet ((%m (z) z)) (sort (loop for x being the hash-key of - (expand-in-current-env (%m *loop.6.hash.1*)) collect x) - #'symbol<)) + (expand-in-current-env (%m *loop.6.hash.1*)) collect x) + #'symbol<)) (a b c)) ;;; Error tests @@ -276,38 +276,38 @@ (deftest loop.6.error.1 (signals-error (loop for k from 1 to 10 - for k being the hash-keys of *loop.6.hash.1* - count t) + for k being the hash-keys of *loop.6.hash.1* + count t) program-error) t) (deftest loop.6.error.2 (signals-error (loop for k being the hash-keys of *loop.6.hash.1* - for k from 1 to 10 - count t) + for k from 1 to 10 + count t) program-error) t) (deftest loop.6.error.3 (signals-error (loop for (k . k) being the hash-keys of *loop.6.hash.3* - count t) + count t) program-error) t) (deftest loop.6.error.4 (signals-error (loop for k being the hash-keys of *loop.6.hash.3* - using (hash-value k) - count t) + using (hash-value k) + count t) program-error) t) (deftest loop.6.error.5 (signals-error (loop for k being the hash-values of *loop.6.hash.3* - using (hash-key k) - count t) + using (hash-key k) + count t) program-error) t) diff --git a/ansi-tests/loop7.lsp b/ansi-tests/loop7.lsp index 73915247..9886beaf 100644 --- a/ansi-tests/loop7.lsp +++ b/ansi-tests/loop7.lsp @@ -16,86 +16,86 @@ (deftest loop.7.1 (sort (mapcar #'symbol-name - (loop for x being the symbols of "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop for x being the symbols of "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.2 (sort (mapcar #'symbol-name - (loop for x being each symbol of "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop for x being each symbol of "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.3 (sort (mapcar #'symbol-name - (loop for x being the symbol of "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop for x being the symbol of "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.4 (sort (mapcar #'symbol-name - (loop for x being each symbols of "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop for x being each symbols of "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.5 (sort (mapcar #'symbol-name - (loop for x being the symbols in "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop for x being the symbols in "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.6 (sort (mapcar #'symbol-name - (loop for x being each symbol in "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop for x being each symbol in "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.7 (sort (mapcar #'symbol-name - (loop for x being the symbol in "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop for x being the symbol in "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.8 (sort (mapcar #'symbol-name - (loop for x being each symbols in "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop for x being each symbols in "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.9 (sort (mapcar #'symbol-name - (loop for x being the external-symbols of "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop for x being the external-symbols of "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "C")) (deftest loop.7.10 (sort (mapcar #'symbol-name - (loop for x being each external-symbol in "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop for x being each external-symbol in "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "C")) (deftest loop.7.11 (sort (mapcar #'symbol-name - (loop for x being each external-symbol in (find-package "LOOP.CL-TEST.1") collect x)) - #'string<) + (loop for x being each external-symbol in (find-package "LOOP.CL-TEST.1") collect x)) + #'string<) ("A" "B" "C")) (deftest loop.7.12 (sort (mapcar #'symbol-name - (loop for x being each external-symbol in :LOOP.CL-TEST.1 collect x)) - #'string<) + (loop for x being each external-symbol in :LOOP.CL-TEST.1 collect x)) + #'string<) ("A" "B" "C")) (deftest loop.7.13 (sort (mapcar #'symbol-name - (loop for x being the symbols of "LOOP.CL-TEST.2" collect x)) - #'string<) + (loop for x being the symbols of "LOOP.CL-TEST.2" collect x)) + #'string<) ("A" "B" "C" "X" "Y" "Z")) (deftest loop.7.14 (sort (mapcar #'symbol-name - (loop for x being the present-symbols of "LOOP.CL-TEST.2" collect x)) - #'string<) + (loop for x being the present-symbols of "LOOP.CL-TEST.2" collect x)) + #'string<) ("X" "Y" "Z")) ;;; According to the ANSI CL spec, "If the package for the iteration is not supplied, @@ -105,19 +105,19 @@ (deftest loop.7.15 (let ((*package* (find-package "LOOP.CL-TEST.1"))) (sort (mapcar #'symbol-name (loop for x being each symbol collect x)) - #'string<)) + #'string<)) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.16 (let ((*package* (find-package "LOOP.CL-TEST.1"))) (sort (mapcar #'symbol-name (loop for x being each external-symbol collect x)) - #'string<)) + #'string<)) ("A" "B" "C")) (deftest loop.7.17 (let ((*package* (find-package "LOOP.CL-TEST.2"))) (sort (mapcar #'symbol-name (loop for x being each present-symbol collect x)) - #'string<)) + #'string<)) ("X" "Y" "Z")) ;;; Cases where the package doesn't exist. According to the standard, @@ -136,7 +136,7 @@ (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (signals-error (loop for x being each present-symbol of "LOOP.MISSING.PACKAGE" - collect x) + collect x) package-error)) t) @@ -145,7 +145,7 @@ (ignore-errors (delete-package "LOOP.MISSING.PACKAGE")) (signals-error (loop for x being each external-symbol of "LOOP.MISSING.PACKAGE" - collect x) + collect x) package-error)) t) @@ -154,11 +154,11 @@ (deftest loop.7.21 (loop for nil being the symbols of "LOOP.CL-TEST.1" count t) 6) - + (deftest loop.7.22 (loop for nil being the external-symbols of "LOOP.CL-TEST.1" count t) 3) - + (deftest loop.7.23 (loop for nil being the present-symbols of "LOOP.CL-TEST.2" count t) 3) @@ -168,11 +168,11 @@ (deftest loop.7.24 (loop for x t being the symbols of "LOOP.CL-TEST.1" count x) 6) - + (deftest loop.7.25 (loop for x t being the external-symbols of "LOOP.CL-TEST.1" count x) 3) - + (deftest loop.7.26 (loop for x t being the present-symbols of "LOOP.CL-TEST.2" count x) 3) @@ -180,11 +180,11 @@ (deftest loop.7.27 (loop for x of-type symbol being the symbols of "LOOP.CL-TEST.1" count x) 6) - + (deftest loop.7.28 (loop for x of-type symbol being the external-symbols of "LOOP.CL-TEST.1" count x) 3) - + (deftest loop.7.29 (loop for x of-type symbol being the present-symbols of "LOOP.CL-TEST.2" count x) 3) @@ -193,20 +193,20 @@ (deftest loop.7.30 (sort (mapcar #'symbol-name - (loop as x being the symbols of "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop as x being the symbols of "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.31 (sort (mapcar #'symbol-name - (loop as x being each symbol of "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop as x being each symbol of "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.32 (sort (mapcar #'symbol-name - (loop as x being the symbol of "LOOP.CL-TEST.1" collect x)) - #'string<) + (loop as x being the symbol of "LOOP.CL-TEST.1" collect x)) + #'string<) ("A" "B" "BAR" "BAZ" "C" "FOO")) ;;; Test that explicit calls to macroexpand in subforms @@ -216,28 +216,28 @@ (macrolet ((%m (z) z)) (sort (mapcar #'symbol-name - (loop for x being the symbols of - (expand-in-current-env (%m "LOOP.CL-TEST.1")) - collect x)) - #'string<)) + (loop for x being the symbols of + (expand-in-current-env (%m "LOOP.CL-TEST.1")) + collect x)) + #'string<)) ("A" "B" "BAR" "BAZ" "C" "FOO")) (deftest loop.7.34 (macrolet ((%m (z) z)) (sort (mapcar #'symbol-name - (loop for x being the external-symbols of - (expand-in-current-env (%m "LOOP.CL-TEST.1")) - collect x)) - #'string<)) + (loop for x being the external-symbols of + (expand-in-current-env (%m "LOOP.CL-TEST.1")) + collect x)) + #'string<)) ("A" "B" "C")) (deftest loop.7.35 (macrolet ((%m (z) z)) (sort (mapcar #'symbol-name - (loop for x being the present-symbols of - (expand-in-current-env (%m "LOOP.CL-TEST.2")) - collect x)) - #'string<)) + (loop for x being the present-symbols of + (expand-in-current-env (%m "LOOP.CL-TEST.2")) + collect x)) + #'string<)) ("X" "Y" "Z")) diff --git a/ansi-tests/loop8.lsp b/ansi-tests/loop8.lsp index 700e5244..697392b7 100644 --- a/ansi-tests/loop8.lsp +++ b/ansi-tests/loop8.lsp @@ -17,15 +17,15 @@ (deftest loop.8.3 (let ((y 2)) (loop with x = y - with y = (1+ x) do (return (list x y)))) + with y = (1+ x) do (return (list x y)))) (2 3)) (deftest loop.8.4 (let (a b) (loop with a = 1 - and b = (list a) - and c = (list b) - return (list a b c))) + and b = (list a) + and c = (list b) + return (list a b c))) (1 (nil) (nil))) @@ -99,12 +99,12 @@ (deftest loop.8.21 (loop with b = 3 - and (a nil) = '(1 2) return (list a b)) + and (a nil) = '(1 2) return (list a b)) (1 3)) (deftest loop.8.22 (loop with b = 3 - and (nil a) = '(1 2) return (list a b)) + and (nil a) = '(1 2) return (list a b)) (2 3)) ;;; The NIL block of a loop encloses the entire loop. @@ -140,13 +140,13 @@ (deftest loop.8.error.1 (signals-error (loop with a = 1 - and a = 2 return a) + and a = 2 return a) program-error) t) (deftest loop.8.error.2 (signals-error (loop with a = 1 - with a = 2 return a) + with a = 2 return a) program-error) t) diff --git a/ansi-tests/loop9.lsp b/ansi-tests/loop9.lsp index a59840eb..6cf77159 100644 --- a/ansi-tests/loop9.lsp +++ b/ansi-tests/loop9.lsp @@ -17,61 +17,61 @@ (deftest loop.9.3 (loop for x in '(0 1 2) - when (eql x 2) do (return 'good) - collect x) + when (eql x 2) do (return 'good) + collect x) good) (deftest loop.9.4 (loop for x in '(a b c) - collect (list x) into foo - finally (return (reverse foo))) + collect (list x) into foo + finally (return (reverse foo))) ((c) (b) (a))) (deftest loop.9.5 (loop for x in '(a b c) - collecting (list x) into foo - finally (return (reverse foo))) + collecting (list x) into foo + finally (return (reverse foo))) ((c) (b) (a))) (deftest loop.9.6 (loop for x from 1 to 10 - when (evenp x) collect x into foo - when (oddp x) collect x into bar - finally (return (list foo bar))) + when (evenp x) collect x into foo + when (oddp x) collect x into bar + finally (return (list foo bar))) ((2 4 6 8 10) (1 3 5 7 9))) (deftest loop.9.7 (loop for x from 1 to 10 - collect (if (> x 5) (loop-finish) x)) + collect (if (> x 5) (loop-finish) x)) (1 2 3 4 5)) (deftest loop.9.8 (loop for x from 1 to 20 - when (eql (mod x 5) 0) collect x into foo - when (eql (mod x 5) 2) collect x into foo - finally (return foo)) + when (eql (mod x 5) 0) collect x into foo + when (eql (mod x 5) 2) collect x into foo + finally (return foo)) (2 5 7 10 12 15 17 20)) (deftest loop.9.9 (loop for x from 1 to 20 - when (eql (mod x 5) 0) collecting x into foo - when (eql (mod x 5) 2) collecting x into foo - finally (return foo)) + when (eql (mod x 5) 0) collecting x into foo + when (eql (mod x 5) 2) collecting x into foo + finally (return foo)) (2 5 7 10 12 15 17 20)) (deftest loop.9.10 (signals-error (loop with foo = '(a b) - for x in '(c d) collect x into foo - finally (return foo)) + for x in '(c d) collect x into foo + finally (return foo)) program-error) t) (deftest loop.9.11 (signals-error (loop with foo = '(a b) - for x in '(c d) collecting x into foo - finally (return foo)) + for x in '(c d) collecting x into foo + finally (return foo)) program-error) t) @@ -103,43 +103,43 @@ (deftest loop.9.24 (loop for x in '(a b c d) - append (list x) - when (eq x 'b) append '(1 2 3) - when (eq x 'd) appending '(4 5 6)) + append (list x) + when (eq x 'b) append '(1 2 3) + when (eq x 'd) appending '(4 5 6)) (a b 1 2 3 c d 4 5 6)) (deftest loop.9.25 (let (z) (values (loop for x in '((a) (b) (c) (d)) - append x into foo - finally (setq z foo)) + append x into foo + finally (setq z foo)) z)) nil (a b c d)) (deftest loop.9.26 (loop for x in '((a) (b) (c) (d)) - for i from 1 - append x into foo - append x into foo - appending (list i) into foo - finally (return foo)) + for i from 1 + append x into foo + append x into foo + appending (list i) into foo + finally (return foo)) (a a 1 b b 2 c c 3 d d 4)) (deftest loop.9.27 (signals-error (loop with foo = '(a b) - for x in '(c d) append (list x) into foo - finally (return foo)) + for x in '(c d) append (list x) into foo + finally (return foo)) program-error) t) (deftest loop.9.28 (signals-error (loop with foo = '(a b) - for x in '(c d) appending (list x) into foo - finally (return foo)) + for x in '(c d) appending (list x) into foo + finally (return foo)) program-error) t) @@ -164,43 +164,43 @@ (deftest loop.9.34 (loop for x in '(a b c d) - nconc (list x) - when (eq x 'b) nconc (copy-seq '(1 2 3)) - when (eq x 'd) nconcing (copy-seq '(4 5 6))) + nconc (list x) + when (eq x 'b) nconc (copy-seq '(1 2 3)) + when (eq x 'd) nconcing (copy-seq '(4 5 6))) (a b 1 2 3 c d 4 5 6)) (deftest loop.9.35 (let (z) (values (loop for x in '((a) (b) (c) (d)) - nconc (copy-seq x) into foo - finally (setq z foo)) + nconc (copy-seq x) into foo + finally (setq z foo)) z)) nil (a b c d)) (deftest loop.9.36 (loop for x in '((a) (b) (c) (d)) - for i from 1 - nconc (copy-seq x) into foo - nconc (copy-seq x) into foo - nconcing (list i) into foo - finally (return foo)) + for i from 1 + nconc (copy-seq x) into foo + nconc (copy-seq x) into foo + nconcing (list i) into foo + finally (return foo)) (a a 1 b b 2 c c 3 d d 4)) (deftest loop.9.37 (signals-error (loop with foo = '(a b) - for x in '(c d) nconc (list x) into foo - finally (return foo)) + for x in '(c d) nconc (list x) into foo + finally (return foo)) program-error) t) (deftest loop.9.38 (signals-error (loop with foo = '(a b) - for x in '(c d) nconcing (list x) into foo - finally (return foo)) + for x in '(c d) nconcing (list x) into foo + finally (return foo)) program-error) t) @@ -208,17 +208,17 @@ (deftest loop.9.40 (loop for x in '(1 2 3 4 5 6 7) - if (< x 2) append (list x) - else if (< x 5) nconc (list (1+ x)) - else collect (+ x 2)) + if (< x 2) append (list x) + else if (< x 5) nconc (list (1+ x)) + else collect (+ x 2)) (1 3 4 5 7 8 9)) (deftest loop.9.41 (loop for x in '(1 2 3 4 5 6 7) - if (< x 2) append (list x) into foo - else if (< x 5) nconc (list (1+ x)) into foo - else collect (+ x 2) into foo - finally (return foo)) + if (< x 2) append (list x) into foo + else if (< x 5) nconc (list (1+ x)) into foo + else collect (+ x 2) into foo + finally (return foo)) (1 3 4 5 7 8 9)) ;;; More nconc tests @@ -246,20 +246,20 @@ (macrolet ((%m (z) z)) (loop for x in '(a b c) - collect (expand-in-current-env (%m (list x))) into foo - finally (return (reverse foo)))) + collect (expand-in-current-env (%m (list x))) into foo + finally (return (reverse foo)))) ((c) (b) (a))) (deftest loop.9.46 (macrolet ((%m (z) z)) (loop for x in '((a b) (c d) (e f g) () (i)) - append (expand-in-current-env (%m x)))) + append (expand-in-current-env (%m x)))) (a b c d e f g i)) (deftest loop.9.47 (macrolet ((%m (z) z)) (loop for x in '((a b) (c d) (e f g) () (i)) - nconc (expand-in-current-env (%m (copy-seq x))))) + nconc (expand-in-current-env (%m (copy-seq x))))) (a b c d e f g i)) diff --git a/ansi-tests/macro-function.lsp b/ansi-tests/macro-function.lsp index fe35a178..2dfcb761 100644 --- a/ansi-tests/macro-function.lsp +++ b/ansi-tests/macro-function.lsp @@ -7,23 +7,23 @@ (deftest macro-function.1 (loop for n in *cl-macro-symbols* - unless (macro-function n) - collect n) + unless (macro-function n) + collect n) nil) (deftest macro-function.2 (loop for n in *cl-macro-symbols* - unless (macro-function n nil) - collect n) + unless (macro-function n nil) + collect n) nil) (deftest macro-function.3 (loop for n in *cl-macro-symbols* - unless (eval `(macrolet ((%m (s &environment env) - (list 'quote - (macro-function s env)))) - (%m ,n))) - collect n) + unless (eval `(macrolet ((%m (s &environment env) + (list 'quote + (macro-function s env)))) + (%m ,n))) + collect n) nil) (deftest macro-function.4 @@ -40,10 +40,10 @@ (deftest macro-function.7 (let ((fn - (macrolet ((%m () 16)) - (macrolet ((%n (&environment env) - (list 'quote (macro-function '%m env)))) - (%n))))) + (macrolet ((%m () 16)) + (macrolet ((%n (&environment env) + (list 'quote (macro-function '%m env)))) + (%n))))) (values (notnot (functionp fn)) (funcall fn '(%m) nil))) @@ -53,18 +53,18 @@ (let ((sym (gensym))) (setf (macro-function sym) (macro-function 'pop)) (eval `(let ((x '(a b c))) - (values - (,sym x) - x)))) + (values + (,sym x) + x)))) a (b c)) (deftest macro-function.9 (let ((sym (gensym))) (setf (macro-function sym nil) (macro-function 'pop)) (eval `(let ((x '(a b c))) - (values - (,sym x) - x)))) + (values + (,sym x) + x)))) a (b c)) (deftest macro-function.10 @@ -72,17 +72,17 @@ (eval `(defun ,sym (x) :bad)) (setf (macro-function sym) (macro-function 'pop)) (eval `(let ((x '(a b c))) - (values - (,sym x) - x)))) + (values + (,sym x) + x)))) a (b c)) (deftest macro-function.11 (let ((fn - (flet ((%m () 16)) - (macrolet ((%n (&environment env) - (list 'quote (macro-function '%m env)))) - (%n))))) + (flet ((%m () 16)) + (macrolet ((%n (&environment env) + (list 'quote (macro-function '%m env)))) + (%n))))) fn) nil) @@ -101,34 +101,34 @@ (let ((i 0) a b) (values (funcall (macro-function (progn (setf a (incf i)) sym) - (progn (setf b (incf i)) nil)) - (list sym) nil) + (progn (setf b (incf i)) nil)) + (list sym) nil) i a b))) t 2 1 2) (deftest macro-function.14 (let ((sym (gensym)) - (i 0)) + (i 0)) (setf (macro-function (progn (incf i) sym)) (macro-function 'pop)) - (values + (values (eval `(let ((x '(a b c))) - (list - (,sym x) - x))) + (list + (,sym x) + x))) i)) (a (b c)) 1) (deftest macro-function.15 (let ((sym (gensym)) - (i 0) a b) + (i 0) a b) (setf (macro-function (progn (setf a (incf i)) sym) - (progn (setf b (incf i)) nil)) - (macro-function 'pop)) - (values + (progn (setf b (incf i)) nil)) + (macro-function 'pop)) + (values (eval `(let ((x '(a b c))) - (list - (,sym x) - x))) + (list + (,sym x) + x))) i a b)) (a (b c)) 2 1 2) diff --git a/ansi-tests/macroexpand-1.lsp b/ansi-tests/macroexpand-1.lsp index cdc5a025..5b8dcc48 100644 --- a/ansi-tests/macroexpand-1.lsp +++ b/ansi-tests/macroexpand-1.lsp @@ -19,46 +19,46 @@ (check-predicate #'(lambda (x) (or (symbolp x) (consp x) - (let ((vals (multiple-value-list (macroexpand-1 x)))) - (and (= (length vals) 2) - (eql (car vals) x) - (null (cadr vals))))))) + (let ((vals (multiple-value-list (macroexpand-1 x)))) + (and (= (length vals) 2) + (eql (car vals) x) + (null (cadr vals))))))) nil) (deftest macroexpand-1.2 (check-predicate #'(lambda (x) (or (symbolp x) (consp x) - (let ((vals (multiple-value-list (macroexpand-1 x nil)))) - (and (= (length vals) 2) - (eql (car vals) x) - (null (cadr vals))))))) + (let ((vals (multiple-value-list (macroexpand-1 x nil)))) + (and (= (length vals) 2) + (eql (car vals) x) + (null (cadr vals))))))) nil) (deftest macroexpand-1.3 (macrolet ((%m (&environment env) - `(quote - ,(check-predicate - #'(lambda (x) - (or (symbolp x) (consp x) - (let ((vals (multiple-value-list (macroexpand-1 x env)))) - (and (= (length vals) 2) - (eql (car vals) x) - (null (cadr vals)))))))))) + `(quote + ,(check-predicate + #'(lambda (x) + (or (symbolp x) (consp x) + (let ((vals (multiple-value-list (macroexpand-1 x env)))) + (and (= (length vals) 2) + (eql (car vals) x) + (null (cadr vals)))))))))) (%m)) nil) (deftest macroexpand-1.4 (macrolet ((%m () ''foo)) (macrolet ((%m2 (&environment env) - (macroexpand-1 '(%m) env))) + (macroexpand-1 '(%m) env))) (%m2))) foo) (deftest macroexpand-1.5 (let ((form (list (gensym))) - (i 0)) + (i 0)) (values (equalt (macroexpand-1 (progn (incf i) form)) form) i)) @@ -66,10 +66,10 @@ (deftest macroexpand-1.6 (let ((form (list (gensym))) - (i 0) a b) + (i 0) a b) (values (equalt (macroexpand-1 (progn (setf a (incf i)) form) - (progn (setf b (incf i)) nil)) - form) + (progn (setf b (incf i)) nil)) + form) i a b)) t 2 1 2) diff --git a/ansi-tests/macroexpand.lsp b/ansi-tests/macroexpand.lsp index 3c70a344..3db6b178 100644 --- a/ansi-tests/macroexpand.lsp +++ b/ansi-tests/macroexpand.lsp @@ -19,45 +19,45 @@ (check-predicate #'(lambda (x) (or (symbolp x) (consp x) - (let ((vals (multiple-value-list (macroexpand x)))) - (and (= (length vals) 2) - (eql (car vals) x) - (null (cadr vals))))))) + (let ((vals (multiple-value-list (macroexpand x)))) + (and (= (length vals) 2) + (eql (car vals) x) + (null (cadr vals))))))) nil) (deftest macroexpand.2 (check-predicate #'(lambda (x) (or (symbolp x) (consp x) - (let ((vals (multiple-value-list (macroexpand x nil)))) - (and (= (length vals) 2) - (eql (car vals) x) - (null (cadr vals))))))) + (let ((vals (multiple-value-list (macroexpand x nil)))) + (and (= (length vals) 2) + (eql (car vals) x) + (null (cadr vals))))))) nil) (deftest macroexpand.3 (macrolet ((%m (&environment env) - `(quote - ,(check-predicate - #'(lambda (x) (or (symbolp x) (consp x) - (let ((vals (multiple-value-list (macroexpand x env)))) - (and (= (length vals) 2) - (eql (car vals) x) - (null (cadr vals)))))))))) + `(quote + ,(check-predicate + #'(lambda (x) (or (symbolp x) (consp x) + (let ((vals (multiple-value-list (macroexpand x env)))) + (and (= (length vals) 2) + (eql (car vals) x) + (null (cadr vals)))))))))) (%m)) nil) (deftest macroexpand.4 (macrolet ((%m () ''foo)) (macrolet ((%m2 (&environment env) - (macroexpand '(%m) env))) + (macroexpand '(%m) env))) (%m2))) foo) (deftest macroexpand.5 (let ((form (list (gensym))) - (i 0)) + (i 0)) (values (equalt (macroexpand (progn (incf i) form)) form) i)) @@ -65,10 +65,10 @@ (deftest macroexpand.6 (let ((form (list (gensym))) - (i 0) a b) + (i 0) a b) (values (equalt (macroexpand (progn (setf a (incf i)) form) - (progn (setf b (incf i)) nil)) - form) + (progn (setf b (incf i)) nil)) + form) i a b)) t 2 1 2) diff --git a/ansi-tests/macrolet.lsp b/ansi-tests/macrolet.lsp index 7bc07f7b..0e352259 100644 --- a/ansi-tests/macrolet.lsp +++ b/ansi-tests/macrolet.lsp @@ -9,17 +9,17 @@ (let ((z (list 3 4))) (macrolet ((%m (x) `(car ,x))) (let ((y (list 1 2))) - (values (%m y) (%m z))))) + (values (%m y) (%m z))))) 1 3) (deftest macrolet.2 (let ((z (list 3 4))) (macrolet ((%m (x) `(car ,x))) (let ((y (list 1 2))) - (values - (setf (%m y) 6) - (setf (%m z) 'a) - y z)))) + (values + (setf (%m y) 6) + (setf (%m z) 'a) + y z)))) 6 a (6 2) (a 4)) ;;; Inner definitions shadow outer ones @@ -27,20 +27,20 @@ (macrolet ((%m (w) `(cadr ,w))) (let ((z (list 3 4))) (macrolet ((%m (x) `(car ,x))) - (let ((y (list 1 2))) - (values - (%m y) (%m z) - (setf (%m y) 6) - (setf (%m z) 'a) - y z))))) + (let ((y (list 1 2))) + (values + (%m y) (%m z) + (setf (%m y) 6) + (setf (%m z) 'a) + y z))))) 1 3 6 a (6 2) (a 4)) ;;; &whole parameter (deftest macrolet.4 (let ((x nil)) (macrolet ((%m (&whole w arg) - `(progn (setq x (quote ,w)) - ,arg))) + `(progn (setq x (quote ,w)) + ,arg))) (values (%m 1) x))) 1 (%m 1)) @@ -48,8 +48,8 @@ (deftest macrolet.5 (let ((x nil)) (macrolet ((%m ((&whole w arg)) - `(progn (setq x (quote ,w)) - ,arg))) + `(progn (setq x (quote ,w)) + ,arg))) (values (%m (1)) x))) 1 (1)) @@ -57,40 +57,40 @@ (deftest macrolet.6 (let ((x nil)) (macrolet ((%m (&key (a 'xxx) b) - `(setq x (quote ,a)))) - + `(setq x (quote ,a)))) + (values (%m :a foo) x - (%m :b bar) x))) + (%m :b bar) x))) foo foo xxx xxx) ;;; nested key parameters (deftest macrolet.7 (let ((x nil)) (macrolet ((%m ((&key a b)) - `(setq x (quote ,a)))) - + `(setq x (quote ,a)))) + (values (%m (:a foo)) x - (%m (:b bar)) x))) + (%m (:b bar)) x))) foo foo nil nil) ;;; nested key parameters (deftest macrolet.8 (let ((x nil)) (macrolet ((%m ((&key (a 10) b)) - `(setq x (quote ,a)))) - + `(setq x (quote ,a)))) + (values (%m (:a foo)) x - (%m (:b bar)) x))) + (%m (:b bar)) x))) foo foo 10 10) ;;; keyword parameter with supplied-p parameter (deftest macrolet.9 (let ((x nil)) (macrolet ((%m (&key (a 'xxx a-p) b) - `(setq x (quote ,(list a (not (not a-p))))))) - + `(setq x (quote ,(list a (not (not a-p))))))) + (values (%m :a foo) x - (%m :b bar) x))) + (%m :b bar) x))) (foo t) (foo t) (xxx nil) (xxx nil)) @@ -98,7 +98,7 @@ (deftest macrolet.10 (let ((x nil)) (macrolet ((%m (b &rest a) - `(setq x (quote ,a)))) + `(setq x (quote ,a)))) (values (%m a1 a2) x))) (a2) (a2)) @@ -106,7 +106,7 @@ (deftest macrolet.11 (let ((x nil)) (macrolet ((%m ((b &rest a)) - `(setq x (quote ,a)))) + `(setq x (quote ,a)))) (values (%m (a1 a2)) x))) (a2) (a2)) @@ -114,7 +114,7 @@ (deftest macrolet.12 (let ((x nil)) (macrolet ((%m (&whole w b &rest a) - `(setq x (quote ,(list a w))))) + `(setq x (quote ,(list a w))))) (values (%m a1 a2) x))) ((a2) (%m a1 a2)) ((a2) (%m a1 a2))) @@ -124,16 +124,16 @@ (deftest macrolet.13 (symbol-macrolet ((a b)) (macrolet ((foo (x &environment env) - (let ((y (macroexpand x env))) - (if (eq y 'a) 1 2)))) + (let ((y (macroexpand x env))) + (if (eq y 'a) 1 2)))) (foo a))) 2) (deftest macrolet.14 (symbol-macrolet ((a b)) (macrolet ((foo (x &environment env) - (let ((y (macroexpand-1 x env))) - (if (eq y 'a) 1 2)))) + (let ((y (macroexpand-1 x env))) + (if (eq y 'a) 1 2)))) (foo a))) 2) @@ -144,9 +144,9 @@ (deftest macrolet.16 (loop for s in *cl-non-function-macro-special-operator-symbols* - for form = `(ignore-errors (macrolet ((,s () ''a)) (,s))) - unless (eq (eval form) 'a) - collect s) + for form = `(ignore-errors (macrolet ((,s () ''a)) (,s))) + unless (eq (eval form) 'a) + collect s) nil) (deftest macrolet.17 @@ -190,7 +190,7 @@ (deftest macrolet.22a (macrolet ((%m (x &optional ((y z) '(2 3) y-z-p)) - `(quote (,x ,y ,z ,y-z-p)))) + `(quote (,x ,y ,z ,y-z-p)))) (values (%m a) (%m a (b c)))) @@ -220,7 +220,7 @@ (deftest macrolet.26 (macrolet ((%m (&key ((:a b))) `(quote ,b))) (values (%m) - (%m :a x))) + (%m :a x))) nil x) @@ -232,8 +232,8 @@ (deftest macrolet.28 (macrolet ((%m (&key ((:a (b c)) '(3 4))) `(quote (,c ,b)))) (values (%m :a (1 2)) - (%m :a (1 2) :a (10 11)) - (%m))) + (%m :a (1 2) :a (10 11)) + (%m))) (2 1) (2 1) (4 3)) @@ -241,13 +241,13 @@ (deftest macrolet.29 (macrolet ((%m (&key a (b a)) `(quote (,a ,b)))) (values (%m) - (%m :a 1) - (%m :b 2) - (%m :a 3 :b 4) - (%m :b 5 :a 6) - (%m :a 7 :a 8) - (%m :a 9 :b nil) - (%m :a 10 :b nil :b 11))) + (%m :a 1) + (%m :b 2) + (%m :a 3 :b 4) + (%m :b 5 :a 6) + (%m :a 7 :a 8) + (%m :a 9 :b nil) + (%m :a 10 :b nil :b 11))) (nil nil) (1 1) (nil 2) @@ -260,12 +260,12 @@ (deftest macrolet.30 (macrolet ((%m ((&key a) &key (b a)) `(quote (,a ,b)))) (values (%m ()) - (%m (:a 1)) - (%m () :b 2) - (%m (:a 3) :b 4) - (%m (:a 7 :a 8)) - (%m (:a 9) :b nil) - (%m (:a 10) :b nil :b 11))) + (%m (:a 1)) + (%m () :b 2) + (%m (:a 3) :b 4) + (%m (:a 7 :a 8)) + (%m (:a 9) :b nil) + (%m (:a 10) :b nil :b 11))) (nil nil) (1 1) (nil 2) @@ -276,10 +276,10 @@ (deftest macrolet.31 (macrolet ((%m (&key ((:a (b c)) '(3 4) a-p)) - `(quote (,(notnot a-p) ,c ,b)))) + `(quote (,(notnot a-p) ,c ,b)))) (values (%m :a (1 2)) - (%m :a (1 2) :a (10 11)) - (%m))) + (%m :a (1 2) :a (10 11)) + (%m))) (t 2 1) (t 2 1) (nil 4 3)) @@ -351,7 +351,7 @@ (deftest macrolet.38 (macrolet ((foo () 1)) (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env) - x)) + x)) (%f))) 1) @@ -386,9 +386,9 @@ (let ((*f* #'(lambda () *x-in-macrolet.43*))) (declare (special *f*)) (eval `(macrolet ((%m (*x-in-macrolet.43*) - (declare (special *f*)) - (funcall *f*))) - (%m t))))) + (declare (special *f*)) + (funcall *f*))) + (%m t))))) nil) (deftest macrolet.44 @@ -397,9 +397,9 @@ (let ((*f* #'(lambda () *x-in-macrolet.44*))) (declare (special *f*)) (eval `(macrolet ((%m (*x-in-macrolet.44*) - (declare (special *f* *x-in-macrolet.44*)) - (funcall *f*))) - (%m t))))) + (declare (special *f* *x-in-macrolet.44*)) + (funcall *f*))) + (%m t))))) t) (deftest macrolet.45 @@ -408,16 +408,16 @@ (let ((*f* #'(lambda () *x-in-macrolet.45*))) (declare (special *f*)) (eval `(macrolet ((%m ((*x-in-macrolet.45*)) - (declare (special *f* *x-in-macrolet.45*)) - (funcall *f*))) - (%m (t)))))) + (declare (special *f* *x-in-macrolet.45*)) + (funcall *f*))) + (%m (t)))))) t) ;;; Macros are expanded in the appropriate environment (deftest macrolet.46 (macrolet ((%m (z) z)) - (macrolet () (expand-in-current-env (%m :good)))) + (macrolet () (expand-in-current-env (%m :good)))) :good) ;;; Free declarations in macrolet diff --git a/ansi-tests/make-array.lsp b/ansi-tests/make-array.lsp index 6be84906..b7525d5a 100644 --- a/ansi-tests/make-array.lsp +++ b/ansi-tests/make-array.lsp @@ -70,32 +70,32 @@ (deftest make-array.6 (make-array-with-checks 4 :element-type 'character - :initial-element #\x) + :initial-element #\x) "xxxx") (deftest make-array.6a (make-array-with-checks 4 :element-type 'character - :initial-contents '(#\a #\b #\c #\d)) + :initial-contents '(#\a #\b #\c #\d)) "abcd") (deftest make-array.6b (make-array-with-checks 4 :element-type 'character - :initial-contents "abcd") + :initial-contents "abcd") "abcd") (deftest make-array.7 (make-array-with-checks 5 :element-type 'symbol - :initial-element 'a) + :initial-element 'a) #(a a a a a)) (deftest make-array.7a (make-array-with-checks 5 :element-type 'symbol - :initial-contents '(a b c d e)) + :initial-contents '(a b c d e)) #(a b c d e)) (deftest make-array.7b (make-array-with-checks '(5) :element-type 'symbol - :initial-contents '(a b c d e)) + :initial-contents '(a b c d e)) #(a b c d e)) (deftest make-array.8 @@ -106,45 +106,45 @@ (deftest make-array.8a (make-array-with-checks 8 :element-type '(integer 0 (256)) - :initial-element 9) + :initial-element 9) #(9 9 9 9 9 9 9 9)) (deftest make-array.8b (make-array-with-checks '(8) :element-type '(integer 0 (256)) - :initial-contents '(4 3 2 1 9 8 7 6)) + :initial-contents '(4 3 2 1 9 8 7 6)) #(4 3 2 1 9 8 7 6)) (deftest make-array.8c (loop for i from 1 to 32 - for tp = `(unsigned-byte ,i) - for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-contents '(1 1 0 0 1)) - when (symbolp a) - collect (list i tp a)) + for tp = `(unsigned-byte ,i) + for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-contents '(1 1 0 0 1)) + when (symbolp a) + collect (list i tp a)) nil) (deftest make-array.8d (loop for i from 2 to 32 - for tp = `(signed-byte ,i) - for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-contents '(1 1 0 0 1)) - when (symbolp a) - collect (list i tp a)) + for tp = `(signed-byte ,i) + for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-contents '(1 1 0 0 1)) + when (symbolp a) + collect (list i tp a)) nil) (deftest make-array.8e (loop for tp in '(short-float single-float double-float long-float) - for v in '(1.0s0 1.0f0 1.0d0 1.0l0) - for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-element v) - when (symbolp a) - collect (list tp v a)) + for v in '(1.0s0 1.0f0 1.0d0 1.0l0) + for a = (make-array 5 :fill-pointer 3 :element-type tp :initial-element v) + when (symbolp a) + collect (list tp v a)) nil) (deftest make-array.8f (loop for tp in '(short-float single-float double-float long-float) - for v in '(1.0s0 1.0f0 1.0d0 1.0l0) - for a = (make-array 5 :fill-pointer 3 :element-type `(complex ,tp) - :initial-element (complex v)) - when (symbolp a) - collect (list tp v a)) + for v in '(1.0s0 1.0f0 1.0d0 1.0l0) + for a = (make-array 5 :fill-pointer 3 :element-type `(complex ,tp) + :initial-element (complex v)) + when (symbolp a) + collect (list tp v a)) nil) ;;; Zero dimensional arrays @@ -168,19 +168,19 @@ (deftest make-array.12a (make-array-with-checks 10 :element-type 'bit :initial-contents '(1 0 0 1 1 0 0 1 0 0) - :fill-pointer 6) + :fill-pointer 6) #*100110) (deftest make-array.12b (make-array-with-checks 10 :element-type 'character - :initial-contents "abcdefghij" - :fill-pointer 8) + :initial-contents "abcdefghij" + :fill-pointer 8) "abcdefgh") (deftest make-array.12c (make-array-with-checks 10 :element-type 'base-char - :initial-contents "abcdefghij" - :fill-pointer 8) + :initial-contents "abcdefghij" + :fill-pointer 8) "abcdefgh") (deftest make-array.13 @@ -200,7 +200,7 @@ (deftest make-array.16 (equalpt (make-array-with-checks '(0 0)) - (read-from-string "#2a()")) + (read-from-string "#2a()")) t) (deftest make-array.17 @@ -213,34 +213,34 @@ (deftest make-array.19 (make-array-with-checks '(4) :initial-contents - (make-array '(10) :initial-element 1 - :fill-pointer 4)) + (make-array '(10) :initial-element 1 + :fill-pointer 4)) #(1 1 1 1)) (deftest make-array.20 (let ((a (make-array '(10) :initial-element 1 - :fill-pointer 4))) + :fill-pointer 4))) (make-array-with-checks '(3 4) :initial-contents - (list a a a))) + (list a a a))) #2a((1 1 1 1) (1 1 1 1) (1 1 1 1))) (deftest make-array.21 (make-array-with-checks '(3 4) :initial-contents - (make-array '(10) :initial-element '(1 2 3 4) - :fill-pointer 3)) + (make-array '(10) :initial-element '(1 2 3 4) + :fill-pointer 3)) #2a((1 2 3 4) (1 2 3 4) (1 2 3 4))) (deftest make-array.22 (loop for i from 3 below (min array-rank-limit 128) - always - (equalpt (make-array-with-checks (make-list i :initial-element 0)) - (read-from-string (format nil "#~Aa()" i)))) + always + (equalpt (make-array-with-checks (make-list i :initial-element 0)) + (read-from-string (format nil "#~Aa()" i)))) t) (deftest make-array.23 (let ((len (1- array-rank-limit))) (equalpt (make-array-with-checks (make-list len :initial-element 0)) - (read-from-string (format nil "#~Aa()" len)))) + (read-from-string (format nil "#~Aa()" len)))) t) ;;; (deftest make-array.24 @@ -249,71 +249,71 @@ (deftest make-array.25 (make-array '(4) :initial-element 'x :nonsense-argument t - :allow-other-keys t) + :allow-other-keys t) #(x x x x)) (deftest make-array.26 (make-array '(4) :initial-element 'x - :allow-other-keys nil) + :allow-other-keys nil) #(x x x x)) (deftest make-array.27 (make-array '(4) :initial-element 'x - :allow-other-keys t - :allow-other-keys nil - :nonsense-argument t) + :allow-other-keys t + :allow-other-keys nil + :nonsense-argument t) #(x x x x)) (deftest make-array.28 (let ((*package* (find-package :cl-test))) (let ((len (1- (min 10000 array-rank-limit)))) (equalpt (make-array (make-list len :initial-element 1) :initial-element 'x) - (read-from-string (concatenate - 'string - (format nil "#~dA" len) - (make-string len :initial-element #\() - "x" - (make-string len :initial-element #\))))))) + (read-from-string (concatenate + 'string + (format nil "#~dA" len) + (make-string len :initial-element #\() + "x" + (make-string len :initial-element #\))))))) t) (deftest make-array.29 (make-array-with-checks '(5) :element-type '(integer 0 (256)) - :initial-contents '(0 5 255 119 57)) + :initial-contents '(0 5 255 119 57)) #(0 5 255 119 57)) (deftest make-array.30 (make-array-with-checks '(5) :element-type '(integer -128 127) - :initial-contents '(-10 5 -128 86 127)) + :initial-contents '(-10 5 -128 86 127)) #(-10 5 -128 86 127)) (deftest make-array.31 (make-array-with-checks '(5) :element-type '(integer 0 (65536)) - :initial-contents '(0 100 65535 7623 13)) + :initial-contents '(0 100 65535 7623 13)) #(0 100 65535 7623 13)) (deftest make-array.32 (make-array-with-checks '(5) :element-type 'fixnum - :initial-contents '(1 2 3 4 5)) + :initial-contents '(1 2 3 4 5)) #(1 2 3 4 5)) (deftest make-array.33 (make-array-with-checks '(5) :element-type 'short-float - :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) + :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) #(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) (deftest make-array.34 (make-array-with-checks '(5) :element-type 'single-float - :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) + :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) #(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) (deftest make-array.35 (make-array-with-checks '(5) :element-type 'double-float - :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) + :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) #(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) (deftest make-array.36 (make-array-with-checks '(5) :element-type 'long-float - :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) + :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) #(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) @@ -326,7 +326,7 @@ (deftest make-array.adjustable.2 (make-array-with-checks '(4) :adjustable t - :initial-element 6) + :initial-element 6) #(6 6 6 6)) (deftest make-array.adjustable.3 @@ -339,63 +339,63 @@ (deftest make-array.adjustable.5 (make-array-with-checks '(2 3) :adjustable t - :initial-contents '((1 2 3) "abc")) + :initial-contents '((1 2 3) "abc")) #2a((1 2 3) (#\a #\b #\c))) (deftest make-array.adjustable.6 (make-array-with-checks '(4) :adjustable t - :initial-contents '(a b c d)) + :initial-contents '(a b c d)) #(a b c d)) (deftest make-array.adjustable.7 (make-array-with-checks '(4) :adjustable t - :fill-pointer t - :initial-contents '(a b c d)) + :fill-pointer t + :initial-contents '(a b c d)) #(a b c d)) (deftest make-array.adjustable.7a (make-array-with-checks '(4) :adjustable t - :element-type 'bit - :fill-pointer t - :initial-contents '(1 0 0 1)) + :element-type 'bit + :fill-pointer t + :initial-contents '(1 0 0 1)) #(1 0 0 1)) (deftest make-array.adjustable.7b (make-array-with-checks '(4) :adjustable t - :element-type 'base-char - :fill-pointer t - :initial-contents "abcd") + :element-type 'base-char + :fill-pointer t + :initial-contents "abcd") "abcd") (deftest make-array.adjustable.7c (make-array-with-checks '(4) :adjustable t - :element-type 'character - :fill-pointer t - :initial-contents "abcd") + :element-type 'character + :fill-pointer t + :initial-contents "abcd") "abcd") (deftest make-array.adjustable.8 (make-array-with-checks '(4) :adjustable t - :element-type '(integer 0 (256)) - :initial-contents '(1 4 7 9)) + :element-type '(integer 0 (256)) + :initial-contents '(1 4 7 9)) #(1 4 7 9)) (deftest make-array.adjustable.9 (make-array-with-checks '(4) :adjustable t - :element-type 'base-char - :initial-contents "abcd") + :element-type 'base-char + :initial-contents "abcd") "abcd") (deftest make-array.adjustable.10 (make-array-with-checks '(4) :adjustable t - :element-type 'bit - :initial-contents '(0 1 1 0)) + :element-type 'bit + :initial-contents '(0 1 1 0)) #*0110) (deftest make-array.adjustable.11 (make-array-with-checks '(4) :adjustable t - :element-type 'symbol - :initial-contents '(a b c d)) + :element-type 'symbol + :initial-contents '(a b c d)) #(a b c d)) ;;; Displaced arrays @@ -408,35 +408,35 @@ (deftest make-array.displaced.2 (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) (make-array-with-checks '(5) :displaced-to a - :displaced-index-offset 3)) + :displaced-index-offset 3)) #(d e f g h)) (deftest make-array.displaced.3 (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) (make-array-with-checks '(5) :displaced-to a - :displaced-index-offset 5)) + :displaced-index-offset 5)) #(f g h i j)) (deftest make-array.displaced.4 (let ((a (make-array '(10) :initial-contents '(a b c d e f g h i j)))) (make-array-with-checks '(0) :displaced-to a - :displaced-index-offset 10)) + :displaced-index-offset 10)) #()) (deftest make-array.displaced.5 (let ((a (make-array '(10) :element-type '(integer 0 (256)) - :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) + :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) (make-array-with-checks '(5) :element-type '(integer 0 (256)) - :displaced-to a)) + :displaced-to a)) #(1 3 5 7 9)) (deftest make-array.displaced.6 (let ((a (make-array '(10) :element-type '(integer 0 (256)) - :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) + :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) (loop for i from 0 to 5 collect - (make-array-with-checks '(5) :element-type '(integer 0 (256)) - :displaced-to a - :displaced-index-offset i))) + (make-array-with-checks '(5) :element-type '(integer 0 (256)) + :displaced-to a + :displaced-index-offset i))) (#(1 3 5 7 9) #(3 5 7 9 11) #(5 7 9 11 13) @@ -446,50 +446,50 @@ (deftest make-array.displaced.7 (let ((a (make-array '(10) :element-type '(integer 0 (256)) - :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) + :initial-contents '(1 3 5 7 9 11 13 15 17 19)))) (make-array-with-checks '(0) :element-type '(integer 0 (256)) - :displaced-to a - :displaced-index-offset 10)) + :displaced-to a + :displaced-index-offset 10)) #()) (deftest make-array.displaced.8 (let ((a (make-array '(10) :element-type 'bit - :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) + :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) (make-array-with-checks '(5) :element-type 'bit - :displaced-to a)) + :displaced-to a)) #*01101) (deftest make-array.displaced.9 (let ((a (make-array '(10) :element-type 'bit - :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) + :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) (loop for i from 0 to 5 collect - (make-array-with-checks '(5) :element-type 'bit - :displaced-to a - :displaced-index-offset i))) + (make-array-with-checks '(5) :element-type 'bit + :displaced-to a + :displaced-index-offset i))) (#*01101 #*11011 #*10111 #*01110 #*11101 #*11010)) (deftest make-array.displaced.10 (let ((a (make-array '(10) :element-type 'bit - :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) + :initial-contents '(0 1 1 0 1 1 1 0 1 0)))) (make-array-with-checks '(0) :element-type 'bit - :displaced-to a - :displaced-index-offset 10)) + :displaced-to a + :displaced-index-offset 10)) #*) (deftest make-array.displaced.11 (let ((a (make-array '(10) :element-type 'base-char - :initial-contents "abcdefghij"))) + :initial-contents "abcdefghij"))) (make-array-with-checks '(5) :element-type 'base-char - :displaced-to a)) + :displaced-to a)) "abcde") (deftest make-array.displaced.12 (let ((a (make-array '(10) :element-type 'base-char - :initial-contents "abcdefghij"))) + :initial-contents "abcdefghij"))) (loop for i from 0 to 5 collect - (make-array-with-checks '(5) :element-type 'base-char - :displaced-to a - :displaced-index-offset i))) + (make-array-with-checks '(5) :element-type 'base-char + :displaced-to a + :displaced-index-offset i))) ("abcde" "bcdef" "cdefg" @@ -499,26 +499,26 @@ (deftest make-array.displaced.13 (let ((a (make-array '(10) :element-type 'base-char - :initial-contents "abcdefghij"))) + :initial-contents "abcdefghij"))) (make-array-with-checks '(0) :element-type 'base-char - :displaced-to a - :displaced-index-offset 10)) + :displaced-to a + :displaced-index-offset 10)) "") (deftest make-array.displaced.14 (let ((a (make-array '(10) :element-type 'character - :initial-contents "abcdefghij"))) + :initial-contents "abcdefghij"))) (make-array-with-checks '(5) :element-type 'character - :displaced-to a)) + :displaced-to a)) "abcde") (deftest make-array.displaced.15 (let ((a (make-array '(10) :element-type 'character - :initial-contents "abcdefghij"))) + :initial-contents "abcdefghij"))) (loop for i from 0 to 5 collect - (make-array-with-checks '(5) :element-type 'character - :displaced-to a - :displaced-index-offset i))) + (make-array-with-checks '(5) :element-type 'character + :displaced-to a + :displaced-index-offset i))) ("abcde" "bcdef" "cdefg" @@ -528,127 +528,127 @@ (deftest make-array.displaced.16 (let ((a (make-array '(10) :element-type 'character - :initial-contents "abcdefghij"))) + :initial-contents "abcdefghij"))) (make-array-with-checks '(0) :element-type 'character - :displaced-to a - :displaced-index-offset 10)) + :displaced-to a + :displaced-index-offset 10)) "") ;;; Multidimensional displaced arrays (deftest make-array.displaced.17 (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) - (9 10 11 12))))) + (9 10 11 12))))) (make-array-with-checks '(8) :displaced-to a)) #(1 2 3 4 5 6 7 8)) (deftest make-array.displaced.18 (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) - (9 10 11 12))))) + (9 10 11 12))))) (make-array-with-checks '(8) :displaced-to a - :displaced-index-offset 3)) + :displaced-index-offset 3)) #(4 5 6 7 8 9 10 11)) (deftest make-array.displaced.19 (let ((a (make-array '(3 4) :initial-contents '((1 2 3 4) (5 6 7 8) - (9 10 11 12))))) + (9 10 11 12))))) (make-array-with-checks '(2 4) :displaced-to a - :displaced-index-offset 4)) + :displaced-index-offset 4)) #2a((5 6 7 8) (9 10 11 12))) (deftest make-array.displaced.20 (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(24) :displaced-to a)) #(a b c d e f g h i j k l m n o p q r s t u v w x)) (deftest make-array.displaced.21 (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(3 8) :displaced-to a)) #2a((a b c d e f g h) (i j k l m n o p) (q r s t u v w x))) (deftest make-array.displaced.22 (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a - :displaced-index-offset 5)) + :displaced-index-offset 5)) #(f g h i j k l m n o)) (deftest make-array.displaced.23 (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a - :displaced-index-offset 5 - :fill-pointer t)) + :displaced-index-offset 5 + :fill-pointer t)) #(f g h i j k l m n o)) (deftest make-array.displaced.24 (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a - :displaced-index-offset 5 - :fill-pointer 5)) + :displaced-index-offset 5 + :fill-pointer 5)) #(f g h i j)) (deftest make-array.displaced.25 (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a - :displaced-index-offset 5 - :adjustable t)) + :displaced-index-offset 5 + :adjustable t)) #(f g h i j k l m n o)) (deftest make-array.displaced.26 (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d) (e f g h) (i j k l)) - ((m n o p) (q r s t) (u v w x)))))) + :initial-contents '(((a b c d) (e f g h) (i j k l)) + ((m n o p) (q r s t) (u v w x)))))) (make-array-with-checks '(10) :displaced-to a - :displaced-index-offset 5 - :fill-pointer 8 - :adjustable t)) + :displaced-index-offset 5 + :fill-pointer 8 + :adjustable t)) #(f g h i j k l m)) (deftest make-array.displaced.27 (let ((a (make-array '(10) - :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer t))) + :initial-contents '(1 2 3 4 5 6 7 8 9 10) + :fill-pointer t))) (make-array-with-checks '(2 4) :displaced-to a)) #2a((1 2 3 4) (5 6 7 8))) (deftest make-array.displaced.28 (let ((a (make-array '(10) - :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 4))) + :initial-contents '(1 2 3 4 5 6 7 8 9 10) + :fill-pointer 4))) (make-array-with-checks '(2 4) :displaced-to a)) #2a((1 2 3 4) (5 6 7 8))) (deftest make-array.displaced.29 (let ((a (make-array '(10) :initial-element 0))) (prog1 - (make-array-with-checks '(2 4) :displaced-to a) + (make-array-with-checks '(2 4) :displaced-to a) (loop for i below 10 do (setf (aref a i) (1+ i))))) #2a((1 2 3 4) (5 6 7 8))) (deftest make-array.displaced.30 (let* ((a1 (make-array '(10) :initial-element 0)) - (a2 (make-array '(10) :displaced-to a1))) + (a2 (make-array '(10) :displaced-to a1))) (prog1 - (make-array-with-checks '(2 4) :displaced-to a2) + (make-array-with-checks '(2 4) :displaced-to a2) (loop for i below 10 do (setf (aref a2 i) (1+ i))))) #2a((1 2 3 4) (5 6 7 8))) (deftest make-array.displaced.31 (let* ((a1 (make-array '(10) :initial-element 0)) - (a2 (make-array '(10) :displaced-to a1))) + (a2 (make-array '(10) :displaced-to a1))) (prog1 - (make-array-with-checks '(2 4) :displaced-to a2) + (make-array-with-checks '(2 4) :displaced-to a2) (loop for i below 10 do (setf (aref a1 i) (1+ i))))) #2a((1 2 3 4) (5 6 7 8))) @@ -677,7 +677,7 @@ (deftest make-array.allow-other-keys.6 (make-array '(5) :bad t :initial-element 'a :allow-other-keys t - :allow-other-keys nil :also-bad nil) + :allow-other-keys nil :also-bad nil) #(a a a a a)) (deftest make-array.allow-other-keys.7 @@ -700,13 +700,13 @@ (deftest make-array.error.3 (signals-error (make-array '(10) :allow-other-keys nil :bad t) - program-error) + program-error) t) (deftest make-array.error.4 (signals-error (make-array '(10) :allow-other-keys nil - :allow-other-keys t :bad t) - program-error) + :allow-other-keys t :bad t) + program-error) t) (deftest make-array.error.5 @@ -723,11 +723,11 @@ (let ((i 0) a b c e) (values (make-array (progn (setf a (incf i)) 5) - :initial-element (progn (setf b (incf i)) 'a) - :fill-pointer (progn (setf c (incf i)) nil) - ;; :displaced-to (progn (setf d (incf i)) nil) - :element-type (progn (setf e (incf i)) t) - ) + :initial-element (progn (setf b (incf i)) 'a) + :fill-pointer (progn (setf c (incf i)) nil) + ;; :displaced-to (progn (setf d (incf i)) nil) + :element-type (progn (setf e (incf i)) t) + ) i a b c e)) #(a a a a a) 4 1 2 3 4) @@ -735,11 +735,11 @@ (let ((i 0) a b d e) (values (make-array (progn (setf a (incf i)) 5) - :element-type (progn (setf b (incf i)) t) - ;; :displaced-to (progn (setf c (incf i)) nil) - :fill-pointer (progn (setf d (incf i)) nil) - :initial-element (progn (setf e (incf i)) 'a) - ) + :element-type (progn (setf b (incf i)) t) + ;; :displaced-to (progn (setf c (incf i)) nil) + :fill-pointer (progn (setf d (incf i)) nil) + :initial-element (progn (setf e (incf i)) 'a) + ) i a b d e)) #(a a a a a) 4 1 2 3 4) diff --git a/ansi-tests/make-broadcast-stream.lsp b/ansi-tests/make-broadcast-stream.lsp index 25615a96..90b382e1 100644 --- a/ansi-tests/make-broadcast-stream.lsp +++ b/ansi-tests/make-broadcast-stream.lsp @@ -33,13 +33,13 @@ (assert (open-stream-p s)) (assert (streamp s)) (assert (eql (stream-element-type s) - (stream-element-type s1))) + (stream-element-type s1))) (write-char #\x s))) "x") (deftest make-broadcast-stream.3 (let ((s1 (make-string-output-stream)) - (s2 (make-string-output-stream))) + (s2 (make-string-output-stream))) (let ((s (make-broadcast-stream s1 s2))) (assert (typep s 'stream)) (assert (typep s 'broadcast-stream)) @@ -48,7 +48,7 @@ (assert (open-stream-p s)) (assert (streamp s)) (assert (eql (stream-element-type s) - (stream-element-type s2))) + (stream-element-type s2))) (format s "This is a test")) (values (get-output-stream-string s1) @@ -89,11 +89,11 @@ (deftest make-broadcast-stream.error.1 (check-type-error #'make-broadcast-stream - #'(lambda (x) (and (streamp x) (output-stream-p x)))) + #'(lambda (x) (and (streamp x) (output-stream-p x)))) nil) (deftest make-broadcast-stream.error.2 (check-type-error #'make-broadcast-stream - #'(lambda (x) (and (streamp x) (output-stream-p x))) - *streams*) + #'(lambda (x) (and (streamp x) (output-stream-p x))) + *streams*) nil) diff --git a/ansi-tests/make-concatenated-stream.lsp b/ansi-tests/make-concatenated-stream.lsp index 97da9206..ce6f6a6d 100644 --- a/ansi-tests/make-concatenated-stream.lsp +++ b/ansi-tests/make-concatenated-stream.lsp @@ -47,16 +47,16 @@ (deftest make-concatenated-stream.9 (let ((pn #p"tmp.dat") - (element-type '(unsigned-byte 8))) + (element-type '(unsigned-byte 8))) (with-open-file (s pn :direction :output :element-type element-type - :if-exists :supersede) - (dolist (b '(1 5 9 13)) (write-byte b s))) + :if-exists :supersede) + (dolist (b '(1 5 9 13)) (write-byte b s))) (with-open-file (s1 pn :direction :input :element-type element-type) (with-open-file (s2 pn :direction :input :element-type element-type) (let ((s (make-concatenated-stream s1 s2))) - (loop repeat 8 collect (read-byte s)))))) + (loop repeat 8 collect (read-byte s)))))) (1 5 9 13 1 5 9 13)) (deftest make-concatenated-stream.10 @@ -137,8 +137,8 @@ (s2 "b") (let ((s (make-concatenated-stream s1 s2))) (multiple-value-bind (str mnp) - (read-line s) - (values str (notnot mnp)))))) + (read-line s) + (values str (notnot mnp)))))) "ab" t) (deftest make-concatenated-stream.18 @@ -148,8 +148,8 @@ (s2 "") (let ((s (make-concatenated-stream s1 s2))) (multiple-value-bind (str mnp) - (read-line s) - (values str (notnot mnp)))))) + (read-line s) + (values str (notnot mnp)))))) "ab" t) (deftest make-concatenated-stream.19 @@ -159,8 +159,8 @@ (s2 "ab") (let ((s (make-concatenated-stream s1 s2))) (multiple-value-bind (str mnp) - (read-line s) - (values str (notnot mnp)))))) + (read-line s) + (values str (notnot mnp)))))) "ab" t) (deftest make-concatenated-stream.20 @@ -179,61 +179,61 @@ (s2 "") (let ((s (make-concatenated-stream s1 s2))) (multiple-value-bind (str mnp) - (read-line s nil :eof) - (values str (notnot mnp)))))) + (read-line s nil :eof) + (values str (notnot mnp)))))) :eof t) (deftest make-concatenated-stream.22 (let ((pn #p"tmp.dat") - (element-type '(unsigned-byte 8))) + (element-type '(unsigned-byte 8))) (with-open-file (s pn :direction :output :element-type element-type - :if-exists :supersede) - (dolist (b '(1 5 9 13)) (write-byte b s))) + :if-exists :supersede) + (dolist (b '(1 5 9 13)) (write-byte b s))) (with-open-file (s1 pn :direction :input :element-type element-type) (with-open-file (s2 pn :direction :input :element-type element-type) (let ((s (make-concatenated-stream s1 s2)) - (x (vector nil nil nil nil nil nil nil nil))) - (values - (read-sequence x s) - x))))) + (x (vector nil nil nil nil nil nil nil nil))) + (values + (read-sequence x s) + x))))) 8 #(1 5 9 13 1 5 9 13)) (deftest make-concatenated-stream.23 (let ((pn #p"tmp.dat") - (element-type '(unsigned-byte 8))) + (element-type '(unsigned-byte 8))) (with-open-file (s pn :direction :output :element-type element-type - :if-exists :supersede) - (dolist (b '(1 5 9 13)) (write-byte b s))) + :if-exists :supersede) + (dolist (b '(1 5 9 13)) (write-byte b s))) (with-open-file (s1 pn :direction :input :element-type element-type) (with-open-file (s2 pn :direction :input :element-type element-type) (let ((s (make-concatenated-stream s1 s2)) - (x (vector nil nil nil nil nil nil))) - (values - (read-sequence x s) - x))))) + (x (vector nil nil nil nil nil nil))) + (values + (read-sequence x s) + x))))) 6 #(1 5 9 13 1 5)) (deftest make-concatenated-stream.24 (let ((pn #p"tmp.dat") - (element-type '(unsigned-byte 8))) + (element-type '(unsigned-byte 8))) (with-open-file (s pn :direction :output :element-type element-type - :if-exists :supersede) - (dolist (b '(1 5 9 13)) (write-byte b s))) + :if-exists :supersede) + (dolist (b '(1 5 9 13)) (write-byte b s))) (with-open-file (s1 pn :direction :input :element-type element-type) (with-open-file (s2 pn :direction :input :element-type element-type) (let ((s (make-concatenated-stream s1 s2)) - (x (vector nil nil nil nil nil nil nil nil nil nil))) - (values - (read-sequence x s) - x))))) + (x (vector nil nil nil nil nil nil nil nil nil nil))) + (values + (read-sequence x s) + x))))) 8 #(1 5 9 13 1 5 9 13 nil nil)) @@ -244,7 +244,7 @@ (deftest make-concatenated-stream.26 (let ((s (make-concatenated-stream))) (values (prog1 (close s) (close s)) - (open-stream-p s))) + (open-stream-p s))) t nil) (deftest make-concatenated-stream.27 @@ -309,15 +309,15 @@ (deftest make-concatenated-stream.error.1 (loop for x in *mini-universe* - unless (or (and (streamp x) (input-stream-p x)) - (eval `(signals-error (make-concatenated-stream ',x) t))) - collect x) + unless (or (and (streamp x) (input-stream-p x)) + (eval `(signals-error (make-concatenated-stream ',x) t))) + collect x) nil) (deftest make-concatenated-stream.error.2 (loop for x in *streams* - unless (or (and (streamp x) (input-stream-p x)) - (eval `(signals-error (make-concatenated-stream ',x) t))) - collect x) + unless (or (and (streamp x) (input-stream-p x)) + (eval `(signals-error (make-concatenated-stream ',x) t))) + collect x) nil) diff --git a/ansi-tests/make-condition.lsp b/ansi-tests/make-condition.lsp index 964d1d63..ace4097d 100644 --- a/ansi-tests/make-condition.lsp +++ b/ansi-tests/make-condition.lsp @@ -8,41 +8,41 @@ (deftest make-condition.1 (loop for tp in *cl-condition-type-symbols* - for c = (make-condition tp) - unless (and (typep c tp) - (typep c 'condition)) - collect (list tp c)) + for c = (make-condition tp) + unless (and (typep c tp) + (typep c 'condition)) + collect (list tp c)) nil) (deftest make-condition.2 (loop for tp in *cl-condition-type-symbols* - for class = (find-class tp) - for c = (and class (make-condition class)) - unless (or (not class) - (and (typep c tp) - (typep c class) - (typep c 'condition))) - collect (list tp c)) + for class = (find-class tp) + for c = (and class (make-condition class)) + unless (or (not class) + (and (typep c tp) + (typep c class) + (typep c 'condition))) + collect (list tp c)) nil) (deftest make-condition.3 :notes (:make-condition-with-compound-name :ansi-spec-problem) (let* ((tp '(or program-error type-error)) - (c (make-condition tp))) + (c (make-condition tp))) (or (not (and (subtypep tp 'condition) - (or (subtypep 'program-error tp) - (subtypep 'type-error tp)))) - (notnot-mv (typep c tp)))) + (or (subtypep 'program-error tp) + (subtypep 'type-error tp)))) + (notnot-mv (typep c tp)))) t) (deftest make-condition.4 :notes (:make-condition-with-compound-name :ansi-spec-problem) (let* ((tp '(and simple-error type-error)) - (c (make-condition tp))) + (c (make-condition tp))) (or (not (and (subtypep 'simple-error tp) - (subtypep 'type-error tp) - (subtypep tp 'condition))) - (notnot-mv (typep c tp)))) + (subtypep 'type-error tp) + (subtypep tp 'condition))) + (notnot-mv (typep c tp)))) t) ;;; Error tests diff --git a/ansi-tests/make-echo-stream.lsp b/ansi-tests/make-echo-stream.lsp index 223a2321..8d73cea9 100644 --- a/ansi-tests/make-echo-stream.lsp +++ b/ansi-tests/make-echo-stream.lsp @@ -7,8 +7,8 @@ (deftest make-echo-stream.1 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (read-char s) (get-output-stream-string os))) @@ -16,39 +16,39 @@ (deftest make-echo-stream.2 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (get-output-stream-string os)) "") (deftest make-echo-stream.3 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (read-line s nil) - (get-output-stream-string os))) + (get-output-stream-string os))) "foo" "foo") ;;; Tests of READ-BYTE on echo streams (deftest make-echo-stream.4 (let ((pn #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 8))) + (pn2 #p"tmp2.dat") + (element-type '(unsigned-byte 8))) (with-open-file (os pn - :direction :output - :element-type element-type - :if-exists :supersede) - (loop for x in '(2 3 5 7 11) - do (write-byte x os))) + :direction :output + :element-type element-type + :if-exists :supersede) + (loop for x in '(2 3 5 7 11) + do (write-byte x os))) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede - :element-type element-type) + :element-type element-type) (let ((s (make-echo-stream is os))) - (loop repeat 6 collect (read-byte s nil :eof1)))) + (loop repeat 6 collect (read-byte s nil :eof1)))) (with-open-file (s pn2 :direction :input :element-type element-type) (loop repeat 6 collect (read-byte s nil :eof2)))))) @@ -57,22 +57,22 @@ (deftest make-echo-stream.5 (let ((pn #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 8))) + (pn2 #p"tmp2.dat") + (element-type '(unsigned-byte 8))) (with-open-file (os pn - :direction :output - :element-type element-type - :if-exists :supersede) - (loop for x in '(2 3 5 7 11) - do (write-byte x os))) + :direction :output + :element-type element-type + :if-exists :supersede) + (loop for x in '(2 3 5 7 11) + do (write-byte x os))) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede - :element-type element-type) + :element-type element-type) (let ((s (make-echo-stream is os))) - (loop repeat 6 collect (read-byte s nil 100)))) + (loop repeat 6 collect (read-byte s nil 100)))) (with-open-file (s pn2 :direction :input :element-type element-type) (loop repeat 6 collect (read-byte s nil 200)))))) @@ -81,19 +81,19 @@ (deftest make-echo-stream.6 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (coerce (loop repeat 3 collect (read-char-no-hang s)) 'string) - (get-output-stream-string os))) + (get-output-stream-string os))) "foo" "foo") (deftest make-echo-stream.7 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (coerce (loop repeat 4 collect (read-char-no-hang s nil '#\z)) - 'string) - (get-output-stream-string os))) + 'string) + (get-output-stream-string os))) "fooz" "foo") ;;; peek-char + echo streams is tested in peek-char.lsp @@ -101,9 +101,9 @@ (deftest make-echo-stream.8 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os)) - (x (copy-seq "xxxxxx"))) + (os (make-string-output-stream)) + (s (make-echo-stream is os)) + (x (copy-seq "xxxxxx"))) (values (read-sequence x s) x @@ -114,24 +114,24 @@ (deftest make-echo-stream.9 (let ((pn #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 8))) + (pn2 #p"tmp2.dat") + (element-type '(unsigned-byte 8))) (with-open-file (os pn - :direction :output - :element-type element-type - :if-exists :supersede) - (loop for x in '(2 3 5 7 11) - do (write-byte x os))) + :direction :output + :element-type element-type + :if-exists :supersede) + (loop for x in '(2 3 5 7 11) + do (write-byte x os))) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede - :element-type element-type) + :element-type element-type) (let ((s (make-echo-stream is os)) - (x (vector 0 0 0 0 0 0 0 0))) - (list (read-sequence x s) - x))) + (x (vector 0 0 0 0 0 0 0 0))) + (list (read-sequence x s) + x))) (with-open-file (s pn2 :direction :input :element-type element-type) (loop repeat 8 collect (read-byte s nil nil)))))) @@ -140,8 +140,8 @@ (deftest make-echo-stream.10 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (notnot (open-stream-p s)) (close s) @@ -152,8 +152,8 @@ (deftest make-echo-stream.11 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (notnot (listen s)) (read-char s) @@ -166,8 +166,8 @@ (deftest make-echo-stream.12 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (notnot (streamp s)) (notnot (typep s 'stream)) @@ -184,8 +184,8 @@ (deftest make-echo-stream.13 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (write-char #\0 s) (close s) @@ -194,8 +194,8 @@ (deftest make-echo-stream.14 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (terpri s) (close s) @@ -204,66 +204,66 @@ (deftest make-echo-stream.15 (let ((pn #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 8))) + (pn2 #p"tmp2.dat") + (element-type '(unsigned-byte 8))) (with-open-file (os pn - :direction :output - :element-type element-type - :if-exists :supersede)) + :direction :output + :element-type element-type + :if-exists :supersede)) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede - :element-type element-type) + :element-type element-type) (let ((s (make-echo-stream is os)) - (x (mapcar #'char-code (coerce "abcdefg" 'list)))) - (loop for b in x do - (assert (equal (list b) - (multiple-value-list (write-byte b s))))) - (close s))))) + (x (mapcar #'char-code (coerce "abcdefg" 'list)))) + (loop for b in x do + (assert (equal (list b) + (multiple-value-list (write-byte b s))))) + (close s))))) (with-open-file (is pn2 :direction :input :element-type element-type) (let ((x (vector 0 0 0 0 0 0 0))) (read-sequence x is) (values - (read-byte is nil :done) - (map 'string #'code-char x))))) + (read-byte is nil :done) + (map 'string #'code-char x))))) :done "abcdefg") (deftest make-echo-stream.16 (let ((pn #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 8))) + (pn2 #p"tmp2.dat") + (element-type '(unsigned-byte 8))) (with-open-file (os pn - :direction :output - :element-type element-type - :if-exists :supersede)) + :direction :output + :element-type element-type + :if-exists :supersede)) (with-open-file (is pn :direction :input :element-type element-type) (values (with-open-file (os pn2 :direction :output :if-exists :supersede - :element-type element-type) + :element-type element-type) (let ((s (make-echo-stream is os)) - (x (map 'vector #'char-code "abcdefg"))) - (assert (equal (multiple-value-list (write-sequence x s)) (list x))) - (close s))))) + (x (map 'vector #'char-code "abcdefg"))) + (assert (equal (multiple-value-list (write-sequence x s)) (list x))) + (close s))))) (with-open-file (is pn2 :direction :input :element-type element-type) (let ((x (vector 0 0 0 0 0 0 0))) (read-sequence x is) (values - (read-byte is nil :done) - (map 'string #'code-char x))))) + (read-byte is nil :done) + (map 'string #'code-char x))))) :done "abcdefg") (deftest make-echo-stream.17 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (write-char #\X s) (notnot (fresh-line s)) @@ -275,8 +275,8 @@ (deftest make-echo-stream.18 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (write-string "159" s) (close s) @@ -285,8 +285,8 @@ (deftest make-echo-stream.20 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (write-string "0159X" s :start 1 :end 4) (close s) @@ -295,8 +295,8 @@ (deftest make-echo-stream.21 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (write-line "159" s) (close s) @@ -305,8 +305,8 @@ (deftest make-echo-stream.22 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-echo-stream is os))) + (os (make-string-output-stream)) + (s (make-echo-stream is os))) (values (write-char #\0 s) (clear-output s))) @@ -324,7 +324,7 @@ (deftest make-echo-stream.error.3 (signals-error (make-echo-stream *standard-input* *standard-output* nil) - program-error) + program-error) t) diff --git a/ansi-tests/make-instance.lsp b/ansi-tests/make-instance.lsp index c6d3a125..baa981c6 100644 --- a/ansi-tests/make-instance.lsp +++ b/ansi-tests/make-instance.lsp @@ -16,38 +16,38 @@ (deftest make-instance.error.2 (signals-error (make-instance 'make-instance-class-01 :a) - program-error) + program-error) t) (deftest make-instance.error.3 (handler-case (progn (eval '(make-instance 'make-instance-class-01 :z 1)) - t) - (error () :good)) + t) + (error () :good)) :good) (deftest make-instance.error.4 (handler-case (progn (eval '(make-instance - (find-class 'make-instance-class-01) - :z 1)) - t) - (error () :good)) + (find-class 'make-instance-class-01) + :z 1)) + t) + (error () :good)) :good) (deftest make-instance.error.5 (signals-error (let () (make-instance) nil) - program-error) + program-error) t) (deftest make-instance.error.6 (loop for cl in *built-in-classes* - unless (eval `(signals-error (make-instance ',cl) error)) - collect cl) + unless (eval `(signals-error (make-instance ',cl) error)) + collect cl) nil) ;; Definitions of methods (defmethod make-instance ((x make-instance-class-01) - &rest initargs &key &allow-other-keys) + &rest initargs &key &allow-other-keys) initargs) (deftest make-instance.1 @@ -60,21 +60,21 @@ #| (when *can-define-metaclasses* - + (defclass make-instance-class-02 () (a b c) (:metaclass substandard-class)) - + (defmethod make-instance ((class (eql (find-class 'make-instance-class-02))) - &rest initargs &key (x nil) (y nil) (z nil) - &allow-other-keys) + &rest initargs &key (x nil) (y nil) (z nil) + &allow-other-keys) (declare (ignore initargs)) (let ((obj (allocate-instance class))) (setf (slot-value obj 'a) x - (slot-value obj 'b) y - (slot-value obj 'c) z) + (slot-value obj 'b) y + (slot-value obj 'c) z) obj)) - + (deftest make-instance.3 (let ((obj (make-instance 'make-instance-class-02))) (values @@ -83,7 +83,7 @@ (slot-value obj 'b) (slot-value obj 'c))) t nil nil nil) - + (deftest make-instance.4 (let ((obj (make-instance 'make-instance-class-02 :z 10 :y 45 :x 'd))) (values @@ -92,8 +92,8 @@ (slot-value obj 'b) (slot-value obj 'c))) t d 45 10) - - + + (deftest make-instance.5 (let ((obj (make-instance (find-class 'make-instance-class-02) :y 'g))) (values @@ -102,48 +102,48 @@ (slot-value obj 'b) (slot-value obj 'c))) t nil g nil) - + (deftest make-instance.6 (eq (make-instance 'make-instance-class-02) - (make-instance 'make-instance-class-02)) + (make-instance 'make-instance-class-02)) nil) ;; Customization of make-instance - + (defclass make-instance-class-03 () ((a :initform 1) (b :initarg :b) c) (:metaclass substandard-class)) (defmethod make-instance ((class (eql (find-class 'make-instance-class-03))) - &rest initargs - &key (x nil x-p) (y nil y-p) (z nil z-p) - &allow-other-keys) + &rest initargs + &key (x nil x-p) (y nil y-p) (z nil z-p) + &allow-other-keys) (declare (ignore initargs)) (let ((obj (allocate-instance (find-class 'make-instance-class-03)))) (when x-p (setf (slot-value obj 'a) x)) (when y-p (setf (slot-value obj 'b) y)) (when z-p (setf (slot-value obj 'c) z)) obj)) - + (deftest make-instance.7 (let ((obj (make-instance 'make-instance-class-03))) (values (eqt (class-of obj) - (find-class 'make-instance-class-03)) + (find-class 'make-instance-class-03)) (map-slot-boundp* obj '(a b c)))) t (nil nil nil)) - + (deftest make-instance.8 (let* ((class (find-class 'make-instance-class-03)) - (obj (make-instance class :b 10))) + (obj (make-instance class :b 10))) (values (eqt (class-of obj) class) (map-slot-boundp* obj '(a b c)))) t (nil nil nil)) - + (deftest make-instance.9 (let* ((class (find-class 'make-instance-class-03)) - (obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad))) + (obj (make-instance class :x 'g :z 'i :y 'k :foo t :x 'bad))) (values (eqt (class-of obj) class) (map-slot-boundp* obj '(a b c)) @@ -163,15 +163,15 @@ &rest initargs &key &allow-other-keys) (declare (ignore initargs)) (incf *make-instance-class-04-var* 10)) - + (deftest make-instance.10 (let* ((*make-instance-class-04-var* 0) - (obj (make-instance 'make-instance-class-04))) + (obj (make-instance 'make-instance-class-04))) (values (slot-value obj 'a) *make-instance-class-04-var*)) 0 10) - + ;; Around method combination (defclass make-instance-class-05 () @@ -185,7 +185,7 @@ (let ((obj (call-next-method))) (setf (slot-value obj 'c) 'bar) obj)) - + (deftest make-instance.11 (let ((obj (make-instance 'make-instance-class-05))) (values @@ -200,9 +200,9 @@ (deftest make-instance.order.1 (let* ((i 0) x y - (obj (make-instance 'make-instance-class-01 - :a (setf x (incf i)) - :b (setf y (incf i))))) + (obj (make-instance 'make-instance-class-01 + :a (setf x (incf i)) + :b (setf y (incf i))))) (values (map-slot-value obj '(a b)) i x y)) @@ -210,11 +210,11 @@ (deftest make-instance.order.2 (let* ((i 0) x y z w - (obj (make-instance 'make-instance-class-01 - :a (setf x (incf i)) - :b (setf y (incf i)) - :b (setf z (incf i)) - :a (setf w (incf i))))) + (obj (make-instance 'make-instance-class-01 + :a (setf x (incf i)) + :b (setf y (incf i)) + :b (setf z (incf i)) + :a (setf w (incf i))))) (values (map-slot-value obj '(a b)) i x y z w)) @@ -222,12 +222,12 @@ (deftest make-instance.order.3 (let* ((i 0) u x y z w - (obj (make-instance (prog1 'make-instance-class-01 - (setf u (incf i))) - :a (setf x (incf i)) - :b (setf y (incf i)) - :b (setf z (incf i)) - :a (setf w (incf i))))) + (obj (make-instance (prog1 'make-instance-class-01 + (setf u (incf i))) + :a (setf x (incf i)) + :b (setf y (incf i)) + :b (setf z (incf i)) + :a (setf w (incf i))))) (values (map-slot-value obj '(a b)) i u x y z w)) diff --git a/ansi-tests/make-instances-obsolete.lsp b/ansi-tests/make-instances-obsolete.lsp index ff7aede7..4cc14f04 100644 --- a/ansi-tests/make-instances-obsolete.lsp +++ b/ansi-tests/make-instances-obsolete.lsp @@ -13,27 +13,27 @@ (deftest make-instances-obsolete.1 (let* ((class-designator 'make-instances-obsolete-class-01) - (class (find-class class-designator)) - (obj (make-instance class :a 'x :b 'y :c 'z :d 17))) + (class (find-class class-designator)) + (obj (make-instance class :a 'x :b 'y :c 'z :d 17))) (values (eqt (class-of obj) class) (map-slot-value obj '(a b c d)) (let ((val (make-instances-obsolete class))) (or (eqt val class-designator) - (eqt val class))) + (eqt val class))) (map-slot-value obj '(a b c d)))) t (x y z 17) t (x y z 17)) (deftest make-instances-obsolete.2 (let* ((class-designator 'make-instances-obsolete-class-01) - (class (find-class class-designator)) - (obj (make-instance class :a 'x :b 'y :c 'z :d 17))) + (class (find-class class-designator)) + (obj (make-instance class :a 'x :b 'y :c 'z :d 17))) (values (eqt (class-of obj) class) (map-slot-value obj '(a b c d)) (let ((val (make-instances-obsolete class-designator))) (or (eqt val class-designator) - (eqt val class))) + (eqt val class))) (map-slot-value obj '(a b c d)))) t (x y z 17) t (x y z 17)) @@ -45,7 +45,7 @@ (deftest make-instances-obsolete.error.2 (signals-error (make-instances-obsolete - (find-class 'make-instances-obsolete-class-01) - nil) - program-error) + (find-class 'make-instances-obsolete-class-01) + nil) + program-error) t) diff --git a/ansi-tests/make-list.lsp b/ansi-tests/make-list.lsp index 84010d2a..f7b88b58 100644 --- a/ansi-tests/make-list.lsp +++ b/ansi-tests/make-list.lsp @@ -51,8 +51,8 @@ (let ((i 0) x y) (values (make-list (progn (setf x (incf i)) 5) - :initial-element - (progn (setf y (incf i)) 'a)) + :initial-element + (progn (setf y (incf i)) 'a)) i x y)) (a a a a a) 2 1 2) @@ -61,10 +61,10 @@ (let ((i 0) x y z) (values (make-list (progn (setf x (incf i)) 5) - :initial-element - (progn (setf y (incf i)) 'a) - :initial-element - (progn (setf z (incf i)) 'b)) + :initial-element + (progn (setf y (incf i)) 'a) + :initial-element + (progn (setf z (incf i)) 'b)) i x y z)) (a a a a a) 3 1 2 3) @@ -96,7 +96,7 @@ (deftest make-list.error.7 (signals-error (make-list 5 :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest make-list.error.8 diff --git a/ansi-tests/make-load-form-saving-slots.lsp b/ansi-tests/make-load-form-saving-slots.lsp index 082ebd95..8487f428 100644 --- a/ansi-tests/make-load-form-saving-slots.lsp +++ b/ansi-tests/make-load-form-saving-slots.lsp @@ -13,8 +13,8 @@ (deftest make-load-form-saving-slots.1 (let* ((obj (make-mlfss-01)) - (forms (multiple-value-list - (make-load-form-saving-slots obj)))) + (forms (multiple-value-list + (make-load-form-saving-slots obj)))) (values (length forms) (let ((newobj (eval (first forms)))) @@ -24,8 +24,8 @@ (deftest make-load-form-saving-slots.2 (let* ((obj (make-mlfss-01)) - (forms (multiple-value-list - (make-load-form-saving-slots obj :slot-names '(a b))))) + (forms (multiple-value-list + (make-load-form-saving-slots obj :slot-names '(a b))))) (values (length forms) (let ((newobj (eval (first forms)))) @@ -37,95 +37,95 @@ (deftest make-load-form-saving-slots.3 (let* ((obj (make-instance 'mlfss-02)) - (forms (multiple-value-list - (make-load-form-saving-slots obj)))) + (forms (multiple-value-list + (make-load-form-saving-slots obj)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c))))) + (length forms) + (eqt (class-of obj) (class-of newobj)) + (map-slot-boundp* newobj '(a b c))))) 2 t (nil nil nil)) (deftest make-load-form-saving-slots.4 (let* ((obj (make-instance 'mlfss-02 :a 1 :b 'a :c '(x y z))) - (forms (multiple-value-list - (make-load-form-saving-slots obj :slot-names '(a b c))))) + (forms (multiple-value-list + (make-load-form-saving-slots obj :slot-names '(a b c))))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c)) - (map-slot-value newobj '(a b c))))) + (length forms) + (eqt (class-of obj) (class-of newobj)) + (map-slot-boundp* newobj '(a b c)) + (map-slot-value newobj '(a b c))))) 2 t (t t t) (1 a (x y z))) (deftest make-load-form-saving-slots.5 (let* ((obj (make-instance 'mlfss-02 :a #(x y z))) - (forms (multiple-value-list - (make-load-form-saving-slots obj :slot-names '(a b))))) + (forms (multiple-value-list + (make-load-form-saving-slots obj :slot-names '(a b))))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c)) - (slot-value newobj 'a)))) + (length forms) + (eqt (class-of obj) (class-of newobj)) + (map-slot-boundp* newobj '(a b c)) + (slot-value newobj 'a)))) 2 t (t nil nil) #(x y z)) (deftest make-load-form-saving-slots.6 (let* ((obj (make-instance 'mlfss-02)) - (forms (multiple-value-list - (make-load-form-saving-slots obj :allow-other-keys nil)))) + (forms (multiple-value-list + (make-load-form-saving-slots obj :allow-other-keys nil)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c))))) + (length forms) + (eqt (class-of obj) (class-of newobj)) + (map-slot-boundp* newobj '(a b c))))) 2 t (nil nil nil)) ;;; If :slot-names is missing, all initialized slots are retained (deftest make-load-form-saving-slots.7 (let* ((obj (make-instance 'mlfss-02 :a (list 'x) :c 6/5)) - (forms (multiple-value-list - (make-load-form-saving-slots obj)))) + (forms (multiple-value-list + (make-load-form-saving-slots obj)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c)) - (map-slot-value newobj '(a c))))) + (length forms) + (eqt (class-of obj) (class-of newobj)) + (map-slot-boundp* newobj '(a b c)) + (map-slot-value newobj '(a c))))) 2 t (t nil t) ((x) 6/5)) ;;; If :slot-names is present, all initialized slots in the list are retained (deftest make-load-form-saving-slots.8 (let* ((obj (make-instance 'mlfss-02 :a (list 'x) :c 6/5)) - (forms (multiple-value-list - (make-load-form-saving-slots obj :slot-names '(c))))) + (forms (multiple-value-list + (make-load-form-saving-slots obj :slot-names '(c))))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c)) - (slot-value newobj 'c)))) + (length forms) + (eqt (class-of obj) (class-of newobj)) + (map-slot-boundp* newobj '(a b c)) + (slot-value newobj 'c)))) 2 t (nil nil t) 6/5) ;; It takes an :environment parameter (deftest make-load-form-saving-slots.9 (let* ((obj (make-instance 'mlfss-02 :a 7 :c 64 :b 100)) - (forms (multiple-value-list - (make-load-form-saving-slots obj :environment nil)))) + (forms (multiple-value-list + (make-load-form-saving-slots obj :environment nil)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values - (length forms) - (eqt (class-of obj) (class-of newobj)) - (map-slot-boundp* newobj '(a b c)) - (map-slot-value newobj '(a b c))))) + (length forms) + (eqt (class-of obj) (class-of newobj)) + (map-slot-boundp* newobj '(a b c)) + (map-slot-value newobj '(a b c))))) 2 t (t t t) (7 100 64)) (defpackage "CL-TEST-MLFSS-PACKAGE" (:use) (:export #:a)) @@ -133,8 +133,8 @@ (deftest make-load-form-savings-slots.10 (let* ((obj (make-mlfss-03 :a 17)) - (forms (multiple-value-list - (make-load-form-saving-slots obj)))) + (forms (multiple-value-list + (make-load-form-saving-slots obj)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values @@ -146,10 +146,10 @@ (deftest make-load-form-savings-slots.11 (let* ((obj (make-mlfss-03 :a 17)) - (forms (multiple-value-list - (make-load-form-saving-slots - obj - :slot-names '(cl-test-mlfss-package:a))))) + (forms (multiple-value-list + (make-load-form-saving-slots + obj + :slot-names '(cl-test-mlfss-package:a))))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values @@ -164,8 +164,8 @@ (deftest make-load-form-savings-slots.12 (let* ((obj (make-mlfss-04 :a 123)) - (forms (multiple-value-list - (make-load-form-saving-slots obj)))) + (forms (multiple-value-list + (make-load-form-saving-slots obj)))) (let ((newobj (eval (first forms)))) (eval (subst newobj obj (second forms))) (values @@ -184,12 +184,12 @@ (deftest make-load-form-saving-slots.error.2 (signals-error (make-load-form-saving-slots (make-instance 'mlfss-02) - :slot-names) - program-error) + :slot-names) + program-error) t) (deftest make-load-form-saving-slots.error.3 (signals-error (make-load-form-saving-slots (make-instance 'mlfss-02) - (gensym) t) - program-error) + (gensym) t) + program-error) t) diff --git a/ansi-tests/make-load-form.lsp b/ansi-tests/make-load-form.lsp index 1acbc13b..22fb03cc 100644 --- a/ansi-tests/make-load-form.lsp +++ b/ansi-tests/make-load-form.lsp @@ -12,15 +12,15 @@ (deftest make-load-form.1 (let* ((fun #'make-load-form) - (obj (make-instance 'make-load-form-class-01))) + (obj (make-instance 'make-load-form-class-01))) (if (eql (or (find-method fun nil '(standard-object) nil) - (find-method fun nil (list (find-class t)) nil) - :none) - (car (compute-applicable-methods fun (list obj)))) - ;; The default method applies - (handler-case - (progn (make-load-form obj) :bad) - (error () :good)) + (find-method fun nil (list (find-class t)) nil) + :none) + (car (compute-applicable-methods fun (list obj)))) + ;; The default method applies + (handler-case + (progn (make-load-form obj) :bad) + (error () :good)) :good)) :good) @@ -28,15 +28,15 @@ (deftest make-load-form.2 (let* ((fun #'make-load-form) - (obj (make-make-load-form-struct-02))) + (obj (make-make-load-form-struct-02))) (if (eql (or (find-method fun nil '(structure-object) nil) - (find-method fun nil (list (find-class t)) nil) - :none) - (car (compute-applicable-methods fun (list obj)))) - ;; The default method applies - (handler-case - (progn (make-load-form obj) :bad) - (error () :good)) + (find-method fun nil (list (find-class t)) nil) + :none) + (car (compute-applicable-methods fun (list obj)))) + ;; The default method applies + (handler-case + (progn (make-load-form obj) :bad) + (error () :good)) :good)) :good) @@ -44,15 +44,15 @@ (deftest make-load-form.3 (let* ((fun #'make-load-form) - (obj (make-condition 'make-load-form-condition-03))) + (obj (make-condition 'make-load-form-condition-03))) (if (eql (or (find-method fun nil '(condition) nil) - (find-method fun nil (list (find-class t)) nil) - :none) - (car (compute-applicable-methods fun (list obj)))) - ;; The default method applies - (handler-case - (progn (make-load-form obj :bad)) - (error () :good)) + (find-method fun nil (list (find-class t)) nil) + :none) + (car (compute-applicable-methods fun (list obj)))) + ;; The default method applies + (handler-case + (progn (make-load-form obj :bad)) + (error () :good)) :good)) :good) @@ -61,73 +61,73 @@ (deftest make-load-form.4 (let* ((obj (make-instance 'make-load-form-class-01)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj)))) + (fun #'make-load-form) + (methods (compute-applicable-methods fun (list obj)))) (notnot-mv methods)) t) (deftest make-load-form.5 (let* ((obj (make-make-load-form-struct-02)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj)))) + (fun #'make-load-form) + (methods (compute-applicable-methods fun (list obj)))) (notnot-mv methods)) t) (deftest make-load-form.6 (let* ((obj (make-condition 'make-load-form-condition-03)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj)))) + (fun #'make-load-form) + (methods (compute-applicable-methods fun (list obj)))) (notnot-mv methods)) t) (deftest make-load-form.7 (let* ((obj (make-instance 'make-load-form-class-01)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj nil)))) + (fun #'make-load-form) + (methods (compute-applicable-methods fun (list obj nil)))) (notnot-mv methods)) t) (deftest make-load-form.8 (let* ((obj (make-make-load-form-struct-02)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj nil)))) + (fun #'make-load-form) + (methods (compute-applicable-methods fun (list obj nil)))) (notnot-mv methods)) t) (deftest make-load-form.9 (let* ((obj (make-condition 'make-load-form-condition-03)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj nil)))) + (fun #'make-load-form) + (methods (compute-applicable-methods fun (list obj nil)))) (notnot-mv methods)) t) - + (deftest make-load-form.10 (macrolet ((%m (&environment env) - (let* ((obj (make-instance 'make-load-form-class-01)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj env)))) - (notnot-mv methods)))) + (let* ((obj (make-instance 'make-load-form-class-01)) + (fun #'make-load-form) + (methods (compute-applicable-methods fun (list obj env)))) + (notnot-mv methods)))) (%m)) t) (deftest make-load-form.11 (macrolet ((%m (&environment env) - (let* ((obj (make-make-load-form-struct-02)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj env)))) - (notnot-mv methods)))) + (let* ((obj (make-make-load-form-struct-02)) + (fun #'make-load-form) + (methods (compute-applicable-methods fun (list obj env)))) + (notnot-mv methods)))) (%m)) t) (deftest make-load-form.12 (macrolet ((%m (&environment env) - (let* ((obj (make-condition 'make-load-form-condition-03)) - (fun #'make-load-form) - (methods (compute-applicable-methods fun (list obj env)))) - (notnot-mv methods)))) + (let* ((obj (make-condition 'make-load-form-condition-03)) + (fun #'make-load-form) + (methods (compute-applicable-methods fun (list obj env)))) + (notnot-mv methods)))) (%m)) t) @@ -137,19 +137,19 @@ ((a :initarg :a) (b :initarg :b) (c :initarg :c))) (defmethod make-load-form ((obj make-load-form-class-04) - &optional (env t)) + &optional (env t)) (declare (ignore env)) (let ((newobj (gensym))) `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04)))) ,@(loop for slot-name in '(a b c) - when (slot-boundp obj slot-name) - collect `(setf (slot-value ,newobj ',slot-name) - ',(slot-value obj slot-name))) + when (slot-boundp obj slot-name) + collect `(setf (slot-value ,newobj ',slot-name) + ',(slot-value obj slot-name))) ,newobj))) (deftest make-load-form.13 (let* ((obj (make-instance 'make-load-form-class-04)) - (obj2 (eval (make-load-form obj)))) + (obj2 (eval (make-load-form obj)))) (values (eqt (class-of obj2) (class-of obj)) (map-slot-boundp* obj2 '(a b c)))) @@ -157,7 +157,7 @@ (deftest make-load-form.14 (let* ((obj (make-instance 'make-load-form-class-04 :a 1 :b '(a b c) :c 'a)) - (obj2 (eval (make-load-form obj)))) + (obj2 (eval (make-load-form obj)))) (values (eqt (class-of obj2) (class-of obj)) (map-slot-boundp* obj2 '(a b c)) @@ -168,7 +168,7 @@ (deftest make-load-form.15 (let* ((obj (make-instance 'make-load-form-class-04 :b '(a b c) :c 'a)) - (obj2 (eval (make-load-form obj nil)))) + (obj2 (eval (make-load-form obj nil)))) (values (eqt (class-of obj2) (class-of obj)) (map-slot-boundp* obj2 '(a b c)) @@ -185,21 +185,21 @@ ((b :initarg :b))) (defmethod make-load-form ((obj make-load-form-class-05a) - &optional (env t)) + &optional (env t)) (declare (ignore env)) (let ((newobj (gensym))) `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04)))) ,@(when (slot-boundp obj 'a) - `((setf (slot-value ,newobj 'a) ',(slot-value obj 'a)))) + `((setf (slot-value ,newobj 'a) ',(slot-value obj 'a)))) ,newobj))) (defmethod make-load-form :around ((obj make-load-form-class-05b) - &optional (env t)) + &optional (env t)) (declare (ignore env)) (let ((newobj (gensym))) `(let ((,newobj (allocate-instance (find-class 'make-load-form-class-04)))) ,@(when (slot-boundp obj 'a) - `((setf (slot-value ,newobj 'a) ',(slot-value obj 'a)))) + `((setf (slot-value ,newobj 'a) ',(slot-value obj 'a)))) ,newobj))) |# diff --git a/ansi-tests/make-package.lsp b/ansi-tests/make-package.lsp index 51f8a3c0..a5234a0d 100644 --- a/ansi-tests/make-package.lsp +++ b/ansi-tests/make-package.lsp @@ -17,11 +17,11 @@ (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1")))) (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t) (deftest make-package.2 @@ -29,11 +29,11 @@ (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1|)))) (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t) (deftest make-package.3 @@ -41,11 +41,11 @@ (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X)))) (prog1 - (and (packagep p) - (equalt (package-name p) "X") - (equalt (package-nicknames p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (and (packagep p) + (equalt (package-name p) "X") + (equalt (package-nicknames p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t) ;; Same, but with a null :use list @@ -55,12 +55,12 @@ (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use nil)))) (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t) (deftest make-package.5 @@ -68,12 +68,12 @@ (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use nil)))) (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t) (deftest make-package.6 @@ -81,12 +81,12 @@ (safely-delete-package #\X) (let ((p (make-package #\X))) (prog1 - (and (packagep p) - (equalt (package-name p) "X") - (equalt (package-nicknames p) nil) - ;; (equalt (package-use-list p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (and (packagep p) + (equalt (package-name p) "X") + (equalt (package-nicknames p) nil) + ;; (equalt (package-use-list p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t) ;; Same, but use the A package @@ -97,12 +97,12 @@ (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use '("A"))))) (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t) (deftest make-package.7a @@ -111,12 +111,12 @@ (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use '(#:|A|))))) (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t) (deftest make-package.7b @@ -125,12 +125,12 @@ (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package "TEST1" :use '(#\A))))) (prog1 - (and (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (and (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t) (deftest make-package.8 @@ -139,12 +139,12 @@ (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '("A"))))) (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (values (notnot (packagep p)) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t t t t) (deftest make-package.8a @@ -153,12 +153,12 @@ (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#:|A|))))) (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (values (notnot (packagep p)) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t t t t) (deftest make-package.8b @@ -167,12 +167,12 @@ (safely-delete-package '#:|TEST1|) (let ((p (ignore-errors (make-package '#:|TEST1| :use '(#\A))))) (multiple-value-prog1 - (values (packagep p) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (values (packagep p) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t t t t) (deftest make-package.9 @@ -181,12 +181,12 @@ (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '("A"))))) (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "X") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (values (notnot (packagep p)) + (equalt (package-name p) "X") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t t t t) (deftest make-package.9a @@ -195,12 +195,12 @@ (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '(#:|A|))))) (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "X") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (values (notnot (packagep p)) + (equalt (package-name p) "X") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t t t t) (deftest make-package.9b @@ -209,12 +209,12 @@ (safely-delete-package #\X) (let ((p (ignore-errors (make-package #\X :use '(#\A))))) (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "X") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package "A"))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (values (notnot (packagep p)) + (equalt (package-name p) "X") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package "A"))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t t t t) ;; make-package with nicknames @@ -224,11 +224,11 @@ (mapc #'safely-delete-package '("TEST1" "F")) (let ((p (make-package "TEST1" :nicknames '("F")))) (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) '("F")) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (values (notnot (packagep p)) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) '("F")) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t t t) (deftest make-package.11 @@ -236,11 +236,11 @@ (mapc #'safely-delete-package '("TEST1" "G")) (let ((p (make-package '#:|TEST1| :nicknames '(#:|G|)))) (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) '("G")) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (values (notnot (packagep p)) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) '("G")) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t t t) (deftest make-package.12 @@ -248,11 +248,11 @@ (mapc #'safely-delete-package '("TEST1" "G")) (let ((p (make-package '#:|TEST1| :nicknames '(#\G)))) (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) '("G")) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (values (notnot (packagep p)) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) '("G")) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t t t) (deftest make-package.13 @@ -260,13 +260,13 @@ (mapc #'safely-delete-package '(#\X #\F #\G #\H)) (let ((p (make-package #\X :nicknames '("F" #\G #:|H|)))) (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "X") - (set-exclusive-or (package-nicknames p) - '("F" "G" "H") - :test #'equal) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (values (notnot (packagep p)) + (equalt (package-name p) "X") + (set-exclusive-or (package-nicknames p) + '("F" "G" "H") + :test #'equal) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t nil t) ;;; Specialized sequences as designators @@ -279,110 +279,110 @@ (assert (string= name "TEST1")) (safely-delete-package "TEST1") (let ((p (ignore-errors (make-package name)))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (multiple-value-prog1 + (values (notnot (packagep p)) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t t t)) (def-make-package-test1 make-package.14 (make-array 5 :initial-contents "TEST1" - :element-type 'base-char)) + :element-type 'base-char)) (def-make-package-test1 make-package.15 (make-array 12 :initial-contents "TEST1xxxyyyz" - :fill-pointer 5 - :element-type 'base-char)) + :fill-pointer 5 + :element-type 'base-char)) (def-make-package-test1 make-package.16 (make-array 12 :initial-contents "TEST1xxxyyyz" - :fill-pointer 5 - :element-type 'character)) + :fill-pointer 5 + :element-type 'character)) (def-make-package-test1 make-package.17 (make-array 5 :initial-contents "TEST1" - :adjustable t - :element-type 'base-char)) + :adjustable t + :element-type 'base-char)) (def-make-package-test1 make-package.18 (make-array 5 :initial-contents "TEST1" - :adjustable t - :element-type 'character)) + :adjustable t + :element-type 'character)) (def-make-package-test1 make-package.19 (let* ((etype 'base-char) - (name0 (make-array 10 :initial-contents "xxTEST1yyy" - :element-type etype))) + (name0 (make-array 10 :initial-contents "xxTEST1yyy" + :element-type etype))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 2))) + :displaced-to name0 + :displaced-index-offset 2))) (def-make-package-test1 make-package.20 (let* ((etype 'character) - (name0 (make-array 10 :initial-contents "xxTEST1yyy" - :element-type etype))) + (name0 (make-array 10 :initial-contents "xxTEST1yyy" + :element-type etype))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 2))) + :displaced-to name0 + :displaced-index-offset 2))) ;;; Nicknames being specialized sequences (defmacro def-make-package-test2 (test-name name-form) `(deftest ,test-name (let ((name ,name-form) - (nickname "TEST1-NICKNAME")) + (nickname "TEST1-NICKNAME")) (safely-delete-package "TEST1") (safely-delete-package nickname) (let ((p (make-package name :nicknames (list nickname)))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) (list nickname)) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (multiple-value-prog1 + (values (notnot (packagep p)) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) (list nickname)) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t t t)) (def-make-package-test2 make-package.21 (make-array 5 :initial-contents "TEST1" - :element-type 'base-char)) + :element-type 'base-char)) (def-make-package-test2 make-package.22 (make-array 12 :initial-contents "TEST1xxxyyyz" - :fill-pointer 5 - :element-type 'base-char)) + :fill-pointer 5 + :element-type 'base-char)) (def-make-package-test2 make-package.23 (make-array 12 :initial-contents "TEST1xxxyyyz" - :fill-pointer 5 - :element-type 'character)) + :fill-pointer 5 + :element-type 'character)) (def-make-package-test2 make-package.24 (make-array 5 :initial-contents "TEST1" - :adjustable t - :element-type 'base-char)) + :adjustable t + :element-type 'base-char)) (def-make-package-test2 make-package.25 (make-array 5 :initial-contents "TEST1" - :adjustable t - :element-type 'character)) + :adjustable t + :element-type 'character)) (def-make-package-test2 make-package.26 (let* ((etype 'base-char) - (name0 (make-array 10 :initial-contents "xxTEST1yyy" - :element-type etype))) + (name0 (make-array 10 :initial-contents "xxTEST1yyy" + :element-type etype))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 2))) + :displaced-to name0 + :displaced-index-offset 2))) (def-make-package-test2 make-package.27 (let* ((etype 'character) - (name0 (make-array 10 :initial-contents "xxTEST1yyy" - :element-type etype))) + (name0 (make-array 10 :initial-contents "xxTEST1yyy" + :element-type etype))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 2))) + :displaced-to name0 + :displaced-index-offset 2))) ;;; USE names being specialized sequences @@ -393,13 +393,13 @@ (safely-delete-package "TEST1") (assert (find-package name)) (let ((p (ignore-errors (make-package "TEST1" :use (list name))))) - (multiple-value-prog1 - (values (notnot (packagep p)) - (equalt (package-name p) "TEST1") - (equalt (package-nicknames p) nil) - (equalt (package-use-list p) (list (find-package name))) - (equalt (package-used-by-list p) nil)) - (safely-delete-package p)))) + (multiple-value-prog1 + (values (notnot (packagep p)) + (equalt (package-name p) "TEST1") + (equalt (package-nicknames p) nil) + (equalt (package-use-list p) (list (find-package name))) + (equalt (package-used-by-list p) nil)) + (safely-delete-package p)))) t t t t t)) (def-make-package-test3 make-package.28 @@ -407,39 +407,39 @@ (def-make-package-test3 make-package.29 (make-array 8 :initial-contents "Axxxyyyz" - :fill-pointer 1 - :element-type 'base-char)) + :fill-pointer 1 + :element-type 'base-char)) (def-make-package-test3 make-package.30 (make-array 8 :initial-contents "Axxxyyyz" - :fill-pointer 1 - :element-type 'character)) + :fill-pointer 1 + :element-type 'character)) (def-make-package-test3 make-package.31 (make-array 1 :initial-contents "A" - :adjustable t - :element-type 'base-char)) + :adjustable t + :element-type 'base-char)) (def-make-package-test3 make-package.32 (make-array 1 :initial-contents "A" - :adjustable t - :element-type 'character)) + :adjustable t + :element-type 'character)) (def-make-package-test3 make-package.33 (let* ((etype 'base-char) - (name0 (make-array 10 :initial-contents "xxAyyy0123" - :element-type etype))) + (name0 (make-array 10 :initial-contents "xxAyyy0123" + :element-type etype))) (make-array 1 :element-type etype - :displaced-to name0 - :displaced-index-offset 2))) + :displaced-to name0 + :displaced-index-offset 2))) (def-make-package-test3 make-package.34 (let* ((etype 'character) - (name0 (make-array 10 :initial-contents "xxAzzzzyyy" - :element-type etype))) + (name0 (make-array 10 :initial-contents "xxAzzzzyyy" + :element-type etype))) (make-array 1 :element-type etype - :displaced-to name0 - :displaced-index-offset 2))) + :displaced-to name0 + :displaced-index-offset 2))) ;; Signal a continuable error if the package or any nicknames ;; exist as packages or nicknames of packages @@ -448,7 +448,7 @@ (progn (set-up-packages) (handle-non-abort-restart (make-package "A"))) - success) + success) (deftest make-package.error.2 (progn @@ -509,5 +509,5 @@ (progn (safely-delete-package "MPE11") (signals-error (make-package "MPE11" 'bad t :allow-other-keys nil) - program-error)) + program-error)) t) diff --git a/ansi-tests/make-pathname.lsp b/ansi-tests/make-pathname.lsp index 25058e1b..1e6c7057 100644 --- a/ansi-tests/make-pathname.lsp +++ b/ansi-tests/make-pathname.lsp @@ -10,39 +10,39 @@ (defun make-pathname-test (&rest args &key (defaults nil) - (host (if defaults (pathname-host defaults) - (pathname-host *default-pathname-defaults*))) - (device (if defaults (pathname-device defaults) - (pathname-device *null-pathname*))) - (directory (if defaults (pathname-directory defaults) - (pathname-directory *null-pathname*))) - (name (if defaults (pathname-name defaults) - (pathname-name *null-pathname*))) - (type (if defaults (pathname-type defaults) - (pathname-type *null-pathname*))) - (version (if defaults (pathname-version defaults) - (pathname-version *null-pathname*))) - case) + (host (if defaults (pathname-host defaults) + (pathname-host *default-pathname-defaults*))) + (device (if defaults (pathname-device defaults) + (pathname-device *null-pathname*))) + (directory (if defaults (pathname-directory defaults) + (pathname-directory *null-pathname*))) + (name (if defaults (pathname-name defaults) + (pathname-name *null-pathname*))) + (type (if defaults (pathname-type defaults) + (pathname-type *null-pathname*))) + (version (if defaults (pathname-version defaults) + (pathname-version *null-pathname*))) + case) (declare (ignorable case)) (let* ((vals (multiple-value-list (apply #'make-pathname args))) - (pn (first vals))) + (pn (first vals))) (and (= (length vals) 1) - (typep pn 'pathname) - (equalp (pathname-host pn) host) - (equalp (pathname-device pn) device) - ;; (equalp (pathname-directory pn) directory) - (let ((pnd (pathname-directory pn))) - (if (eq directory :wild) - (member pnd '((:absolute :wild-inferiors) - (:absolute :wild)) - :test #'equal) - (equalp pnd directory))) - (equalp (pathname-name pn) name) - (equalp (pathname-type pn) type) - (equalp (pathname-version pn) version) - t))) - - + (typep pn 'pathname) + (equalp (pathname-host pn) host) + (equalp (pathname-device pn) device) + ;; (equalp (pathname-directory pn) directory) + (let ((pnd (pathname-directory pn))) + (if (eq directory :wild) + (member pnd '((:absolute :wild-inferiors) + (:absolute :wild)) + :test #'equal) + (equalp pnd directory))) + (equalp (pathname-name pn) name) + (equalp (pathname-type pn) type) + (equalp (pathname-version pn) version) + t))) + + (deftest make-pathname.1 (make-pathname-test) @@ -110,40 +110,40 @@ (deftest make-pathname.14 (let ((*default-pathname-defaults* - (make-pathname :name "foo" :type "lsp" :version :newest))) + (make-pathname :name "foo" :type "lsp" :version :newest))) (make-pathname-test)) t) ;;; Works on the components of actual pathnames (deftest make-pathname.rebuild (loop for p in *pathnames* - for host = (pathname-host p) - for device = (pathname-device p) - for directory = (pathname-directory p) - for name = (pathname-name p) - for type = (pathname-type p) - for version = (pathname-version p) - for p2 = (make-pathname - :host host - :device device - :directory directory - :name name - :type type - :version version) - unless (equal p p2) - collect (list p p2)) + for host = (pathname-host p) + for device = (pathname-device p) + for directory = (pathname-directory p) + for name = (pathname-name p) + for type = (pathname-type p) + for version = (pathname-version p) + for p2 = (make-pathname + :host host + :device device + :directory directory + :name name + :type type + :version version) + unless (equal p p2) + collect (list p p2)) nil) ;;; Various constraints on :directory (deftest make-pathname-error-absolute-up (signals-error (directory (make-pathname :directory '(:absolute :up))) - file-error) + file-error) t) (deftest make-pathname-error-absolute-back (signals-error (directory (make-pathname :directory '(:absolute :back))) - file-error) + file-error) t) ;; The next test is correct, but was causing very large amounts of time to be spent @@ -151,21 +151,21 @@ #| (deftest make-pathname-error-absolute-wild-inferiors-up (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :up))) - file-error) + file-error) t) |# (deftest make-pathname-error-relative-wild-inferiors-up (signals-error (length (directory (make-pathname :directory '(:relative :wild-inferiors :up)))) - file-error) + file-error) t) (deftest make-pathname-error-absolute-wild-inferiors-back (signals-error (directory (make-pathname :directory '(:absolute :wild-inferiors :back))) - file-error) + file-error) t) (deftest make-pathname-error-relative-wild-inferiors-back (signals-error (directory (make-pathname :directory '(:relative :wild-inferiors :back))) - file-error) + file-error) t) diff --git a/ansi-tests/make-random-element-of.lsp b/ansi-tests/make-random-element-of.lsp index 8932fae4..dcbea8a9 100644 --- a/ansi-tests/make-random-element-of.lsp +++ b/ansi-tests/make-random-element-of.lsp @@ -35,13 +35,13 @@ (defmethod make-random-element-of ((type (eql rational))) (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) - (n (random r)) - (d (loop for x = (random r) unless (zerop x) do (return x)))) + (n (random r)) + (d (loop for x = (random r) unless (zerop x) do (return x)))) (if (coin) (/ n d) (- (/ n d))))) (defmethod make-random-element-of ((type (eql integer))) (let* ((b (random *maximum-random-int-bits*)) - (x (ash 1 b))) + (x (ash 1 b))) (rcase (1 (+ x (make-random-element-of 'integer))) (1 (- (make-random-element-of 'integer) x)) @@ -68,7 +68,7 @@ (defmethod make-random-element-of ((type (eql ratio))) (loop for x = (make-random-element-of 'rational) - unless (integerp x) return x)) + unless (integerp x) return x)) (defmethod make-random-element-of ((type complex)) (make-random-element-of '(complex real))) @@ -78,7 +78,7 @@ (defmethod make-random-element-of ((type bignum)) (make-random-element-of `(or (integer * (,most-negative-fixnum)) - (integer (,most-positive-fixnum))))) + (integer (,most-positive-fixnum))))) (defmethod make-random-element-of ((type (eql number))) (make-random-element-of (random-from-seq #(integer rational float complex)))) @@ -87,11 +87,11 @@ (rcase (3 (random-from-seq +standard-chars+)) (2 (let ((r (random 256))) - (or (code-char r) (make-random-element-of 'character)))) + (or (code-char r) (make-random-element-of 'character)))) (1 (let ((r (random #.(ash 1 16)))) - (or (code-char r) (make-random-element-of 'character)))) + (or (code-char r) (make-random-element-of 'character)))) (1 (let ((r (random #.(ash 1 24)))) - (or (code-char r) (make-random-element-of 'character)))))) + (or (code-char r) (make-random-element-of 'character)))))) (defmethod make-random-element-of ((type 'base-char)) (random-from-seq +standard-chars+)) @@ -169,37 +169,37 @@ (defmethod make-random-element-of-compound-type ((type-op (eql and)) (args cons)) (loop for e = (make-random-element-of (car args)) - repeat 100 - when (or (null (cdr args)) (typep e (cons 'and (cdr args)))) - return x - finally (error "Cannot generate a random element of ~A" - (cons 'and args)))) + repeat 100 + when (or (null (cdr args)) (typep e (cons 'and (cdr args)))) + return x + finally (error "Cannot generate a random element of ~A" + (cons 'and args)))) (defmethod make-random-element-of-compound-type ((type-op (eql integer)) (args t)) (let ((lo (let ((lo (car args))) - (cond - ((consp lo) (1+ (car lo))) - ((eq lo nil) '*) - (t lo)))) - (hi (let ((hi (cadr args))) - (cond - ((consp hi) (1- (car hi))) - ((eq hi nil) '*) - (t hi))))) + (cond + ((consp lo) (1+ (car lo))) + ((eq lo nil) '*) + (t lo)))) + (hi (let ((hi (cadr args))) + (cond + ((consp hi) (1- (car hi))) + ((eq hi nil) '*) + (t hi))))) (if (eq lo '*) - (if (eq hi '*) - (let ((x (ash 1 (random *maximum-random-int-bits*)))) - (random-from-interval x (- x))) - (random-from-interval (1+ hi) - (- hi (random (ash 1 *maximum-random-int-bits*))))) - + (if (eq hi '*) + (let ((x (ash 1 (random *maximum-random-int-bits*)))) + (random-from-interval x (- x))) + (random-from-interval (1+ hi) + (- hi (random (ash 1 *maximum-random-int-bits*))))) + (if (eq hi '*) - (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) - lo) - ;; May generalize the next case to increase odds - ;; of certain integers (near 0, near endpoints, near - ;; powers of 2...) - (random-from-interval (1+ hi) lo))))) + (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) + lo) + ;; May generalize the next case to increase odds + ;; of certain integers (near 0, near endpoints, near + ;; powers of 2...) + (random-from-interval (1+ hi) lo))))) (defmethod make-random-element-of-compound-type ((type-op (eql short-float)) (args t)) (make-random-element-of-float-type type args)) @@ -215,8 +215,8 @@ (defun make-random-element-of-float-type (type-op args) (let ((lo (car args)) - (hi (cadr args)) - lo= hi=) + (hi (cadr args)) + lo= hi=) (cond ((consp lo) nil) ((member lo '(* nil)) @@ -238,14 +238,14 @@ (let ((limit 100000)) (cond ((or (<= hi 0) - (>= lo 0) - (and (<= (- limit) hi limit) (<= (- limit) lo limit))) - (loop for x = (+ (random (- hi lo)) lo) - do (when (or lo= (/= x lo)) (return x)))) + (>= lo 0) + (and (<= (- limit) hi limit) (<= (- limit) lo limit))) + (loop for x = (+ (random (- hi lo)) lo) + do (when (or lo= (/= x lo)) (return x)))) (t - (rcase - (1 (random (min hi (float limit hi)))) - (1 (- (random (min (float limit lo) (- lo))))))))))) + (rcase + (1 (random (min hi (float limit hi)))) + (1 (- (random (min (float limit lo) (- lo))))))))))) (defmethod make-random-element-of-compound-type ((type-op (eql mod)) (args cons)) (let ((modulus (car args))) @@ -258,10 +258,10 @@ (make-random-element-of '(integer 0 *)) (let ((bits (car args))) (if (eq bits'*) - (make-random-element-of '(integer 0 *)) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of `(integer 0 ,(1- (ash 1 bits))))))))) + (make-random-element-of '(integer 0 *)) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of `(integer 0 ,(1- (ash 1 bits))))))))) (defmethod make-random-element-of-compound-type ((type-op (eql eql)) (args cons)) (assert (null (cdr args))) diff --git a/ansi-tests/make-random-state.lsp b/ansi-tests/make-random-state.lsp index 02602d69..02b1b03a 100644 --- a/ansi-tests/make-random-state.lsp +++ b/ansi-tests/make-random-state.lsp @@ -28,15 +28,15 @@ (deftest make-random-state.1 (let ((rs (make-random-state))) (and (not (eq rs *random-state*)) - (random-state-p rs) - (eqlt (random 1000000) (random 1000000 rs)))) + (random-state-p rs) + (eqlt (random 1000000) (random 1000000 rs)))) t) (deftest make-random-state.2 (let ((rs (make-random-state *random-state*))) (and (not (eq rs *random-state*)) - (random-state-p rs) - (eqlt (random 1000000) (random 1000000 rs)))) + (random-state-p rs) + (eqlt (random 1000000) (random 1000000 rs)))) t) (deftest make-random-state.3 @@ -44,24 +44,24 @@ (random 10) (let ((rs2 (make-random-state rs))) (and (not (eq rs *random-state*)) - (not (eq rs rs2)) - (not (eq rs2 *random-state*)) - (random-state-p rs) - (random-state-p rs2) - (eqlt (random 1.0 rs) (random 1.0 rs2))))) + (not (eq rs rs2)) + (not (eq rs2 *random-state*)) + (random-state-p rs) + (random-state-p rs2) + (eqlt (random 1.0 rs) (random 1.0 rs2))))) t) (deftest make-random-state.4 (let ((rs (make-random-state t)) - (rs2 (make-random-state t))) + (rs2 (make-random-state t))) (and (random-state-p rs) - (not (eq rs *random-state*)) - (random-state-p rs2) - (not (eq rs2 *random-state*)) - (not (eq rs rs2)) - (integerp (random 10 rs)) - (floatp (random 1.0 rs2)) - t)) + (not (eq rs *random-state*)) + (random-state-p rs2) + (not (eq rs2 *random-state*)) + (not (eq rs rs2)) + (integerp (random 10 rs)) + (floatp (random 1.0 rs2)) + t)) t) - + diff --git a/ansi-tests/make-sequence.lsp b/ansi-tests/make-sequence.lsp index 7cfb549e..0b59e6ed 100644 --- a/ansi-tests/make-sequence.lsp +++ b/ansi-tests/make-sequence.lsp @@ -8,10 +8,10 @@ (deftest make-sequence.1 (let ((x (make-sequence 'list 4))) (and (eql (length x) 4) - (listp x) - #+:ansi-tests-strict-initial-element - (loop for e in x always (eql (car x) e)) - t)) + (listp x) + #+:ansi-tests-strict-initial-element + (loop for e in x always (eql (car x) e)) + t)) t) (deftest make-sequence.2 @@ -21,10 +21,10 @@ (deftest make-sequence.3 (let ((x (make-sequence 'cons 4))) (and (eql (length x) 4) - (listp x) - #+:ansi-tests-strict-initial-element - (loop for e in x always (eql (car x) e)) - t)) + (listp x) + #+:ansi-tests-strict-initial-element + (loop for e in x always (eql (car x) e)) + t)) t) (deftest make-sequence.4 @@ -38,9 +38,9 @@ (deftest make-sequence.6 (let ((s (make-sequence 'string 10))) (and (eql (length s) 10) - #+:ansi-tests-strict-initial-element - (loop for e across s always (eql e (aref s 0))) - t)) + #+:ansi-tests-strict-initial-element + (loop for e across s always (eql e (aref s 0))) + t)) t) (deftest make-sequence.7 @@ -51,9 +51,9 @@ (deftest make-sequence.8 (let ((s (make-sequence 'simple-string 10))) (and (eql (length s) 10) - #+:ansi-tests-strict-initial-element - (loop for e across s always (eql e (aref s 0))) - t)) + #+:ansi-tests-strict-initial-element + (loop for e across s always (eql e (aref s 0))) + t)) t) (deftest make-sequence.9 @@ -63,97 +63,97 @@ (deftest make-sequence.10 (let ((x (make-sequence 'vector 10))) (and (eql (length x) 10) - #+:ansi-tests-strict-initial-element - (loop for e across x always (eql e (aref x 0))) - t)) + #+:ansi-tests-strict-initial-element + (loop for e across x always (eql e (aref x 0))) + t)) t) (deftest make-sequence.11 (let* ((u (list 'a)) - (x (make-sequence 'vector 10 :initial-element u))) + (x (make-sequence 'vector 10 :initial-element u))) (and (eql (length x) 10) - (loop for e across x always (eql e u)) - t)) + (loop for e across x always (eql e u)) + t)) t) (deftest make-sequence.12 (let ((x (make-sequence 'simple-vector 10))) (and (eql (length x) 10) - #+:ansi-tests-strict-initial-element - (loop for e across x always (eql e (aref x 0))) - t)) + #+:ansi-tests-strict-initial-element + (loop for e across x always (eql e (aref x 0))) + t)) t) (deftest make-sequence.13 (let* ((u (list 'a)) - (x (make-sequence 'simple-vector 10 :initial-element u))) + (x (make-sequence 'simple-vector 10 :initial-element u))) (and (eql (length x) 10) - (loop for e across x always (eql e u)) - t)) + (loop for e across x always (eql e u)) + t)) t) (deftest make-sequence.14 (let ((x (make-sequence '(vector *) 10))) (and (eql (length x) 10) - #+:ansi-tests-strict-initial-element - (loop for e across x always (eql e (aref x 0))) - t)) + #+:ansi-tests-strict-initial-element + (loop for e across x always (eql e (aref x 0))) + t)) t) (deftest make-sequence.15 (let* ((u (list 'a)) - (x (make-sequence '(vector *) 10 :initial-element u))) + (x (make-sequence '(vector *) 10 :initial-element u))) (and (eql (length x) 10) - (loop for e across x always (eql e u)) - t)) + (loop for e across x always (eql e u)) + t)) t) (deftest make-sequence.16 (let ((x (make-sequence '(simple-vector *) 10))) (and (eql (length x) 10) - #+:ansi-tests-strict-initial-element - (loop for e across x always (eql e (aref x 0))) - t)) + #+:ansi-tests-strict-initial-element + (loop for e across x always (eql e (aref x 0))) + t)) t) (deftest make-sequence.17 (let* ((u (list 'a)) - (x (make-sequence '(simple-vector *) 10 :initial-element u))) + (x (make-sequence '(simple-vector *) 10 :initial-element u))) (and (eql (length x) 10) - (loop for e across x always (eql e u)) - t)) + (loop for e across x always (eql e u)) + t)) t) (deftest make-sequence.18 (let ((x (make-sequence '(string *) 10))) (and (eql (length x) 10) - #+:ansi-tests-strict-initial-element - (loop for e across x always (eql e (aref x 0))) - t)) + #+:ansi-tests-strict-initial-element + (loop for e across x always (eql e (aref x 0))) + t)) t) (deftest make-sequence.19 (let* ((u #\a) - (x (make-sequence '(string *) 10 :initial-element u))) + (x (make-sequence '(string *) 10 :initial-element u))) (and (eql (length x) 10) - (loop for e across x always (eql e u)) - t)) + (loop for e across x always (eql e u)) + t)) t) (deftest make-sequence.20 (let ((x (make-sequence '(simple-string *) 10))) (and (eql (length x) 10) - #+:ansi-tests-strict-initial-element - (loop for e across x always (eql e (aref x 0))) - t)) + #+:ansi-tests-strict-initial-element + (loop for e across x always (eql e (aref x 0))) + t)) t) (deftest make-sequence.21 (let* ((u #\a) - (x (make-sequence '(simple-string *) 10 :initial-element u))) + (x (make-sequence '(simple-string *) 10 :initial-element u))) (and (eql (length x) 10) - (loop for e across x always (eql e u)) - t)) + (loop for e across x always (eql e u)) + t)) t) (deftest make-sequence.22 @@ -180,47 +180,47 @@ (deftest make-sequence.27 (let ((len 10)) (loop for i from 1 to 40 - for etype = `(unsigned-byte ,i) - for type = `(vector ,etype) - for vec = (make-sequence type len :initial-element 0) - unless (and (typep vec type) - (loop for i below len always (eql (elt vec i) 0))) - collect (list i etype type vec))) + for etype = `(unsigned-byte ,i) + for type = `(vector ,etype) + for vec = (make-sequence type len :initial-element 0) + unless (and (typep vec type) + (loop for i below len always (eql (elt vec i) 0))) + collect (list i etype type vec))) nil) (deftest make-sequence.28 (let ((len 10)) (loop for i from 1 to 40 - for etype = `(signed-byte ,i) - for type = `(vector ,etype) - for vec = (make-sequence type len :initial-element 0) - unless (and (typep vec type) - (loop for i below len always (eql (elt vec i) 0))) - collect (list i etype type vec))) + for etype = `(signed-byte ,i) + for type = `(vector ,etype) + for vec = (make-sequence type len :initial-element 0) + unless (and (typep vec type) + (loop for i below len always (eql (elt vec i) 0))) + collect (list i etype type vec))) nil) (deftest make-sequence.29 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float) - for type = `(vector ,etype) - for elem = (coerce 1 etype) - for vec = (make-sequence type len :initial-element elem) - unless (and (typep vec type) - (loop for i below len always (eql (elt vec i) elem))) - collect (list etype type vec))) + for type = `(vector ,etype) + for elem = (coerce 1 etype) + for vec = (make-sequence type len :initial-element elem) + unless (and (typep vec type) + (loop for i below len always (eql (elt vec i) elem))) + collect (list etype type vec))) nil) (deftest make-sequence.30 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float - integer rational) - for etype = `(complex ,cetype) - for type = `(vector ,etype) - for elem = (complex (coerce 1 cetype) (coerce -1 cetype)) - for vec = (make-sequence type len :initial-element elem) - unless (and (typep vec type) - (loop for i below len always (eql (elt vec i) elem))) - collect (list etype type vec))) + integer rational) + for etype = `(complex ,cetype) + for type = `(vector ,etype) + for elem = (complex (coerce 1 cetype) (coerce -1 cetype)) + for vec = (make-sequence type len :initial-element elem) + unless (and (typep vec type) + (loop for i below len always (eql (elt vec i) elem))) + collect (list etype type vec))) nil) ;;; Other type specifiers @@ -313,64 +313,64 @@ (deftest make-sequence.51 (loop for i from 1 to 40 - for vec = (make-array 1 :element-type `(unsigned-byte ,i) - :initial-element 1) - for class = (class-of vec) - nconc - (if (subtypep class 'vector) - (let ((vec2 (make-sequence class 1 :initial-element 1))) - (unless (equalp vec vec) - (list (list i vec class vec2)))) - nil)) + for vec = (make-array 1 :element-type `(unsigned-byte ,i) + :initial-element 1) + for class = (class-of vec) + nconc + (if (subtypep class 'vector) + (let ((vec2 (make-sequence class 1 :initial-element 1))) + (unless (equalp vec vec) + (list (list i vec class vec2)))) + nil)) nil) (deftest make-sequence.52 (let ((class (class-of "aaaa"))) (if (subtypep class 'vector) - (make-sequence class 4 :initial-element #\a) + (make-sequence class 4 :initial-element #\a) "aaaa")) "aaaa") (deftest make-sequence.53 (let ((class (class-of (make-array 4 :element-type 'base-char - :fill-pointer 4 - :adjustable t - :initial-contents "aaaa")))) + :fill-pointer 4 + :adjustable t + :initial-contents "aaaa")))) (if (subtypep class 'vector) - (make-sequence class 4 :initial-element #\a) + (make-sequence class 4 :initial-element #\a) "aaaa")) "aaaa") (deftest make-sequence.54 (let ((class (class-of (make-array 4 :element-type 'character - :fill-pointer 4 - :adjustable t - :initial-contents "aaaa")))) + :fill-pointer 4 + :adjustable t + :initial-contents "aaaa")))) (if (subtypep class 'vector) - (make-sequence class 4 :initial-element #\a) + (make-sequence class 4 :initial-element #\a) "aaaa")) "aaaa") (deftest make-sequence.55 (let ((class (class-of (make-array 4 :element-type 'character - :initial-contents "aaaa")))) + :initial-contents "aaaa")))) (if (subtypep class 'vector) - (make-sequence class 4 :initial-element #\a) + (make-sequence class 4 :initial-element #\a) "aaaa")) "aaaa") (deftest make-sequence.56 (loop for i from 1 to 40 - for vec = (make-array 1 :element-type `(unsigned-byte ,i) - :adjustable t :fill-pointer 1 - :initial-element 1) - for class = (class-of vec) - nconc - (if (subtypep class 'vector) - (let ((vec2 (make-sequence class 1 :initial-element 1))) - (unless (equalp vec vec) - (list (list i vec class vec2)))) - nil)) + for vec = (make-array 1 :element-type `(unsigned-byte ,i) + :adjustable t :fill-pointer 1 + :initial-element 1) + for class = (class-of vec) + nconc + (if (subtypep class 'vector) + (let ((vec2 (make-sequence class 1 :initial-element 1))) + (unless (equalp vec vec) + (list (list i vec class vec2)))) + nil)) nil) (deftest make-sequence.57 @@ -401,7 +401,7 @@ (deftest make-sequence.allow-other-keys.5 (make-sequence 'list 5 :initial-element 'a :allow-other-keys t - :allow-other-keys nil :bad t) + :allow-other-keys nil :bad t) (a a a a a)) (deftest make-sequence.keywords.6 @@ -452,12 +452,12 @@ (deftest make-sequence.error.11 (signals-error (make-sequence 'list 10 :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest make-sequence.error.12 (signals-error (make-sequence 'list 10 :initial-element) - program-error) + program-error) t) (deftest make-sequence.error.13 @@ -466,7 +466,7 @@ (deftest make-sequence.error.14 (signals-error-always (locally (make-sequence 'symbol 10) t) - type-error) + type-error) t t) (deftest make-sequence.error.15 @@ -478,7 +478,7 @@ (deftest make-sequence.error.16 (signals-error-always (make-sequence (find-class 'integer) 0) type-error) - t t) + t t) ;;; Order of execution tests @@ -486,8 +486,8 @@ (let ((i 0) a b c) (values (make-sequence (progn (setf a (incf i)) 'list) - (progn (setf b (incf i)) 5) - :initial-element (progn (setf c (incf i)) 'a)) + (progn (setf b (incf i)) 5) + :initial-element (progn (setf c (incf i)) 'a)) i a b c)) (a a a a a) 3 1 2 3) @@ -495,10 +495,10 @@ (let ((i 0) a b c d e) (values (make-sequence (progn (setf a (incf i)) 'list) - (progn (setf b (incf i)) 5) - :allow-other-keys (setf c (incf i)) - :initial-element (progn (setf d (incf i)) 'a) - :foo (setf e (incf i))) + (progn (setf b (incf i)) 5) + :allow-other-keys (setf c (incf i)) + :initial-element (progn (setf d (incf i)) 'a) + :foo (setf e (incf i))) i a b c d e)) (a a a a a) 5 1 2 3 4 5) diff --git a/ansi-tests/make-string-input-stream.lsp b/ansi-tests/make-string-input-stream.lsp index b56b8b1f..63ca250d 100644 --- a/ansi-tests/make-string-input-stream.lsp +++ b/ansi-tests/make-string-input-stream.lsp @@ -42,35 +42,35 @@ (deftest make-string-input-stream.6 (let ((str1 (make-array 6 :element-type 'character - :initial-contents "abcdef" - :fill-pointer 4))) + :initial-contents "abcdef" + :fill-pointer 4))) (let ((s (make-string-input-stream str1))) (values (read-line s) (read-char s nil :eof)))) "abcd" :eof) (deftest make-string-input-stream.7 (let* ((str1 (make-array 6 :element-type 'character - :initial-contents "abcdef")) - (str2 (make-array 4 :element-type 'character - :displaced-to str1))) + :initial-contents "abcdef")) + (str2 (make-array 4 :element-type 'character + :displaced-to str1))) (let ((s (make-string-input-stream str2))) (values (read-line s) (read-char s nil :eof)))) "abcd" :eof) (deftest make-string-input-stream.8 (let* ((str1 (make-array 6 :element-type 'character - :initial-contents "abcdef")) - (str2 (make-array 4 :element-type 'character - :displaced-to str1 - :displaced-index-offset 1))) + :initial-contents "abcdef")) + (str2 (make-array 4 :element-type 'character + :displaced-to str1 + :displaced-index-offset 1))) (let ((s (make-string-input-stream str2))) (values (read-line s) (read-char s nil :eof)))) "bcde" :eof) (deftest make-string-input-stream.9 (let ((str1 (make-array 6 :element-type 'character - :initial-contents "abcdef" - :adjustable t))) + :initial-contents "abcdef" + :adjustable t))) (let ((s (make-string-input-stream str1))) (values (read-line s) (read-char s nil :eof)))) "abcdef" :eof) @@ -78,7 +78,7 @@ (deftest make-string-input-stream.10 :notes (:allow-nil-arrays :nil-vectors-are-strings) (let ((s (make-string-input-stream - (make-array 0 :element-type nil)))) + (make-array 0 :element-type nil)))) (read-char s nil :eof)) :eof) diff --git a/ansi-tests/make-string-output-stream.lsp b/ansi-tests/make-string-output-stream.lsp index 9b3e7fd6..42c56644 100644 --- a/ansi-tests/make-string-output-stream.lsp +++ b/ansi-tests/make-string-output-stream.lsp @@ -68,8 +68,8 @@ (deftest make-string-output-stream.7 (let ((s (make-string-output-stream :foo 'bar :allow-other-keys t - :allow-other-keys nil - :foo2 'x))) + :allow-other-keys nil + :foo2 'x))) (values (notnot (typep s 'stream)) (notnot (typep s 'string-stream)) @@ -130,8 +130,8 @@ (deftest make-string-output-stream.error.3 (signals-error (make-string-output-stream :allow-other-keys nil - :foo 'bar) - program-error) + :foo 'bar) + program-error) t) diff --git a/ansi-tests/make-string.lsp b/ansi-tests/make-string.lsp index d47f487c..074a6a24 100644 --- a/ansi-tests/make-string.lsp +++ b/ansi-tests/make-string.lsp @@ -8,41 +8,41 @@ (deftest make-string.1 (let ((s (make-string 10))) (and (stringp s) - #+:ansi-tests-strict-initial-element - (string-all-the-same s) - (eqlt (length s) 10) - )) + #+:ansi-tests-strict-initial-element + (string-all-the-same s) + (eqlt (length s) 10) + )) t) (deftest make-string.2 (let ((s (make-string 10 :initial-element #\a))) (and (stringp s) - (eql (length s) 10) - s)) + (eql (length s) 10) + s)) "aaaaaaaaaa") (deftest make-string.3 (let ((s (make-string 10 :initial-element #\a - :element-type 'character))) + :element-type 'character))) (and (stringp s) - (eql (length s) 10) - s)) + (eql (length s) 10) + s)) "aaaaaaaaaa") (deftest make-string.4 (let ((s (make-string 10 :initial-element #\a - :element-type 'standard-char))) + :element-type 'standard-char))) (and (stringp s) - (eql (length s) 10) - s)) + (eql (length s) 10) + s)) "aaaaaaaaaa") (deftest make-string.5 (let ((s (make-string 10 :initial-element #\a - :element-type 'base-char))) + :element-type 'base-char))) (and (stringp s) - (eql (length s) 10) - s)) + (eql (length s) 10) + s)) "aaaaaaaaaa") (deftest make-string.6 @@ -52,28 +52,28 @@ (deftest make-string.7 (let ((s (make-string 10 :element-type 'character))) (and (stringp s) - (eqlt (length s) 10) - #+:ansi-tests-strict-initial-element - (string-all-the-same s) - )) + (eqlt (length s) 10) + #+:ansi-tests-strict-initial-element + (string-all-the-same s) + )) t) (deftest make-string.8 (let ((s (make-string 10 :element-type 'standard-char))) (and (stringp s) - (eqlt (length s) 10) - #+:ansi-tests-strict-initial-element - (string-all-the-same s) - )) + (eqlt (length s) 10) + #+:ansi-tests-strict-initial-element + (string-all-the-same s) + )) t) (deftest make-string.9 (let ((s (make-string 10 :element-type 'base-char))) (and (stringp s) - (eqlt (length s) 10) - #+:ansi-tests-strict-initial-element - (string-all-the-same s) - )) + (eqlt (length s) 10) + #+:ansi-tests-strict-initial-element + (string-all-the-same s) + )) t) (deftest make-string.10 @@ -99,22 +99,22 @@ (deftest make-string.allow-other-keys.3 (make-string 5 :initial-element #\a :allow-other-keys t - :bad t) + :bad t) "aaaaa") (deftest make-string.allow-other-keys.4 (make-string 5 :bad t :allow-other-keys t :allow-other-keys nil - :initial-element #\a) + :initial-element #\a) "aaaaa") (deftest make-string.allow-other-keys.5 (make-string 5 :allow-other-keys t :bad t :allow-other-keys nil - :initial-element #\a) + :initial-element #\a) "aaaaa") (deftest make-string.allow-other-keys.6 (make-string 5 :allow-other-keys t :allow-other-keys nil :bad nil - :initial-element #\a) + :initial-element #\a) "aaaaa") (deftest make-string.keywords.7 @@ -133,7 +133,7 @@ (deftest make-string.error.3 (signals-error (make-string 10 :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest make-string.error.4 @@ -154,7 +154,7 @@ (let ((i 0) a b) (values (make-string (progn (setf a (incf i)) 4) - :initial-element (progn (setf b (incf i)) #\a)) + :initial-element (progn (setf b (incf i)) #\a)) i a b)) "aaaa" 2 1 2) @@ -162,8 +162,8 @@ (let ((i 0) a b c) (values (make-string (progn (setf a (incf i)) 4) - :initial-element (progn (setf b (incf i)) #\a) - :element-type (progn (setf c (incf i)) 'base-char)) + :initial-element (progn (setf b (incf i)) #\a) + :element-type (progn (setf c (incf i)) 'base-char)) i a b c)) "aaaa" 3 1 2 3) @@ -171,8 +171,8 @@ (let ((i 0) a b c) (values (make-string (progn (setf a (incf i)) 4) - :element-type (progn (setf b (incf i)) 'base-char) - :initial-element (progn (setf c (incf i)) #\a)) + :element-type (progn (setf b (incf i)) 'base-char) + :initial-element (progn (setf c (incf i)) #\a)) i a b c)) "aaaa" 3 1 2 3) diff --git a/ansi-tests/make-symbol.lsp b/ansi-tests/make-symbol.lsp index 4a031e65..c06cb26f 100644 --- a/ansi-tests/make-symbol.lsp +++ b/ansi-tests/make-symbol.lsp @@ -27,7 +27,7 @@ (deftest make-symbol.6 (eqt (make-symbol "A") - (make-symbol "A")) + (make-symbol "A")) nil) (deftest make-symbol.7 @@ -53,9 +53,9 @@ (deftest make-symbol.12 (let* ((name (make-array '(4) :initial-contents '(#\A #\B #\C #\D) - :element-type 'base-char)) - (s (make-symbol name)) - (name2 (symbol-name s))) + :element-type 'base-char)) + (s (make-symbol name)) + (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) @@ -63,10 +63,10 @@ (deftest make-symbol.13 (let* ((name (make-array '(6) :initial-contents '(#\A #\B #\C #\D #\E #\F) - :element-type 'character - :fill-pointer 4)) - (s (make-symbol name)) - (name2 (symbol-name s))) + :element-type 'character + :fill-pointer 4)) + (s (make-symbol name)) + (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) @@ -74,10 +74,10 @@ (deftest make-symbol.14 (let* ((name (make-array '(4) :initial-contents '(#\A #\B #\C #\D) - :adjustable t - :element-type 'character)) - (s (make-symbol name)) - (name2 (symbol-name s))) + :adjustable t + :element-type 'character)) + (s (make-symbol name)) + (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) @@ -85,12 +85,12 @@ (deftest make-symbol.15 (let* ((name0 (make-array '(6) :initial-contents '(#\0 #\A #\B #\C #\D #\E) - :element-type 'character)) - (name (make-array '(4) :element-type 'character - :displaced-to name0 - :displaced-index-offset 1)) - (s (make-symbol name)) - (name2 (symbol-name s))) + :element-type 'character)) + (name (make-array '(4) :element-type 'character + :displaced-to name0 + :displaced-index-offset 1)) + (s (make-symbol name)) + (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) @@ -98,12 +98,12 @@ (deftest make-symbol.16 (let* ((name0 (make-array '(6) :initial-contents '(#\0 #\A #\B #\C #\D #\E) - :element-type 'base-char)) - (name (make-array '(4) :element-type 'base-char - :displaced-to name0 - :displaced-index-offset 1)) - (s (make-symbol name)) - (name2 (symbol-name s))) + :element-type 'base-char)) + (name (make-array '(4) :element-type 'base-char + :displaced-to name0 + :displaced-index-offset 1)) + (s (make-symbol name)) + (name2 (symbol-name s))) (values (symbol-package s) (string=t name2 "ABCD"))) diff --git a/ansi-tests/make-two-way-stream.lsp b/ansi-tests/make-two-way-stream.lsp index e1a43d78..53363c6c 100644 --- a/ansi-tests/make-two-way-stream.lsp +++ b/ansi-tests/make-two-way-stream.lsp @@ -7,8 +7,8 @@ (deftest make-two-way-stream.1 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (assert (typep s 'stream)) (assert (typep s 'two-way-stream)) (assert (streamp s)) @@ -28,8 +28,8 @@ (deftest make-two-way-stream.2 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (values (close s) (open-stream-p s) @@ -41,8 +41,8 @@ (deftest make-two-way-stream.3 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (values (peek-char nil s) (read-char s) @@ -51,8 +51,8 @@ (deftest make-two-way-stream.4 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (values (read-char-no-hang s) (read-char-no-hang s nil) @@ -63,8 +63,8 @@ (deftest make-two-way-stream.5 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (values (terpri s) (get-output-stream-string os))) @@ -72,8 +72,8 @@ (deftest make-two-way-stream.6 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (values (write-char #\+ s) (notnot (fresh-line s)) @@ -83,8 +83,8 @@ (deftest make-two-way-stream.7 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (values (read-char s) (unread-char #\f s) @@ -96,8 +96,8 @@ (deftest make-two-way-stream.8 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (values (read-line s) (get-output-stream-string os))) @@ -105,8 +105,8 @@ (deftest make-two-way-stream.9 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (values (write-string "bar" s) (get-output-stream-string os))) @@ -114,8 +114,8 @@ (deftest make-two-way-stream.10 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (values (write-line "bar" s) (get-output-stream-string os))) @@ -123,8 +123,8 @@ (deftest make-two-way-stream.11 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (let ((x (vector nil nil nil))) (values (read-sequence x s) @@ -134,64 +134,64 @@ (deftest make-two-way-stream.12 (let ((pn1 #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 8))) + (pn2 #p"tmp2.dat") + (element-type '(unsigned-byte 8))) (with-open-file (s pn1 :direction :output :if-exists :supersede - :element-type element-type) - (dolist (b '(3 8 19 41)) (write-byte b s))) + :element-type element-type) + (dolist (b '(3 8 19 41)) (write-byte b s))) (with-open-file (is pn1 :direction :input :element-type element-type) (with-open-file (os pn2 :direction :output :element-type element-type - :if-exists :supersede) + :if-exists :supersede) (let ((s (make-two-way-stream is os)) - (x (vector nil nil nil nil))) - (assert (eql (read-sequence x s) 4)) - (assert (equalp x #(3 8 19 41))) - (let ((y #(100 5 18 211 0 178))) - (assert (eql (write-sequence y s) y)) - (close s))))) + (x (vector nil nil nil nil))) + (assert (eql (read-sequence x s) 4)) + (assert (equalp x #(3 8 19 41))) + (let ((y #(100 5 18 211 0 178))) + (assert (eql (write-sequence y s) y)) + (close s))))) (with-open-file (s pn2 :direction :input :element-type element-type) (let ((x (vector nil nil nil nil nil nil nil))) (values - (read-sequence x s) - x)))) + (read-sequence x s) + x)))) 6 #(100 5 18 211 0 178 nil)) (deftest make-two-way-stream.13 (let ((pn1 #p"tmp.dat") - (pn2 #p"tmp2.dat") - (element-type '(unsigned-byte 32))) + (pn2 #p"tmp2.dat") + (element-type '(unsigned-byte 32))) (with-open-file (s pn1 :direction :output :if-exists :supersede - :element-type element-type) - (dolist (b '(3 8 19 41)) (write-byte b s))) + :element-type element-type) + (dolist (b '(3 8 19 41)) (write-byte b s))) (with-open-file (is pn1 :direction :input :element-type element-type) (with-open-file (os pn2 :direction :output :element-type element-type - :if-exists :supersede) + :if-exists :supersede) (let ((s (make-two-way-stream is os)) - (x (vector nil nil nil nil))) - (assert (eql (read-sequence x s) 4)) - (assert (equalp x #(3 8 19 41))) - (let ((y #(100 5 18 211 0 178))) - (assert (eql (write-sequence y s) y)) - (close s))))) + (x (vector nil nil nil nil))) + (assert (eql (read-sequence x s) 4)) + (assert (equalp x #(3 8 19 41))) + (let ((y #(100 5 18 211 0 178))) + (assert (eql (write-sequence y s) y)) + (close s))))) (with-open-file (s pn2 :direction :input :element-type element-type) (let ((x (vector nil nil nil nil nil nil nil))) (values - (read-sequence x s) - x)))) + (read-sequence x s) + x)))) 6 #(100 5 18 211 0 178 nil)) (deftest make-two-way-stream.14 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (values (write-string "abc" s) (clear-input s) @@ -207,38 +207,38 @@ (deftest make-two-way-stream.error.2 (signals-error (make-two-way-stream (make-string-input-stream "foo")) - program-error) + program-error) t) (deftest make-two-way-stream.error.3 (signals-error (let ((os (make-string-output-stream))) - (make-two-way-stream (make-string-input-stream "foo") - os nil)) - program-error) + (make-two-way-stream (make-string-input-stream "foo") + os nil)) + program-error) t) (deftest make-two-way-stream.error.4 (check-type-error #'(lambda (x) (make-two-way-stream x (make-string-output-stream))) - #'(lambda (x) (and (streamp x) (input-stream-p x)))) + #'(lambda (x) (and (streamp x) (input-stream-p x)))) nil) (deftest make-two-way-stream.error.5 (check-type-error #'(lambda (x) (make-two-way-stream x (make-string-output-stream))) - #'(lambda (x) (and (streamp x) (input-stream-p x))) - *streams*) + #'(lambda (x) (and (streamp x) (input-stream-p x))) + *streams*) nil) (deftest make-two-way-stream.error.6 (check-type-error #'(lambda (x) (make-two-way-stream (make-string-input-stream "foo") x)) - #'(lambda (x) (and (streamp x) (output-stream-p x)))) + #'(lambda (x) (and (streamp x) (output-stream-p x)))) nil) (deftest make-two-way-stream.error.7 (check-type-error #'(lambda (x) (make-two-way-stream (make-string-input-stream "foo") x)) - #'(lambda (x) (and (streamp x) (output-stream-p x))) - *streams*) + #'(lambda (x) (and (streamp x) (output-stream-p x))) + *streams*) nil) - \ No newline at end of file + diff --git a/ansi-tests/makunbound.lsp b/ansi-tests/makunbound.lsp index 16aee870..25086429 100644 --- a/ansi-tests/makunbound.lsp +++ b/ansi-tests/makunbound.lsp @@ -25,9 +25,9 @@ (equalt (multiple-value-list (makunbound sym)) (list sym)) (boundp sym) (handler-case (symbol-value sym) - (unbound-variable (c) - (if (eq (cell-error-name c) sym) :good - (list :bad sym (cell-error-name c))))))) + (unbound-variable (c) + (if (eq (cell-error-name c) sym) :good + (list :bad sym (cell-error-name c))))))) nil :foo t nil :good) ;;; Error cases diff --git a/ansi-tests/map-into.lsp b/ansi-tests/map-into.lsp index 5089f03e..5df0ec2c 100644 --- a/ansi-tests/map-into.lsp +++ b/ansi-tests/map-into.lsp @@ -7,7 +7,7 @@ (deftest map-into-list.1 (let ((a (copy-seq '(a b c d e f))) - (b nil)) + (b nil)) (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) (values a b)) (1 2 3 4 5 6) @@ -27,10 +27,10 @@ (deftest map-into-list.4 (let ((a (copy-seq '(a b c d e f))) - (b nil)) + (b nil)) (map-into a #'(lambda (x y) (let ((z (+ x y))) (push z b) z)) - '(1 2 3 4 5 6) - '(10 11 12 13 14 15)) + '(1 2 3 4 5 6) + '(10 11 12 13 14 15)) (values a b)) (11 13 15 17 19 21) (21 19 17 15 13 11)) @@ -45,8 +45,8 @@ (let ((b nil)) (values (map-into nil #'(lambda (x y) (let ((z (+ x y))) (push z b) z)) - '(1 2 3 4 5 6) - '(10 11 12 13 14 15)) + '(1 2 3 4 5 6) + '(10 11 12 13 14 15)) b)) nil nil) @@ -58,15 +58,15 @@ (deftest map-into-list.8 (let ((a (copy-seq '(a b c d e f))) - (s2 (make-array '(6) :initial-element 'x - :fill-pointer 4))) + (s2 (make-array '(6) :initial-element 'x + :fill-pointer 4))) (map-into a #'identity s2) a) (x x x x e f)) (deftest map-into-array.1 (let ((a (copy-seq #(a b c d e f))) - b) + b) (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) (values a b)) #(1 2 3 4 5 6) @@ -74,7 +74,7 @@ (deftest map-into-array.2 (let ((a (copy-seq #(a b c d e f g h))) - b) + b) (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) (values a b)) #(1 2 3 4 5 6 g h) @@ -82,7 +82,7 @@ (deftest map-into-array.3 (let ((a (copy-seq #(a b c d))) - b) + b) (map-into a #'(lambda (x) (push x b) x) '(1 2 3 4 5 6)) (values a b)) #(1 2 3 4) @@ -90,7 +90,7 @@ (deftest map-into-array.4 (let ((a (copy-seq #(a b c d e f))) - b) + b) (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) (values a b)) #(1 2 3 4 5 6) @@ -98,7 +98,7 @@ (deftest map-into-array.5 (let ((a (copy-seq #(a b c d e f g h))) - b) + b) (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) (values a b)) #(1 2 3 4 5 6 g h) @@ -106,7 +106,7 @@ (deftest map-into-array.6 (let ((a (copy-seq #(a b c d))) - b) + b) (map-into a #'(lambda (x) (push x b) x) #(1 2 3 4 5 6)) (values a b)) #(1 2 3 4) @@ -115,38 +115,38 @@ ;;; Tests of mapping into arrays with fill pointers (deftest map-into-array.7 (let ((a (make-array 6 :initial-element 'x - :fill-pointer 3))) + :fill-pointer 3))) (map-into a #'identity '(1 2 3)) a) #(1 2 3)) (deftest map-into-array.8 (let ((a (make-array 6 :initial-element 'x - :fill-pointer 3))) + :fill-pointer 3))) (map-into a #'identity '(1 2)) a) #(1 2)) (deftest map-into-array.9 (let ((a (make-array 6 :initial-element 'x - :fill-pointer 3))) + :fill-pointer 3))) (map-into a #'identity '(1 2 3 4 5)) (and (eqlt (fill-pointer a) 5) - a)) + a)) #(1 2 3 4 5)) (deftest map-into-array.10 (let ((a (make-array 6 :initial-element 'x - :fill-pointer 3))) + :fill-pointer 3))) (map-into a #'(lambda () 'y)) (and (eqlt (fill-pointer a) 6) - a)) + a)) #(y y y y y y)) (deftest map-into-array.11 (let ((a (copy-seq #(a b c d e f))) - (s2 (make-array '(6) :initial-element 'x - :fill-pointer 4))) + (s2 (make-array '(6) :initial-element 'x + :fill-pointer 4))) (map-into a #'identity s2) a) #(x x x x e f)) @@ -176,8 +176,8 @@ (deftest map-into-string.4 (let ((a (make-array 6 :initial-element #\x - :element-type 'character - :fill-pointer 3))) + :element-type 'character + :fill-pointer 3))) (map-into a #'identity "abcde") (values (fill-pointer a) @@ -189,62 +189,62 @@ (deftest map-into-string.5 (let ((a (make-array 6 :initial-element #\x - :element-type 'character - :fill-pointer 3))) + :element-type 'character + :fill-pointer 3))) (map-into a #'(lambda () #\y)) (values (fill-pointer a) - a)) + a)) 6 "yyyyyy") (deftest map-into-string.6 (let ((a (make-array 6 :initial-element #\x - :element-type 'character))) + :element-type 'character))) (map-into a #'(lambda () #\y)) a) "yyyyyy") (deftest map-into-string.7 (let ((a (make-array 6 :initial-element #\x - :element-type 'base-char - :fill-pointer 3))) + :element-type 'base-char + :fill-pointer 3))) (map-into a #'identity "abcde") (values (fill-pointer a) - (aref a 5) - a)) + (aref a 5) + a)) 5 #\x "abcde") (deftest map-into-string.8 (let ((a (make-array 6 :initial-element #\x - :element-type 'base-char - :fill-pointer 3))) + :element-type 'base-char + :fill-pointer 3))) (map-into a #'(lambda () #\y)) (values (fill-pointer a) - a)) + a)) 6 "yyyyyy") (deftest map-into-string.9 (let ((a (make-array 6 :initial-element #\x - :element-type 'base-char))) + :element-type 'base-char))) (map-into a #'(lambda () #\y)) a) "yyyyyy") (deftest map-into-string.10 (let ((a (copy-seq "abcdef")) - (s2 (make-array '(6) :initial-element #\x - :fill-pointer 4))) + (s2 (make-array '(6) :initial-element #\x + :fill-pointer 4))) (map-into a #'identity s2) a) "xxxxef") (deftest map-into-string.11 (let ((a (make-array 6 :initial-element #\x - :element-type 'character - :fill-pointer 3))) + :element-type 'character + :fill-pointer 3))) (map-into a #'identity "abcd") (values (fill-pointer a) @@ -258,8 +258,8 @@ (deftest map-into-string.12 (let ((a (make-array 6 :initial-element #\x - :element-type 'character - :fill-pointer 3))) + :element-type 'character + :fill-pointer 3))) (map-into a #'identity "abcdefgh") (values (fill-pointer a) @@ -279,7 +279,7 @@ (do-special-strings (s "abcde" nil) (let* ((s1 (copy-seq "123456")) - (s2 (map-into s1 #'identity s))) + (s2 (map-into s1 #'identity s))) (assert (eq s1 s2)) (assert (string= s2 "abcde6")))) nil) @@ -290,74 +290,74 @@ (let ((v (copy-seq #*0100110))) (map-into v #'(lambda (x) (- 1 x)) v) (and (bit-vector-p v) - v)) + v)) #*1011001) (deftest map-into.bit-vector.2 (let ((v (copy-seq #*0100110))) (map-into v #'(lambda () 0)) (and (bit-vector-p v) - v)) + v)) #*0000000) (deftest map-into.bit-vector.3 (let ((v (copy-seq #*0100110))) (map-into v #'identity '(0 1 1 1 0 0 1)) (and (bit-vector-p v) - v)) + v)) #*0111001) (deftest map-into.bit-vector.4 (let ((v (copy-seq #*0100110))) (map-into v #'identity '(0 1 1 1)) (and (bit-vector-p v) - v)) + v)) #*0111110) (deftest map-into.bit-vector.5 (let ((v (copy-seq #*0100110))) (map-into v #'identity '(0 1 1 1 0 0 1 4 5 6 7)) (and (bit-vector-p v) - v)) + v)) #*0111001) (deftest map-into.bit-vector.6 (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) - :fill-pointer 4 - :element-type 'bit))) + :fill-pointer 4 + :element-type 'bit))) (map-into v #'(lambda () 1)) (and (bit-vector-p v) - v)) + v)) #*11111111) (deftest map-into.bit-vector.7 (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) - :fill-pointer 4 - :element-type 'bit))) + :fill-pointer 4 + :element-type 'bit))) (map-into v #'identity v) (and (bit-vector-p v) - v)) + v)) #*0100) (deftest map-into.bit-vector.8 (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) - :fill-pointer 4 - :element-type 'bit))) + :fill-pointer 4 + :element-type 'bit))) (map-into v #'identity '(1 1 1 1 1 1)) (and (bit-vector-p v) - (values (fill-pointer v) - v))) + (values (fill-pointer v) + v))) 6 #*111111) (deftest map-into.bit-vector.9 (let ((v (make-array '(8) :initial-contents '(0 1 0 0 1 1 0 1) - :fill-pointer 4 - :element-type 'bit))) + :fill-pointer 4 + :element-type 'bit))) (map-into v #'identity '(1 1 1 1 1 1 0 0 1 1 1)) (and (bit-vector-p v) - (values (fill-pointer v) - v))) + (values (fill-pointer v) + v))) 8 #*11111100) @@ -398,57 +398,57 @@ (deftest map-into.specialized-vector.5 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float) - for vals = (loop for i below len collect (coerce i etype)) - for vec = (make-array len :initial-contents vals :element-type etype) - for target = (loop repeat len collect nil) - for result = (map-into target #'identity vec) - unless (and (eq target result) - (= (length result) len) - (= (length vec) len) - (equal vals result)) - collect (list etype vals vec result))) + for vals = (loop for i below len collect (coerce i etype)) + for vec = (make-array len :initial-contents vals :element-type etype) + for target = (loop repeat len collect nil) + for result = (map-into target #'identity vec) + unless (and (eq target result) + (= (length result) len) + (= (length vec) len) + (equal vals result)) + collect (list etype vals vec result))) nil) (deftest map-into.specialized-vector.6 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float) - for etype = `(complex ,cetype) - for vals = (loop for i from 1 to len collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for vec = (make-array len :initial-contents vals :element-type etype) - for target = (loop repeat len collect nil) - for result = (map-into target #'identity vec) - unless (and (eq target result) - (= (length result) len) - (= (length vec) len) - (equal vals result)) - collect (list etype vals vec result))) + for etype = `(complex ,cetype) + for vals = (loop for i from 1 to len collect (complex (coerce i cetype) + (coerce (- i) cetype))) + for vec = (make-array len :initial-contents vals :element-type etype) + for target = (loop repeat len collect nil) + for result = (map-into target #'identity vec) + unless (and (eq target result) + (= (length result) len) + (= (length vec) len) + (equal vals result)) + collect (list etype vals vec result))) nil) (deftest map-into.specialized-vector.7 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float) - for vals = (loop for i below len collect (coerce i etype)) - for target = (make-array len :initial-contents vals :element-type etype) - for result = (map-into target #'identity vals) - unless (and (eq target result) - (= (length result) len) - (every #'= result vals)) - collect (list etype vals result))) + for vals = (loop for i below len collect (coerce i etype)) + for target = (make-array len :initial-contents vals :element-type etype) + for result = (map-into target #'identity vals) + unless (and (eq target result) + (= (length result) len) + (every #'= result vals)) + collect (list etype vals result))) nil) (deftest map-into.specialized-vector.8 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float) - for etype = `(complex ,cetype) - for vals = (loop for i from 1 to len collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for target = (make-array len :initial-contents vals :element-type etype) - for result = (map-into target #'identity vals) - unless (and (eq target result) - (= (length result) len) - (every #'= result vals)) - collect (list etype vals result))) + for etype = `(complex ,cetype) + for vals = (loop for i from 1 to len collect (complex (coerce i cetype) + (coerce (- i) cetype))) + for target = (make-array len :initial-contents vals :element-type etype) + for result = (map-into target #'identity vals) + unless (and (eq target result) + (= (length result) len) + (every #'= result vals)) + collect (list etype vals result))) nil) ;;; Error cases @@ -463,14 +463,14 @@ ;;; means that error checking may be skipped. (deftest map-into.error.2 (and (locally (declare (optimize (safety 3))) - (handler-case (eval '(map-into nil #'identity 'a)) - (type-error () nil))) + (handler-case (eval '(map-into nil #'identity 'a)) + (type-error () nil))) :bad) nil) (deftest map-into.error.3 (check-type-error #'(lambda (x) (map-into (copy-seq '(a b c)) #'cons '(d e f) x)) - #'sequencep) + #'sequencep) nil) (deftest map-into.error.4 @@ -483,7 +483,7 @@ (deftest map-into.error.6 (signals-error (locally (map-into 'a #'(lambda () nil)) t) - type-error) + type-error) t) (deftest map-into.error.7 @@ -500,8 +500,8 @@ (let ((i 0) a b c) (values (map-into (progn (setf a (incf i)) (list 1 2 3 4)) - (progn (setf b (incf i)) #'identity) - (progn (setf c (incf i)) '(a b c d))) + (progn (setf b (incf i)) #'identity) + (progn (setf c (incf i)) '(a b c d))) i a b c)) (a b c d) 3 1 2 3) @@ -509,8 +509,8 @@ (let ((i 0) a b c d) (values (map-into (progn (setf a (incf i)) (list 1 2 3 4)) - (progn (setf b (incf i)) #'list) - (progn (setf c (incf i)) '(a b c d)) - (progn (setf d (incf i)) '(e f g h))) + (progn (setf b (incf i)) #'list) + (progn (setf c (incf i)) '(a b c d)) + (progn (setf d (incf i)) '(e f g h))) i a b c d)) ((a e) (b f) (c g) (d h)) 4 1 2 3 4) diff --git a/ansi-tests/map.lsp b/ansi-tests/map.lsp index eae2525a..846c96d5 100644 --- a/ansi-tests/map.lsp +++ b/ansi-tests/map.lsp @@ -211,7 +211,7 @@ :notes (:result-type-element-type-by-subtype) (let ((type '(or (vector t 10) (vector t 5)))) (if (subtypep type '(vector t)) - (equalpt (map type #'identity '(1 2 3 4 5)) #(1 2 3 4 5)) + (equalpt (map type #'identity '(1 2 3 4 5)) #(1 2 3 4 5)) t)) t) @@ -251,7 +251,7 @@ (deftest map.error.8 (signals-error (map 'list #'cons '(a b c d) '(1 2 3 4) '(5 6 7 8)) - program-error) + program-error) t) (deftest map.error.9 @@ -262,14 +262,14 @@ :notes (:result-type-element-type-by-subtype) (let ((type '(or (vector bit) (vector t)))) (if (subtypep type 'vector) - (eval `(signals-error-always (map ',type #'identity '(1 0 1)) error)) + (eval `(signals-error-always (map ',type #'identity '(1 0 1)) error)) (values t t))) t t) (deftest map.error.11 (let ((type '(or (vector t 5) (vector t 10)))) (if (subtypep type 'vector) - (eval `(signals-error (map ',type #'identity '(1 2 3 4 5 6)) type-error)) + (eval `(signals-error (map ',type #'identity '(1 2 3 4 5 6)) type-error)) t)) t) @@ -285,41 +285,41 @@ (deftest map.fill.1 (let ((s1 (make-array '(10) :initial-contents '(a b c d e f g h i j) - :fill-pointer 8))) + :fill-pointer 8))) (map 'list #'identity s1)) (a b c d e f g h)) (deftest map.fill.2 (let ((s1 (make-array '(10) :initial-contents '(a b c d e f g h i j) - :fill-pointer 8))) + :fill-pointer 8))) (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) (1 2 3 4 5 6 7 8)) (deftest map.fill.3 (let ((s1 (make-array '(10) :initial-element #\a - :element-type 'character - :fill-pointer 8))) + :element-type 'character + :fill-pointer 8))) (map 'string #'identity s1)) "aaaaaaaa") - + (deftest map.fill.4 (let ((s1 (make-array '(10) :initial-element #\a - :element-type 'base-char - :fill-pointer 8))) + :element-type 'base-char + :fill-pointer 8))) (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) (1 2 3 4 5 6 7 8)) (deftest map.fill.5 (let ((s1 (make-array '(10) :initial-element 0 - :element-type 'bit - :fill-pointer 8))) + :element-type 'bit + :fill-pointer 8))) (map 'bit-vector #'identity s1)) - #*00000000) - + #*00000000) + (deftest map.fill.6 (let ((s1 (make-array '(10) :initial-element 1 - :element-type 'bit - :fill-pointer 8))) + :element-type 'bit + :fill-pointer 8))) (map 'list #'(lambda (x y) x) '(1 2 3 4 5 6 7 8 9 10) s1)) (1 2 3 4 5 6 7 8)) @@ -369,49 +369,49 @@ (deftest map.specialized-vector.4 (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - for bound = (ash 1 i) - for len = 10 - for vals = (loop repeat len collect (random i)) - for result = (map `(vector ,type) #'identity vals) - unless (and (= (length result) len) - (every #'eql vals result)) - collect (list i vals result)) + for type = `(unsigned-byte ,i) + for bound = (ash 1 i) + for len = 10 + for vals = (loop repeat len collect (random i)) + for result = (map `(vector ,type) #'identity vals) + unless (and (= (length result) len) + (every #'eql vals result)) + collect (list i vals result)) nil) (deftest map.specialized-vector.5 (loop for i from 1 to 40 - for type = `(signed-byte ,i) - for bound = (ash 1 i) - for len = 10 - for vals = (loop repeat len collect (- (random i) (/ bound 2))) - for result = (map `(vector ,type) #'identity vals) - unless (and (= (length result) len) - (every #'eql vals result)) - collect (list i vals result)) + for type = `(signed-byte ,i) + for bound = (ash 1 i) + for len = 10 + for vals = (loop repeat len collect (- (random i) (/ bound 2))) + for result = (map `(vector ,type) #'identity vals) + unless (and (= (length result) len) + (every #'eql vals result)) + collect (list i vals result)) nil) (deftest map.specialized-vector.6 (loop for type in '(short-float single-float long-float double-float) - for len = 10 - for vals = (loop for i from 1 to len collect (coerce i type)) - for result = (map `(vector ,type) #'identity vals) - unless (and (= (length result) len) - (every #'eql vals result)) - collect (list type vals result)) + for len = 10 + for vals = (loop for i from 1 to len collect (coerce i type)) + for result = (map `(vector ,type) #'identity vals) + unless (and (= (length result) len) + (every #'eql vals result)) + collect (list type vals result)) nil) (deftest map.specialized-vector.7 (loop for etype in '(short-float single-float long-float double-float - integer rational) - for type = `(complex ,etype) - for len = 10 - for vals = (loop for i from 1 to len collect (complex (coerce i etype) - (coerce (- i) etype))) - for result = (map `(vector ,type) #'identity vals) - unless (and (= (length result) len) - (every #'eql vals result)) - collect (list type vals result)) + integer rational) + for type = `(complex ,etype) + for len = 10 + for vals = (loop for i from 1 to len collect (complex (coerce i etype) + (coerce (- i) etype))) + for result = (map `(vector ,type) #'identity vals) + unless (and (= (length result) len) + (every #'eql vals result)) + collect (list type vals result)) nil) ;;; Order of evaluation tests @@ -420,9 +420,9 @@ (let ((i 0) a b c d) (values (map (progn (setf a (incf i)) 'list) - (progn (setf b (incf i)) #'list) - (progn (setf c (incf i)) '(a b c)) - (progn (setf d (incf i)) '(b c d))) + (progn (setf b (incf i)) #'list) + (progn (setf c (incf i)) '(a b c)) + (progn (setf d (incf i)) '(b c d))) i a b c d)) ((a b)(b c)(c d)) 4 1 2 3 4) diff --git a/ansi-tests/mapc.lsp b/ansi-tests/mapc.lsp index 70494fd0..4c9a6544 100644 --- a/ansi-tests/mapc.lsp +++ b/ansi-tests/mapc.lsp @@ -14,8 +14,8 @@ (deftest mapc.2 (let ((x 0)) (let ((result - (mapc #'(lambda (y) (incf x y)) - '(1 2 3 4)))) + (mapc #'(lambda (y) (incf x y)) + '(1 2 3 4)))) (list result x))) ((1 2 3 4) 10)) @@ -23,8 +23,8 @@ (let ((x 0)) (list (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) - (make-list 5 :initial-element 'a) - (make-list 5 )) + (make-list 5 :initial-element 'a) + (make-list 5 )) x)) ((a a a a a) 5)) @@ -32,8 +32,8 @@ (let ((x 0)) (list (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) - (make-list 5 :initial-element 'a) - (make-list 10)) + (make-list 5 :initial-element 'a) + (make-list 10)) x)) ((a a a a a) 5)) @@ -41,30 +41,30 @@ (let ((x 0)) (list (mapc #'(lambda (y z) (declare (ignore y z)) (incf x)) - (make-list 5 :initial-element 'a) - (make-list 3)) + (make-list 5 :initial-element 'a) + (make-list 3)) x)) ((a a a a a) 3)) (deftest mapc.6 (let* ((x (copy-list '(a b c d e f g h))) - (xcopy (make-scaffold-copy x))) + (xcopy (make-scaffold-copy x))) (setf *mapc.6-var* nil) (let ((result (mapc 'mapc.6-fun x))) (and (check-scaffold-copy x xcopy) - (eqt result x) - *mapc.6-var*))) + (eqt result x) + *mapc.6-var*))) (h g f e d c b a)) (deftest mapc.order.1 (let ((i 0) x y z) (values (mapc (progn (setf x (incf i)) - #'list) - (progn (setf y (incf i)) - '(a b c)) - (progn (setf z (incf i)) - '(1 2 3))) + #'list) + (progn (setf y (incf i)) + '(a b c)) + (progn (setf z (incf i)) + '(1 2 3))) i x y z)) (a b c) 3 1 2 3) diff --git a/ansi-tests/mapcan.lsp b/ansi-tests/mapcan.lsp index 4e93adfd..c5b2f6e8 100644 --- a/ansi-tests/mapcan.lsp +++ b/ansi-tests/mapcan.lsp @@ -17,8 +17,8 @@ (deftest mapcan.3 (let* ((x (list 'a 'b 'c 'd)) - (xcopy (make-scaffold-copy x)) - (result (mapcan #'list x))) + (xcopy (make-scaffold-copy x)) + (result (mapcan #'list x))) (and (= (length x) (length result)) (check-scaffold-copy x xcopy) @@ -30,14 +30,14 @@ (deftest mapcan.4 (mapcan #'list - (copy-list '(1 2 3 4)) - (copy-list '(a b c d))) + (copy-list '(1 2 3 4)) + (copy-list '(a b c d))) (1 a 2 b 3 c 4 d)) (deftest mapcan.5 (mapcan #'(lambda (x y) (make-list y :initial-element x)) - (copy-list '(a b c d)) - (copy-list '(1 2 3 4))) + (copy-list '(a b c d)) + (copy-list '(1 2 3 4))) (a b b c c c d d d d)) (defvar *mapcan.6-var* nil) @@ -55,32 +55,32 @@ (let ((i 0) x y z) (values (mapcan (progn (setf x (incf i)) - #'list) - (progn (setf y (incf i)) - '(a b c)) - (progn (setf z (incf i)) - '(1 2 3))) + #'list) + (progn (setf y (incf i)) + '(a b c)) + (progn (setf z (incf i)) + '(1 2 3))) i x y z)) (a 1 b 2 c 3) 3 1 2 3) (deftest mapcan.8 (mapcan #'(lambda (x y) (make-list y :initial-element x)) - (copy-list '(a b c d)) - (copy-list '(1 2 3 4 5 6))) + (copy-list '(a b c d)) + (copy-list '(1 2 3 4 5 6))) (a b b c c c d d d d)) (deftest mapcan.9 (mapcan #'(lambda (x y) (make-list y :initial-element x)) - (copy-list '(a b c d e f)) - (copy-list '(1 2 3 4))) + (copy-list '(a b c d e f)) + (copy-list '(1 2 3 4))) (a b b c c c d d d d)) (deftest mapcan.10 (mapcan #'list - (copy-list '(a b c d)) - (copy-list '(1 2 3 4)) - nil) + (copy-list '(a b c d)) + (copy-list '(1 2 3 4)) + nil) nil) (deftest mapcan.11 @@ -113,10 +113,10 @@ (deftest mapcan.error.7 (signals-error (mapcan #'cons '(a b c) '(1 2 3) '(4 5 6)) - program-error) + program-error) t) (deftest mapcan.error.8 (signals-error (mapcan #'identity (list* (list 1) (list 2) 3)) - type-error) + type-error) t) diff --git a/ansi-tests/mapcar.lsp b/ansi-tests/mapcar.lsp index e1db5f8c..34bb0e9c 100644 --- a/ansi-tests/mapcar.lsp +++ b/ansi-tests/mapcar.lsp @@ -13,69 +13,69 @@ (deftest mapcar.2 (let* ((x (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x))) + (xcopy (make-scaffold-copy x))) (let ((result (mapcar #'1+ x))) (and (check-scaffold-copy x xcopy) - result))) + result))) (2 3 4 5)) (deftest mapcar.3 (let* ((n 0) - (x (copy-list '(a b c d))) - (xcopy (make-scaffold-copy x))) + (x (copy-list '(a b c d))) + (xcopy (make-scaffold-copy x))) (let ((result - (mapcar #'(lambda (y) (declare (ignore y)) (incf n)) - x))) + (mapcar #'(lambda (y) (declare (ignore y)) (incf n)) + x))) (and (check-scaffold-copy x xcopy) - result))) + result))) (1 2 3 4)) (deftest mapcar.4 (let* ((n 0) - (x (copy-list '(a b c d))) - (xcopy (make-scaffold-copy x)) - (x2 (copy-list '(a b c d e f))) - (x2copy (make-scaffold-copy x2)) - (result - (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) - x x2))) + (x (copy-list '(a b c d))) + (xcopy (make-scaffold-copy x)) + (x2 (copy-list '(a b c d e f))) + (x2copy (make-scaffold-copy x2)) + (result + (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) + x x2))) (and (check-scaffold-copy x xcopy) - (check-scaffold-copy x2 x2copy) - (list result n))) + (check-scaffold-copy x2 x2copy) + (list result n))) ((1 2 3 4) 4)) - + (deftest mapcar.5 (let* ((n 0) - (x (copy-list '(a b c d))) - (xcopy (make-scaffold-copy x)) - (x2 (copy-list '(a b c d e f))) - (x2copy (make-scaffold-copy x2)) - (result - (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) - x2 x))) + (x (copy-list '(a b c d))) + (xcopy (make-scaffold-copy x)) + (x2 (copy-list '(a b c d e f))) + (x2copy (make-scaffold-copy x2)) + (result + (mapcar #'(lambda (y z) (declare (ignore y z)) (incf n)) + x2 x))) (and (check-scaffold-copy x xcopy) - (check-scaffold-copy x2 x2copy) - (list result n))) + (check-scaffold-copy x2 x2copy) + (list result n))) ((1 2 3 4) 4)) (deftest mapcar.6 (let* ((x (copy-list '(a b c d e f g h))) - (xcopy (make-scaffold-copy x))) + (xcopy (make-scaffold-copy x))) (setf *mapc.6-var* nil) (let ((result (mapcar 'mapc.6-fun x))) (and (check-scaffold-copy x xcopy) - (list *mapc.6-var* result)))) + (list *mapc.6-var* result)))) ((h g f e d c b a) (a b c d e f g h))) (deftest mapcar.order.1 (let ((i 0) x y z) (values (mapcar (progn (setf x (incf i)) - #'list) - (progn (setf y (incf i)) - '(a b c)) - (progn (setf z (incf i)) - '(1 2 3))) + #'list) + (progn (setf y (incf i)) + '(a b c)) + (progn (setf z (incf i)) + '(1 2 3))) i x y z)) ((a 1) (b 2) (c 3)) 3 1 2 3) diff --git a/ansi-tests/mapcon.lsp b/ansi-tests/mapcon.lsp index 58bb0fe8..d61ffd3b 100644 --- a/ansi-tests/mapcon.lsp +++ b/ansi-tests/mapcon.lsp @@ -13,9 +13,9 @@ (deftest mapcon.2 (let* ((x (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (result - (mapcon #'(lambda (y) (append '(a) y nil)) x))) + (xcopy (make-scaffold-copy x)) + (result + (mapcon #'(lambda (y) (append '(a) y nil)) x))) (and (check-scaffold-copy x xcopy) result)) @@ -23,13 +23,13 @@ (deftest mapcon.3 (let* ((x (copy-list '(4 2 3 2 2))) - (y (copy-list '(a b c d e f g h i j k l))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (mapcon #'(lambda (xt yt) - (subseq yt 0 (car xt))) - x y))) + (y (copy-list '(a b c d e f g h i j k l))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapcon #'(lambda (xt yt) + (subseq yt 0 (car xt))) + x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) @@ -44,11 +44,11 @@ (let ((i 0) x y z) (values (mapcon (progn (setf x (incf i)) - #'(lambda (x y) (list (car x) (car y)))) - (progn (setf y (incf i)) - '(a b c)) - (progn (setf z (incf i)) - '(1 2 3))) + #'(lambda (x y) (list (car x) (car y)))) + (progn (setf y (incf i)) + '(a b c)) + (progn (setf z (incf i)) + '(1 2 3))) i x y z)) (a 1 b 2 c 3) 3 1 2 3) diff --git a/ansi-tests/maphash.lsp b/ansi-tests/maphash.lsp index 13742286..0666a26f 100644 --- a/ansi-tests/maphash.lsp +++ b/ansi-tests/maphash.lsp @@ -11,7 +11,7 @@ (let ((s1 0) (s2 0)) (values (multiple-value-list - (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) + (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) s1 s2))) (nil) #.(* 500 1001) #.(* 1000 1001)) @@ -21,7 +21,7 @@ (let ((s1 0) (s2 0)) (values (multiple-value-list - (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) + (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) s1 s2))) (nil) #.(* 500 1001) #.(* 1000 1001)) @@ -31,7 +31,7 @@ (let ((s1 0) (s2 0)) (values (multiple-value-list - (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) + (maphash #'(lambda (k v) (incf s1 k) (incf s2 v)) table)) s1 s2))) (nil) #.(* 500 1001) #.(* 1000 1001)) @@ -43,10 +43,10 @@ (let ((s1 0) (s2 0)) (values (multiple-value-list - (maphash #'(lambda (k v) - (incf s1 k) (incf s2 v) - (remhash k table)) - table)) + (maphash #'(lambda (k v) + (incf s1 k) (incf s2 v) + (remhash k table)) + table)) s1 s2 (hash-table-count table)))) (nil) #.(* 500 1001) #.(* 1000 1001) 0) @@ -56,10 +56,10 @@ (let ((s1 0) (s2 0)) (values (multiple-value-list - (maphash #'(lambda (k v) - (incf s1 k) (incf s2 v) - (remhash k table)) - table)) + (maphash #'(lambda (k v) + (incf s1 k) (incf s2 v) + (remhash k table)) + table)) s1 s2 (hash-table-count table)))) (nil) #.(* 500 1001) #.(* 1000 1001) 0) @@ -69,10 +69,10 @@ (let ((s1 0) (s2 0)) (values (multiple-value-list - (maphash #'(lambda (k v) - (incf s1 k) (incf s2 v) - (remhash k table)) - table)) + (maphash #'(lambda (k v) + (incf s1 k) (incf s2 v) + (remhash k table)) + table)) s1 s2 (hash-table-count table)))) (nil) #.(* 500 1001) #.(* 1000 1001) 0) @@ -81,34 +81,34 @@ (deftest maphash.7 (let ((symbols '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) - (table (make-hash-table :test #'eq))) + (table (make-hash-table :test #'eq))) (loop for sym in symbols - for i from 1 - do (setf (gethash sym table) i)) + for i from 1 + do (setf (gethash sym table) i)) (let ((sum 0)) (values (multiple-value-list - (maphash #'(lambda (k v) - (assert (eq (elt symbols (1- v)) k)) - (incf sum v)) - table)) + (maphash #'(lambda (k v) + (assert (eq (elt symbols (1- v)) k)) + (incf sum v)) + table)) sum))) (nil) #.(* 13 27)) (deftest maphash.8 (let ((symbols '(a b c d e f g h i j k l m n o p q r s t u v w x y z)) - (table (make-hash-table :test #'eq))) + (table (make-hash-table :test #'eq))) (loop for sym in symbols - for i from 1 - do (setf (gethash sym table) i)) + for i from 1 + do (setf (gethash sym table) i)) (let ((sum 0)) (values (multiple-value-list - (maphash #'(lambda (k v) - (assert (eq (elt symbols (1- v)) k)) - (remhash k table) - (incf sum v)) - table)) + (maphash #'(lambda (k v) + (assert (eq (elt symbols (1- v)) k)) + (remhash k table) + (incf sum v)) + table)) sum (hash-table-count table)))) (nil) #.(* 13 27) 0) @@ -117,16 +117,16 @@ (deftest maphash.order.1 (let ((i 0) x y dummy - (table (make-hash-table))) + (table (make-hash-table))) (values (multiple-value-list (maphash (progn (setf x (incf i)) - #'(lambda (k v) (setf dummy (list k v)))) - (progn (setf y (incf i)) - table))) + #'(lambda (k v) (setf dummy (list k v)))) + (progn (setf y (incf i)) + table))) i x y dummy)) (nil) 2 1 2 nil) - + ;;; Error tests diff --git a/ansi-tests/mapl.lsp b/ansi-tests/mapl.lsp index 3907ae77..08ac5824 100644 --- a/ansi-tests/mapl.lsp +++ b/ansi-tests/mapl.lsp @@ -13,11 +13,11 @@ (deftest mapl.2 (let* ((a nil) - (x (copy-list '(a b c))) - (xcopy (make-scaffold-copy x)) - (result - (mapl #'(lambda (y) (push y a)) - x))) + (x (copy-list '(a b c))) + (xcopy (make-scaffold-copy x)) + (result + (mapl #'(lambda (y) (push y a)) + x))) (and (check-scaffold-copy x xcopy) (eqt result x) @@ -26,16 +26,16 @@ (deftest mapl.3 (let* ((a nil) - (x (copy-list '(a b c d))) - (y (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (mapl #'(lambda (xtail ytail) - (setf a - (append (mapcar #'list xtail ytail) - a))) - x y))) + (x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapl #'(lambda (xtail ytail) + (setf a + (append (mapcar #'list xtail ytail) + a))) + x y))) (and (eqt result x) (check-scaffold-copy x xcopy) @@ -46,16 +46,16 @@ (deftest mapl.4 (let* ((a nil) - (x (copy-list '(a b c d))) - (y (copy-list '(1 2 3 4 5 6 7 8))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (mapl #'(lambda (xtail ytail) - (setf a - (append (mapcar #'list xtail ytail) - a))) - x y))) + (x (copy-list '(a b c d))) + (y (copy-list '(1 2 3 4 5 6 7 8))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapl #'(lambda (xtail ytail) + (setf a + (append (mapcar #'list xtail ytail) + a))) + x y))) (and (eqt result x) (check-scaffold-copy x xcopy) @@ -66,16 +66,16 @@ (deftest mapl.5 (let* ((a nil) - (x (copy-list '(a b c d e f g))) - (y (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (mapl #'(lambda (xtail ytail) - (setf a - (append (mapcar #'list xtail ytail) - a))) - x y))) + (x (copy-list '(a b c d e f g))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (mapl #'(lambda (xtail ytail) + (setf a + (append (mapcar #'list xtail ytail) + a))) + x y))) (and (eqt result x) (check-scaffold-copy x xcopy) @@ -88,14 +88,14 @@ (let ((i 0) x y z) (values (mapl (progn - (setf x (incf i)) - (constantly nil)) - (progn - (setf y (incf i)) - '(a b c)) - (progn - (setf z (incf i)) - '(1 2 3))) + (setf x (incf i)) + (constantly nil)) + (progn + (setf y (incf i)) + '(a b c)) + (progn + (setf z (incf i)) + '(1 2 3))) i x y z)) (a b c) 3 1 2 3) diff --git a/ansi-tests/maplist.lsp b/ansi-tests/maplist.lsp index 14a75968..5d6c33a3 100644 --- a/ansi-tests/maplist.lsp +++ b/ansi-tests/maplist.lsp @@ -13,19 +13,19 @@ (deftest maplist.2 (let* ((x (copy-list '(a b c))) - (xcopy (make-scaffold-copy x)) - (result (maplist #'identity x))) + (xcopy (make-scaffold-copy x)) + (result (maplist #'identity x))) (and (check-scaffold-copy x xcopy) - result)) + result)) ((a b c) (b c) (c))) (deftest maplist.3 (let* ((x (copy-list '(a b c d))) - (y (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (maplist #'append x y))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (maplist #'append x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) @@ -37,11 +37,11 @@ (deftest maplist.4 (let* ((x (copy-list '(a b c d))) - (y (copy-list '(1 2 3 4 5))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (maplist #'append x y))) + (y (copy-list '(1 2 3 4 5))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (maplist #'append x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) @@ -53,11 +53,11 @@ (deftest maplist.5 (let* ((x (copy-list '(a b c d e))) - (y (copy-list '(1 2 3 4))) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - (result - (maplist #'append x y))) + (y (copy-list '(1 2 3 4))) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + (result + (maplist #'append x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) @@ -73,9 +73,9 @@ (deftest maplist.7 (maplist #'(lambda (x y) (nth (car x) y)) - '(0 1 0 1 0 1 0) - '(a b c d e f g) - ) + '(0 1 0 1 0 1 0) + '(a b c d e f g) + ) (a c c e e g g)) (deftest maplist.order.1 @@ -83,14 +83,14 @@ (values (maplist (progn - (setf x (incf i)) - #'(lambda (x y) (declare (ignore x)) (car y))) + (setf x (incf i)) + #'(lambda (x y) (declare (ignore x)) (car y))) (progn - (setf y (incf i)) - '(a b c)) + (setf y (incf i)) + '(a b c)) (progn - (setf z (incf i)) - '(1 2 3))) + (setf z (incf i)) + '(1 2 3))) i x y z)) (1 2 3) 3 1 2 3) @@ -137,12 +137,12 @@ (deftest maplist.error.10 (signals-error (maplist #'cons '(a b c) '(1 2 3) '(4 5 6)) - program-error) + program-error) t) (deftest maplist.error.11 (signals-error (maplist #'identity (list* (list 1) (list 2) 3)) - type-error) + type-error) t) diff --git a/ansi-tests/mask-field.lsp b/ansi-tests/mask-field.lsp index 0ca744fa..ea7ce233 100644 --- a/ansi-tests/mask-field.lsp +++ b/ansi-tests/mask-field.lsp @@ -23,38 +23,38 @@ (deftest mask-field.1 (loop for x = (random-fixnum) - for pos = (random 30) - for size = (random 30) - repeat 10000 - unless (eql (mask-field (byte size pos) x) - (logand (ash (1- (ash 1 size)) pos) x)) - collect (list x pos size)) + for pos = (random 30) + for size = (random 30) + repeat 10000 + unless (eql (mask-field (byte size pos) x) + (logand (ash (1- (ash 1 size)) pos) x)) + collect (list x pos size)) nil) (deftest mask-field.2 (let ((bound (ash 1 300))) (loop for x = (random-from-interval bound) - for pos = (random 300) - for size = (random 300) - repeat 1000 - unless (eql (mask-field (byte size pos) x) - (logand (ash (1- (ash 1 size)) pos) x)) - collect (list x pos size))) + for pos = (random 300) + for size = (random 300) + repeat 1000 + unless (eql (mask-field (byte size pos) x) + (logand (ash (1- (ash 1 size)) pos) x)) + collect (list x pos size))) nil) (deftest mask-field.3 (loop for i of-type fixnum from -1000 to 1000 - always (eql (mask-field (byte 0 0) i) 0)) + always (eql (mask-field (byte 0 0) i) 0)) t) (deftest mask-field.order.1 (let ((i 0) a b c d) (values (mask-field (progn (setf a (incf i)) - (byte (progn (setf b (incf i)) 3) - (progn (setf c (incf i)) 1))) - (progn (setf d (incf i)) -1)) + (byte (progn (setf b (incf i)) 3) + (progn (setf c (incf i)) 1))) + (progn (setf d (incf i)) -1)) i a b c d)) 14 4 1 2 3 4) @@ -69,25 +69,25 @@ (deftest mask-field.place.2 (loop for pos from 0 to 100 - always - (loop for size from 0 to 100 - always - (let ((x 0) - (field (ash 1 pos))) - (and (eql (setf (mask-field (byte size pos) x) field) field) - (if (> size 0) (eql x field) (eql x 0)) - )))) + always + (loop for size from 0 to 100 + always + (let ((x 0) + (field (ash 1 pos))) + (and (eql (setf (mask-field (byte size pos) x) field) field) + (if (> size 0) (eql x field) (eql x 0)) + )))) t) (deftest mask-field.place.order.1 (let ((i 0) a b c d e f (x (copy-seq #(63)))) (values (setf (mask-field (progn (setf a (incf i)) - (byte (progn (setf b (incf i)) 3) - (progn (setf c (incf i)) 1))) - (aref (progn (setf d (incf i)) x) - (progn (setf e (incf i)) 0))) - (progn (setf f (incf i)) (lognot 14))) + (byte (progn (setf b (incf i)) 3) + (progn (setf c (incf i)) 1))) + (aref (progn (setf d (incf i)) x) + (progn (setf e (incf i)) 0))) + (progn (setf f (incf i)) (lognot 14))) x i a b c d e f)) -15 #(49) 6 1 2 3 4 5 6) diff --git a/ansi-tests/max.lsp b/ansi-tests/max.lsp index c09ce3bc..924a1301 100644 --- a/ansi-tests/max.lsp +++ b/ansi-tests/max.lsp @@ -25,14 +25,14 @@ (deftest max.1 (loop for n in *reals* - when (or (not (eql (max n) n)) - (not (eql (max n n) n)) - (not (eql (max n n n) n)) - (not (eql (apply #'max (make-list - (min 256 (1- call-arguments-limit)) - :initial-element n)) - n))) - collect n) + when (or (not (eql (max n) n)) + (not (eql (max n n) n)) + (not (eql (max n n n) n)) + (not (eql (apply #'max (make-list + (min 256 (1- call-arguments-limit)) + :initial-element n)) + n))) + collect n) nil) (deftest max.2 @@ -41,38 +41,38 @@ (deftest max.3 (loop for x = (- (random 60000) 30000) - for y = (- (random 60000) 30000) - for m = (max x y) - for m2 = (if (>= x y) x y) - repeat 1000 - unless (eql m m2) - collect (list x y m m2)) + for y = (- (random 60000) 30000) + for m = (max x y) + for m2 = (if (>= x y) x y) + repeat 1000 + unless (eql m m2) + collect (list x y m m2)) nil) (deftest max.4 (loop for x = (- (random 6000000) 3000000) - for y = (- (random 6000000) 3000000) - for m = (max x y) - for m2 = (if (>= x y) x y) - repeat 1000 - unless (eql m m2) - collect (list x y m m2)) + for y = (- (random 6000000) 3000000) + for m = (max x y) + for m2 = (if (>= x y) x y) + repeat 1000 + unless (eql m m2) + collect (list x y m m2)) nil) (deftest max.5 (loop for x = (- (random 1000000000000) 500000000000) - for y = (- (random 1000000000000) 500000000000) - for m = (max x y) - for m2 = (if (>= x y) x y) - repeat 1000 - unless (eql m m2) - collect (list x y m m2)) + for y = (- (random 1000000000000) 500000000000) + for m = (max x y) + for m2 = (if (>= x y) x y) + repeat 1000 + unless (eql m m2) + collect (list x y m m2)) nil) (deftest max.6 (let ((m (max 2 1.0s0))) (or (eqlt m 2) - (eqlt m 2.0s0))) + (eqlt m 2.0s0))) t) (deftest max.7 @@ -82,7 +82,7 @@ (deftest max.8 (let ((m (max 2 1.0f0))) (or (eqlt m 2) - (eqlt m 2.0f0))) + (eqlt m 2.0f0))) t) (deftest max.9 @@ -92,7 +92,7 @@ (deftest max.10 (let ((m (max 2 1.0d0))) (or (eqlt m 2) - (eqlt m 2.0d0))) + (eqlt m 2.0d0))) t) (deftest max.11 @@ -102,7 +102,7 @@ (deftest max.12 (let ((m (max 2 1.0l0))) (or (eqlt m 2) - (eqlt m 2.0l0))) + (eqlt m 2.0l0))) t) (deftest max.13 @@ -112,7 +112,7 @@ (deftest max.15 (let ((m (max 1.0s0 0.0f0))) (or (eqlt m 1.0s0) - (eqlt m 1.0f0))) + (eqlt m 1.0f0))) t) (deftest max.16 @@ -122,7 +122,7 @@ (deftest max.17 (let ((m (max 1.0s0 0.0d0))) (or (eqlt m 1.0s0) - (eqlt m 1.0d0))) + (eqlt m 1.0d0))) t) (deftest max.18 @@ -132,7 +132,7 @@ (deftest max.19 (let ((m (max 1.0s0 0.0l0))) (or (eqlt m 1.0s0) - (eqlt m 1.0l0))) + (eqlt m 1.0l0))) t) (deftest max.20 @@ -142,7 +142,7 @@ (deftest max.21 (let ((m (max 1.0f0 0.0d0))) (or (eqlt m 1.0f0) - (eqlt m 1.0d0))) + (eqlt m 1.0d0))) t) (deftest max.22 @@ -152,7 +152,7 @@ (deftest max.23 (let ((m (max 1.0f0 0.0l0))) (or (eqlt m 1.0f0) - (eqlt m 1.0l0))) + (eqlt m 1.0l0))) t) (deftest max.24 @@ -162,7 +162,7 @@ (deftest max.25 (let ((m (max 1.0d0 0.0l0))) (or (eqlt m 1.0d0) - (eqlt m 1.0l0))) + (eqlt m 1.0l0))) t) (deftest max.26 @@ -171,59 +171,59 @@ (deftest max.27 (loop for i from 1 to (min 256 (1- call-arguments-limit)) - for x = (make-list i :initial-element 0) - do (setf (elt x (random i)) 1) - unless (eql (apply #'max x) 1) - collect x) + for x = (make-list i :initial-element 0) + do (setf (elt x (random i)) 1) + unless (eql (apply #'max x) 1) + collect x) nil) (deftest max.28 (let ((m (max 1/3 0.2s0))) (or (eqlt m 1/3) - (eqlt m (float 1/3 0.2s0)))) + (eqlt m (float 1/3 0.2s0)))) t) (deftest max.29 (let ((m (max 1.0s0 3 2.0f0))) (or (eqlt m 3) - (eqlt m 3.0f0))) + (eqlt m 3.0f0))) t) (deftest max.30 (let ((m (max 1.0d0 3 2.0f0))) (or (eqlt m 3) - (eqlt m 3.0d0))) + (eqlt m 3.0d0))) t) (deftest max.31 (let ((m (max 1.0s0 3 2.0l0))) (or (eqlt m 3) - (eqlt m 3.0l0))) + (eqlt m 3.0l0))) t) (deftest max.32 (let ((m (max 1.0l0 3 2.0s0))) (or (eqlt m 3) - (eqlt m 3.0l0))) + (eqlt m 3.0l0))) t) (deftest max.33 (let ((m (max 1.0d0 3 2.0l0))) (or (eqlt m 3) - (eqlt m 3.0l0))) + (eqlt m 3.0l0))) t) (deftest max.34 (let ((m (max 1.0l0 3 2.0d0))) (or (eqlt m 3) - (eqlt m 3.0l0))) + (eqlt m 3.0l0))) t) (deftest max.order.1 (let ((i 0) x y) (values (max (progn (setf x (incf i)) 10) - (progn (setf y (incf i)) 20)) + (progn (setf y (incf i)) 20)) i x y)) 20 2 1 2) @@ -231,8 +231,8 @@ (let ((i 0) x y z) (values (max (progn (setf x (incf i)) 10) - (progn (setf y (incf i)) 20) - (progn (setf z (incf i)) 30)) + (progn (setf y (incf i)) 20) + (progn (setf z (incf i)) 30)) i x y z)) 30 3 1 2 3) @@ -240,10 +240,10 @@ (let ((i 0) u v w x y z) (values (max (progn (setf u (incf i)) 10) - (progn (setf v (incf i)) 20) - (progn (setf w (incf i)) 30) - (progn (setf x (incf i)) 10) - (progn (setf y (incf i)) 20) - (progn (setf z (incf i)) 30)) + (progn (setf v (incf i)) 20) + (progn (setf w (incf i)) 30) + (progn (setf x (incf i)) 10) + (progn (setf y (incf i)) 20) + (progn (setf z (incf i)) 30)) i u v w x y z)) 30 6 1 2 3 4 5 6) diff --git a/ansi-tests/member-if-not.lsp b/ansi-tests/member-if-not.lsp index 63dc8665..69ee39a1 100644 --- a/ansi-tests/member-if-not.lsp +++ b/ansi-tests/member-if-not.lsp @@ -21,19 +21,19 @@ (deftest member-if-not.4 (let ((test-inputs - `(1 a 11.3121 11.31s3 1.123f5 -1 0 - 13.13122d34 581.131e-10 - ((a) (b) (c) . d) - ,(make-array '(10)) - "ancadas" #\w))) + `(1 a 11.3121 11.31s3 1.123f5 -1 0 + 13.13122d34 581.131e-10 + ((a) (b) (c) . d) + ,(make-array '(10)) + "ancadas" #\w))) (not (every - #'(lambda (x) - (let ((result (catch-type-error (member-if-not #'listp x)))) - (or (eqt result 'type-error) - (progn - (format t "~%On x = ~S, returns: ~%~S" x result) - nil)))) - test-inputs))) + #'(lambda (x) + (let ((result (catch-type-error (member-if-not #'listp x)))) + (or (eqt result 'type-error) + (progn + (format t "~%On x = ~S, returns: ~%~S" x result) + nil)))) + test-inputs))) nil) (deftest member-if-not.5 @@ -46,9 +46,9 @@ (let ((i 0) x y) (values (member-if-not (progn (setf x (incf i)) - #'not) - (progn (setf y (incf i)) - '(nil nil a b nil c d))) + #'not) + (progn (setf y (incf i)) + '(nil nil a b nil c d))) i x y)) (a b nil c d) 2 1 2) @@ -56,12 +56,12 @@ (let ((i 0) x y z w) (values (member-if-not (progn (setf x (incf i)) - #'not) - (progn (setf y (incf i)) - '(nil nil a b nil c d)) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf w (incf i)) #'not)) - + #'not) + (progn (setf y (incf i)) + '(nil nil a b nil c d)) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf w (incf i)) #'not)) + i x y z w)) (a b nil c d) 4 1 2 3 4) @@ -89,7 +89,7 @@ (deftest member-if-not.allow-other-keys.6 (member-if-not #'not '(nil 2 3 4 5) :allow-other-keys t - :allow-other-keys nil :key #'identity :key #'null) + :allow-other-keys nil :key #'identity :key #'null) (2 3 4 5)) ;;; Error tests @@ -97,35 +97,35 @@ (deftest member-if-not.error.1 (check-type-error #'(lambda (x) (member-if-not #'identity x)) #'listp) nil) - + (deftest member-if-not.error.2 (signals-error (member-if-not) program-error) t) - + (deftest member-if-not.error.3 (signals-error (member-if-not #'null) program-error) t) - + (deftest member-if-not.error.4 (signals-error (member-if-not #'null '(a b c) :bad t) program-error) t) - + (deftest member-if-not.error.5 (signals-error (member-if-not #'null '(a b c) :bad t :allow-other-keys nil) - program-error) + program-error) t) - + (deftest member-if-not.error.6 (signals-error (member-if-not #'null '(a b c) :key) program-error) t) - + (deftest member-if-not.error.7 (signals-error (member-if-not #'null '(a b c) 1 2) program-error) t) (deftest member-if-not.error.8 (signals-error (locally (member-if-not #'identity 'a) t) - type-error) + type-error) t) (deftest member-if-not.error.9 @@ -134,5 +134,5 @@ (deftest member-if-not.error.10 (signals-error (member-if-not #'identity '(a b c) :key #'cons) - program-error) + program-error) t) diff --git a/ansi-tests/member-if.lsp b/ansi-tests/member-if.lsp index bb26099d..68111794 100644 --- a/ansi-tests/member-if.lsp +++ b/ansi-tests/member-if.lsp @@ -21,19 +21,19 @@ (deftest member-if.4 (let ((test-inputs - `(1 a 11.3121 11.31s3 1.123f5 -1 0 - 13.13122d34 581.131e-10 - (a b c . d) - ,(make-array '(10)) - "ancadas" #\w))) + `(1 a 11.3121 11.31s3 1.123f5 -1 0 + 13.13122d34 581.131e-10 + (a b c . d) + ,(make-array '(10)) + "ancadas" #\w))) (notnot-mv (every #'(lambda (x) - (let ((result (catch-type-error (member-if #'listp x)))) - (or (eqt result 'type-error) - (progn - (format t "~%On ~S: returned ~%~S" x result) - nil)))) + (let ((result (catch-type-error (member-if #'listp x)))) + (or (eqt result 'type-error) + (progn + (format t "~%On ~S: returned ~%~S" x result) + nil)))) test-inputs))) t) @@ -47,9 +47,9 @@ (let ((i 0) x y) (values (member-if (progn (setf x (incf i)) - #'identity) - (progn (setf y (incf i)) - '(nil nil a b nil c d))) + #'identity) + (progn (setf y (incf i)) + '(nil nil a b nil c d))) i x y)) (a b nil c d) 2 1 2) @@ -57,12 +57,12 @@ (let ((i 0) x y z w) (values (member-if (progn (setf x (incf i)) - #'identity) - (progn (setf y (incf i)) - '(nil nil a b nil c d)) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf w (incf i)) #'not)) - + #'identity) + (progn (setf y (incf i)) + '(nil nil a b nil c d)) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf w (incf i)) #'not)) + i x y z w)) (a b nil c d) 4 1 2 3 4) @@ -90,12 +90,12 @@ (deftest member-if.allow-other-keys.6 (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t - :allow-other-keys nil) + :allow-other-keys nil) (2 3 4 5)) (deftest member-if.allow-other-keys.7 (member-if #'identity '(nil 2 3 4 5) :allow-other-keys t - :allow-other-keys nil :key #'identity :key #'null) + :allow-other-keys nil :key #'identity :key #'null) (2 3 4 5)) ;;; Error cases @@ -103,28 +103,28 @@ (deftest member-if.error.1 (check-type-error #'(lambda (x) (member-if #'identity x)) #'listp) nil) - + (deftest member-if.error.2 (signals-error (member-if) program-error) t) - + (deftest member-if.error.3 (signals-error (member-if #'null) program-error) t) - + (deftest member-if.error.4 (signals-error (member-if #'null '(a b c) :bad t) program-error) t) - + (deftest member-if.error.5 (signals-error (member-if #'null '(a b c) :bad t :allow-other-keys nil) - program-error) + program-error) t) - + (deftest member-if.error.6 (signals-error (member-if #'null '(a b c) :key) program-error) t) - + (deftest member-if.error.7 (signals-error (member-if #'null '(a b c) 1 2) program-error) t) diff --git a/ansi-tests/member.lsp b/ansi-tests/member.lsp index b8595a45..826db8e3 100644 --- a/ansi-tests/member.lsp +++ b/ansi-tests/member.lsp @@ -9,8 +9,8 @@ (deftest member.1 (let* ((x (copy-tree '(a b c d e f))) - (xcopy (make-scaffold-copy x)) - (result (member 'c x))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x))) (and (eqt result (cddr x)) (check-scaffold-copy x xcopy))) @@ -18,8 +18,8 @@ (deftest member.2 (let* ((x (copy-tree '(a b c d e f))) - (xcopy (make-scaffold-copy x)) - (result (member 'e x))) + (xcopy (make-scaffold-copy x)) + (result (member 'e x))) (and (eqt result (cddddr x)) (check-scaffold-copy x xcopy))) @@ -27,8 +27,8 @@ (deftest member.3 (let* ((x (copy-tree '(1 2 3 4 5 6 7))) - (xcopy (make-scaffold-copy x)) - (result (member 4 x))) + (xcopy (make-scaffold-copy x)) + (result (member 4 x))) (and (eqt result (cdddr x)) (check-scaffold-copy x xcopy))) @@ -36,8 +36,8 @@ (deftest member.4 (let* ((x (copy-tree '(2 4 6 8 10 12))) - (xcopy (make-scaffold-copy x)) - (result (member 9 x :key #'1+))) + (xcopy (make-scaffold-copy x)) + (result (member 9 x :key #'1+))) (and (eqt result (cdddr x)) (check-scaffold-copy x xcopy))) @@ -45,8 +45,8 @@ (deftest member.5 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) - (xcopy (make-scaffold-copy x)) - (result (member '(c d) x :test #'equal))) + (xcopy (make-scaffold-copy x)) + (result (member '(c d) x :test #'equal))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) @@ -54,8 +54,8 @@ (deftest member.6 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) - (xcopy (make-scaffold-copy x)) - (result (member 'c x :key #'car))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x :key #'car))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) @@ -63,8 +63,8 @@ (deftest member.7 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) - (xcopy (make-scaffold-copy x)) - (result (member 'c x :key #'car :test #'eq))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x :key #'car :test #'eq))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) @@ -72,8 +72,8 @@ (deftest member.8 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) - (xcopy (make-scaffold-copy x)) - (result (member 'c x :key #'car :test-not (complement #'eq)))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x :key #'car :test-not (complement #'eq)))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) @@ -81,8 +81,8 @@ (deftest member.9 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) - (xcopy (make-scaffold-copy x)) - (result (member 'c x :key #'car :test #'eql))) + (xcopy (make-scaffold-copy x)) + (result (member 'c x :key #'car :test #'eql))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) @@ -90,8 +90,8 @@ (deftest member.10 (let* ((x (copy-tree '((a b) (c d) (e f) (g h)))) - (xcopy (make-scaffold-copy x)) - (result (member (list 'd) x :key #'cdr :test #'equal))) + (xcopy (make-scaffold-copy x)) + (result (member (list 'd) x :key #'cdr :test #'equal))) (and (eqt result (cdr x)) (check-scaffold-copy x xcopy))) @@ -107,7 +107,7 @@ (deftest member.13 (member (copy-seq "cc") (copy-tree '("aa" "bb" "cc" "dd" "ee")) - :test #'equal) + :test #'equal) ("cc" "dd" "ee")) (deftest member.14 @@ -160,7 +160,7 @@ (let ((i 0) x y) (values (member (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '(a b c d))) + (progn (setf y (incf i)) '(a b c d))) i x y)) (c d) 2 1 2) @@ -168,9 +168,9 @@ (let ((i 0) x y z p) (values (member (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '(a b c d)) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf p (incf i)) #'eq)) + (progn (setf y (incf i)) '(a b c d)) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf p (incf i)) #'eq)) i x y z p)) (c d) 4 1 2 3 4) @@ -178,8 +178,8 @@ (let ((i 0) x y) (values (member (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '(a b c d)) - :test #'eq) + (progn (setf y (incf i)) '(a b c d)) + :test #'eq) i x y)) (c d) 2 1 2) @@ -187,10 +187,10 @@ (let ((i 0) x y z p q) (values (member (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '(a b c d)) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf p (incf i)) #'eq) - :key (progn (setf q (incf i)) (constantly 'z))) + (progn (setf y (incf i)) '(a b c d)) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf p (incf i)) #'eq) + :key (progn (setf q (incf i)) (constantly 'z))) i x y z p q)) (c d) 5 1 2 3 4 5) @@ -198,10 +198,10 @@ (let ((i 0) x y z q) (values (member (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '(a b c d)) - :test #'eq - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf q (incf i)) (constantly 'z))) + (progn (setf y (incf i)) '(a b c d)) + :test #'eq + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf q (incf i)) (constantly 'z))) i x y z q)) (c d) 4 1 2 3 4) @@ -280,7 +280,7 @@ (deftest member.error.12 (signals-error (member nil nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest member.error.13 diff --git a/ansi-tests/merge-pathnames.lsp b/ansi-tests/merge-pathnames.lsp index 7435e980..0a5c94df 100644 --- a/ansi-tests/merge-pathnames.lsp +++ b/ansi-tests/merge-pathnames.lsp @@ -9,17 +9,17 @@ (defun merge-pathnames-test (&rest args) (assert (<= 1 (length args) 3)) (let* ((p1 (car args)) - (p2 (if (cdr args) (cadr args) *default-pathname-defaults*)) - (default-version (if (cddr args) (caddr args) :newest)) - (results (multiple-value-list (apply #'merge-pathnames args)))) + (p2 (if (cdr args) (cadr args) *default-pathname-defaults*)) + (default-version (if (cddr args) (caddr args) :newest)) + (results (multiple-value-list (apply #'merge-pathnames args)))) (assert (= (length results) 1)) (let ((p3 (first results))) - + |# (deftest merge-pathnames.1 (let* ((p1 (make-pathname :name "foo")) - (p2 (merge-pathnames p1 p1 nil))) + (p2 (merge-pathnames p1 p1 nil))) (values (equalpt (pathname-name p1) "foo") (if (equalpt p1 p2) t @@ -28,7 +28,7 @@ (deftest merge-pathnames.2 (let* ((p1 (make-pathname :name "foo")) - (p2 (merge-pathnames p1 p1))) + (p2 (merge-pathnames p1 p1))) (values (equalpt (pathname-host p1) (pathname-host p2)) (equalpt (pathname-device p1) (pathname-device p2)) @@ -37,14 +37,14 @@ (pathname-name p2) (equalpt (pathname-type p1) (pathname-type p2)) (if (pathname-version p1) - (equalpt (pathname-version p1) (pathname-version p2)) + (equalpt (pathname-version p1) (pathname-version p2)) (equalpt (pathname-version p2) :newest)))) t t t "foo" "foo" t t) (deftest merge-pathnames.3 (let* ((p1 (make-pathname :name "foo")) - (p2 (make-pathname :name "bar")) - (p3 (merge-pathnames p1 p2))) + (p2 (make-pathname :name "bar")) + (p3 (merge-pathnames p1 p2))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-device p1) (pathname-device p3)) @@ -53,14 +53,14 @@ (pathname-name p3) (equalpt (pathname-type p1) (pathname-type p3)) (if (pathname-version p1) - (equalpt (pathname-version p1) (pathname-version p3)) + (equalpt (pathname-version p1) (pathname-version p3)) (equalpt (pathname-version p3) :newest)))) t t t "foo" "foo" t t) (deftest merge-pathnames.4 (let* ((p1 (make-pathname :name "foo")) - (p2 (make-pathname :type "lsp")) - (p3 (merge-pathnames p1 p2))) + (p2 (make-pathname :type "lsp")) + (p3 (merge-pathnames p1 p2))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-device p1) (pathname-device p3)) @@ -70,14 +70,14 @@ (pathname-type p3) (equalpt (pathname-type p2) (pathname-type p3)) (if (pathname-version p1) - (equalpt (pathname-version p1) (pathname-version p3)) + (equalpt (pathname-version p1) (pathname-version p3)) (equalpt (pathname-version p3) :newest)))) t t t "foo" "lsp" "lsp" t t) (deftest merge-pathnames.5 (let* ((p1 (make-pathname :name "foo")) - (p2 (make-pathname :type "lsp" :version :newest)) - (p3 (merge-pathnames p1 p2 nil))) + (p2 (make-pathname :type "lsp" :version :newest)) + (p3 (merge-pathnames p1 p2 nil))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-device p1) (pathname-device p3)) @@ -91,8 +91,8 @@ (deftest merge-pathnames.6 (let* ((p1 (make-pathname)) - (p2 (make-pathname :name "foo" :version :newest)) - (p3 (merge-pathnames p1 p2 nil))) + (p2 (make-pathname :name "foo" :version :newest)) + (p3 (merge-pathnames p1 p2 nil))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-device p1) (pathname-device p3)) @@ -106,8 +106,8 @@ (deftest merge-pathnames.7 (let* ((p1 (make-pathname)) - (p2 *default-pathname-defaults*) - (p3 (merge-pathnames p1))) + (p2 *default-pathname-defaults*) + (p3 (merge-pathnames p1))) (values (equalpt (pathname-host p1) (pathname-host p3)) (equalpt (pathname-host p2) (pathname-host p3)) @@ -117,8 +117,8 @@ (equalpt (pathname-type p2) (pathname-type p3)) (cond ((pathname-version p1) (equalpt (pathname-version p1) - (pathname-version p3))) + (pathname-version p3))) ((pathname-version p2) (equalpt (pathname-version p2) - (pathname-version p3))) + (pathname-version p3))) (t (equalpt (pathname-version p3) :newest))))) t t t t t t t) diff --git a/ansi-tests/merge.lsp b/ansi-tests/merge.lsp index 9574e134..692244bb 100644 --- a/ansi-tests/merge.lsp +++ b/ansi-tests/merge.lsp @@ -7,19 +7,19 @@ (deftest merge-list.1 (let ((x (list 1 3 7 8 10)) - (y (list 2 4 5 8 11))) + (y (list 2 4 5 8 11))) (merge 'list x y #'<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.2 (let ((x nil) - (y (list 2 4 5 8 11))) + (y (list 2 4 5 8 11))) (merge 'list x y #'<)) (2 4 5 8 11)) (deftest merge-list.3 (let ((x nil) - (y (list 2 4 5 8 11))) + (y (list 2 4 5 8 11))) (merge 'list y x #'<)) (2 4 5 8 11)) @@ -29,37 +29,37 @@ (deftest merge-list.5 (let ((x (vector 1 3 7 8 10)) - (y (list 2 4 5 8 11))) + (y (list 2 4 5 8 11))) (merge 'list x y #'<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.6 (let ((x (list 1 3 7 8 10)) - (y (vector 2 4 5 8 11))) + (y (vector 2 4 5 8 11))) (merge 'list x y #'<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.7 (let ((x (vector 1 3 7 8 10)) - (y (vector 2 4 5 8 11))) + (y (vector 2 4 5 8 11))) (merge 'list x y #'<)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.8 (let ((x (sort (list 1 3 7 8 10) #'>)) - (y (sort (list 2 4 5 8 11) #'>))) + (y (sort (list 2 4 5 8 11) #'>))) (merge 'list x y #'< :key #'-)) (11 10 8 8 7 5 4 3 2 1)) (deftest merge-list.9 (let ((x (list 1 3 7 8 10)) - (y (list 2 4 5 8 11))) + (y (list 2 4 5 8 11))) (merge 'list x y #'< :key nil)) (1 2 3 4 5 7 8 8 10 11)) (deftest merge-list.10 (let ((x (list 1 3 7 8 10)) - (y (list 2 4 5 8 11))) + (y (list 2 4 5 8 11))) (merge 'list x y '<)) (1 2 3 4 5 7 8 8 10 11)) @@ -92,19 +92,19 @@ (deftest merge-vector.1 (let ((x (list 1 3 7 8 10)) - (y (list 2 4 5 8 11))) + (y (list 2 4 5 8 11))) (merge 'vector x y #'<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.2 (let ((x nil) - (y (list 2 4 5 8 11))) + (y (list 2 4 5 8 11))) (merge 'vector x y #'<)) #(2 4 5 8 11)) (deftest merge-vector.3 (let ((x nil) - (y (list 2 4 5 8 11))) + (y (list 2 4 5 8 11))) (merge 'vector y x #'<)) #(2 4 5 8 11)) @@ -114,37 +114,37 @@ (deftest merge-vector.5 (let ((x (vector 1 3 7 8 10)) - (y (list 2 4 5 8 11))) + (y (list 2 4 5 8 11))) (merge 'vector x y #'<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.6 (let ((x (list 1 3 7 8 10)) - (y (vector 2 4 5 8 11))) + (y (vector 2 4 5 8 11))) (merge 'vector x y #'<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.7 (let ((x (vector 1 3 7 8 10)) - (y (vector 2 4 5 8 11))) + (y (vector 2 4 5 8 11))) (merge 'vector x y #'<)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.8 (let ((x (sort (list 1 3 7 8 10) #'>)) - (y (sort (list 2 4 5 8 11) #'>))) + (y (sort (list 2 4 5 8 11) #'>))) (merge 'vector x y #'< :key #'-)) #(11 10 8 8 7 5 4 3 2 1)) (deftest merge-vector.9 (let ((x (list 1 3 7 8 10)) - (y (list 2 4 5 8 11))) + (y (list 2 4 5 8 11))) (merge 'vector x y #'< :key nil)) #(1 2 3 4 5 7 8 8 10 11)) (deftest merge-vector.10 (let ((x (list 1 3 7 8 10)) - (y (list 2 4 5 8 11))) + (y (list 2 4 5 8 11))) (merge 'vector x y '<)) #(1 2 3 4 5 7 8 8 10 11)) @@ -175,22 +175,22 @@ (deftest merge-vector.16 (let ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) - :fill-pointer 5)) - (y (list 1 6 10))) + :fill-pointer 5)) + (y (list 1 6 10))) (merge 'vector x y #'<)) #(1 2 5 6 8 9 10 11)) (deftest merge-vector.16a (let ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) - :fill-pointer 5)) - (y (list 1 6 10))) + :fill-pointer 5)) + (y (list 1 6 10))) (merge 'vector y x #'<)) #(1 2 5 6 8 9 10 11)) (deftest merge-vector.17 (let* ((x (make-array '(10) :initial-contents '(2 5 8 9 11 12 14 15 18 30) - :fill-pointer 5)) - (result (merge 'vector x () #'<))) + :fill-pointer 5)) + (result (merge 'vector x () #'<))) (values (array-element-type result) result)) @@ -229,43 +229,43 @@ (deftest merge-string.1 (let ((x (list #\1 #\3 #\7 #\8)) - (y (list #\2 #\4 #\5 #\9))) + (y (list #\2 #\4 #\5 #\9))) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1a (let ((x (copy-seq "1378")) - (y (list #\2 #\4 #\5 #\9))) + (y (list #\2 #\4 #\5 #\9))) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1b (let ((x (list #\1 #\3 #\7 #\8)) - (y (copy-seq "2459"))) + (y (copy-seq "2459"))) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1c (let ((x (copy-seq "1378")) - (y (copy-seq "2459"))) + (y (copy-seq "2459"))) (merge 'string x y #'char<)) "12345789") (deftest merge-string.1d (let ((x (copy-seq "1378")) - (y (copy-seq "2459"))) + (y (copy-seq "2459"))) (merge 'string y x #'char<)) "12345789") (deftest merge-string.2 (let ((x nil) - (y (list #\2 #\4 #\5 #\9))) + (y (list #\2 #\4 #\5 #\9))) (merge 'string x y #'char<)) "2459") (deftest merge-string.3 (let ((x nil) - (y (list #\2 #\4 #\5 #\9))) + (y (list #\2 #\4 #\5 #\9))) (merge 'string y x #'char<)) "2459") @@ -275,19 +275,19 @@ (deftest merge-string.8 (let ((x (list #\1 #\3 #\7 #\8)) - (y (list #\2 #\4 #\5))) + (y (list #\2 #\4 #\5))) (merge 'string x y #'char< :key #'nextdigit)) "1234578") - + (deftest merge-string.9 (let ((x (list #\1 #\3 #\7 #\8)) - (y (list #\2 #\4 #\5 #\9))) + (y (list #\2 #\4 #\5 #\9))) (merge 'string x y #'char< :key nil)) "12345789") (deftest merge-string.10 (let ((x (list #\1 #\3 #\7 #\8)) - (y (list #\2 #\4 #\5 #\9))) + (y (list #\2 #\4 #\5 #\9))) (merge 'string x y 'char<)) "12345789") @@ -323,27 +323,27 @@ (deftest merge-string.15 (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" - :fill-pointer 5 :element-type 'character)) - (y (copy-seq "bci"))) + :fill-pointer 5 :element-type 'character)) + (y (copy-seq "bci"))) (merge 'string x y #'char<)) "abcdgikm") (deftest merge-string.16 (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" - :fill-pointer 5 :element-type 'character)) - (y (copy-seq "bci"))) + :fill-pointer 5 :element-type 'character)) + (y (copy-seq "bci"))) (merge 'string y x #'char<)) "abcdgikm") (deftest merge-string.17 (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" - :fill-pointer 5 :element-type 'character))) + :fill-pointer 5 :element-type 'character))) (merge 'string nil x #'char<)) "adgkm") (deftest merge-string.18 (let* ((x (make-array '(10) :initial-contents "adgkmpruwv" - :fill-pointer 5 :element-type 'character))) + :fill-pointer 5 :element-type 'character))) (merge 'string x nil #'char<)) "adgkm") @@ -430,19 +430,19 @@ (deftest merge-bit-vector.1 (let ((x (list 0 0 1 1 1)) - (y (list 0 0 0 1 1))) + (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.2 (let ((x nil) - (y (list 0 0 0 1 1))) + (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*00011) (deftest merge-bit-vector.3 (let ((x nil) - (y (list 0 0 0 1 1))) + (y (list 0 0 0 1 1))) (merge 'bit-vector y x #'<)) #*00011) @@ -452,67 +452,67 @@ (deftest merge-bit-vector.5 (let ((x (vector 0 0 1 1 1)) - (y (list 0 0 0 1 1))) + (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5a (let ((x (copy-seq #*00111)) - (y (list 0 0 0 1 1))) + (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5b (let ((x (list 0 0 1 1 1)) - (y (copy-seq #*00011))) + (y (copy-seq #*00011))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5c (let ((x (copy-seq #*00111)) - (y (copy-seq #*00011))) + (y (copy-seq #*00011))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5d (let ((x (copy-seq #*11111)) - (y (copy-seq #*00000))) + (y (copy-seq #*00000))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.5e (let ((x (copy-seq #*11111)) - (y (copy-seq #*00000))) + (y (copy-seq #*00000))) (merge 'bit-vector y x #'<)) #*0000011111) (deftest merge-bit-vector.6 (let ((x (list 0 0 1 1 1)) - (y (vector 0 0 0 1 1))) + (y (vector 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.7 (let ((x (vector 0 0 1 1 1)) - (y (vector 0 0 0 1 1))) + (y (vector 0 0 0 1 1))) (merge 'bit-vector x y #'<)) #*0000011111) (deftest merge-bit-vector.8 (let ((x (list 1 1 1 0 0)) - (y (list 1 1 0 0 0))) + (y (list 1 1 0 0 0))) (merge 'bit-vector x y #'< :key #'-)) #*1111100000) (deftest merge-bit-vector.9 (let ((x (list 0 0 1 1 1)) - (y (list 0 0 0 1 1))) + (y (list 0 0 0 1 1))) (merge 'bit-vector x y #'< :key nil)) #*0000011111) (deftest merge-bit-vector.10 (let ((x (list 0 0 1 1 1)) - (y (list 0 0 0 1 1))) + (y (list 0 0 0 1 1))) (merge 'bit-vector x y '<)) #*0000011111) @@ -525,7 +525,7 @@ (let ((x (copy-seq #*)) (y (copy-seq #*011))) (merge 'bit-vector x y #'<)) #*011) - + (deftest merge-bit-vector.13 (let ((x (copy-seq #*)) (y (list 0 1 1))) (merge 'bit-vector x y #'<)) @@ -543,27 +543,27 @@ (deftest merge-bit-vector.16 (let* ((x (make-array '(10) :initial-contents #*0001101010 - :fill-pointer 5 :element-type 'bit)) - (y (copy-seq #*001))) + :fill-pointer 5 :element-type 'bit)) + (y (copy-seq #*001))) (merge 'bit-vector x y #'<)) #*00000111) (deftest merge-bit-vector.17 (let* ((x (make-array '(10) :initial-contents #*0001101010 - :fill-pointer 5 :element-type 'bit)) - (y (copy-seq #*001))) + :fill-pointer 5 :element-type 'bit)) + (y (copy-seq #*001))) (merge 'bit-vector y x #'<)) #*00000111) (deftest merge-bit-vector.18 (let* ((x (make-array '(10) :initial-contents #*0001101010 - :fill-pointer 5 :element-type 'bit))) + :fill-pointer 5 :element-type 'bit))) (merge 'bit-vector nil x #'<)) #*00011) (deftest merge-bit-vector.19 (let* ((x (make-array '(10) :initial-contents #*0001101010 - :fill-pointer 5 :element-type 'bit))) + :fill-pointer 5 :element-type 'bit))) (merge 'bit-vector x nil #'<)) #*00011) @@ -585,7 +585,7 @@ (deftest merge-vector-length.1 (merge '(vector * 6) (list 1 2 3) (list 4 5 6) #'<) #(1 2 3 4 5 6)) - + (deftest merge-bit-vector-length.1 (merge '(bit-vector 6) (list 0 1 1) (list 0 0 1) #'<) #*000111) @@ -596,44 +596,44 @@ (let ((i 0) a b c d) (values (merge (progn (setf a (incf i)) 'list) - (progn (setf b (incf i)) (list 2 5 6)) - (progn (setf c (incf i)) (list 1 3 4)) - (progn (setf d (incf i)) #'<)) + (progn (setf b (incf i)) (list 2 5 6)) + (progn (setf c (incf i)) (list 1 3 4)) + (progn (setf d (incf i)) #'<)) i a b c d)) (1 2 3 4 5 6) 4 1 2 3 4) - + ;;; Tests of error situations (deftest merge.error.1 (handler-case (eval - '(locally (declare (optimize safety)) - (merge 'symbol (list 1 2 3) (list 4 5 6) #'<))) - (error () :caught)) + '(locally (declare (optimize safety)) + (merge 'symbol (list 1 2 3) (list 4 5 6) #'<))) + (error () :caught)) :caught) (deftest merge.error.2 (signals-error (merge '(vector * 3) (list 1 2 3) (list 4 5 6) #'<) - type-error) + type-error) t) (deftest merge.error.3 (signals-error (merge '(bit-vector 3) (list 0 0 0) (list 1 1 1) #'<) - type-error) + type-error) t) (deftest merge.error.4 (signals-error (merge '(vector * 7) (list 1 2 3) (list 4 5 6) #'<) - type-error) + type-error) t) (deftest merge.error.5 (signals-error (merge '(bit-vector 7) (list 0 0 0) (list 1 1 1) #'<) - type-error) + type-error) t) (deftest merge.error.6 (signals-error (merge 'null (list 1 2 3) (list 4 5 6) #'<) - type-error) + type-error) t) (deftest merge.error.7 @@ -650,43 +650,43 @@ (deftest merge.error.10 (signals-error (merge 'list (list 2 4 6) (list 1 3 5)) - program-error) + program-error) t) (deftest merge.error.11 (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t) - program-error) + program-error) t) (deftest merge.error.12 (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :key) - program-error) + program-error) t) (deftest merge.error.13 (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< :bad t - :allow-other-keys nil) - program-error) + :allow-other-keys nil) + program-error) t) (deftest merge.error.14 (signals-error (merge 'list (list 2 4 6) (list 1 3 5) #'< 1 2) - program-error) + program-error) t) (deftest merge.error.15 (signals-error (locally (merge '(vector * 3) (list 1 2 3) - (list 4 5 6) #'<) - t) - type-error) - t) + (list 4 5 6) #'<) + t) + type-error) + t) (deftest merge.error.16 (signals-error (merge 'list (list 1 2) (list 3 4) #'car) - program-error) + program-error) t) (deftest merge.error.17 (signals-error (merge 'list (list 'a 'b) (list 3 4) #'max) - type-error) + type-error) t) diff --git a/ansi-tests/min.lsp b/ansi-tests/min.lsp index 5b42fc2c..e5a88dfc 100644 --- a/ansi-tests/min.lsp +++ b/ansi-tests/min.lsp @@ -21,14 +21,14 @@ (deftest min.1 (loop for n in *reals* - when (or (not (eql (min n) n)) - (not (eql (min n n) n)) - (not (eql (min n n n) n)) - (not (eql (apply #'min (make-list - (min 256 (1- call-arguments-limit)) - :initial-element n)) - n))) - collect n) + when (or (not (eql (min n) n)) + (not (eql (min n n) n)) + (not (eql (min n n n) n)) + (not (eql (apply #'min (make-list + (min 256 (1- call-arguments-limit)) + :initial-element n)) + n))) + collect n) nil) (deftest min.2 @@ -37,38 +37,38 @@ (deftest min.3 (loop for x = (- (random 60000) 30000) - for y = (- (random 60000) 30000) - for m = (min x y) - for m2 = (if (<= x y) x y) - repeat 1000 - unless (eql m m2) - collect (list x y m m2)) + for y = (- (random 60000) 30000) + for m = (min x y) + for m2 = (if (<= x y) x y) + repeat 1000 + unless (eql m m2) + collect (list x y m m2)) nil) (deftest min.4 (loop for x = (- (random 6000000) 3000000) - for y = (- (random 6000000) 3000000) - for m = (min x y) - for m2 = (if (<= x y) x y) - repeat 1000 - unless (eql m m2) - collect (list x y m m2)) + for y = (- (random 6000000) 3000000) + for m = (min x y) + for m2 = (if (<= x y) x y) + repeat 1000 + unless (eql m m2) + collect (list x y m m2)) nil) (deftest min.5 (loop for x = (- (random 1000000000000) 500000000000) - for y = (- (random 1000000000000) 500000000000) - for m = (min x y) - for m2 = (if (<= x y) x y) - repeat 1000 - unless (eql m m2) - collect (list x y m m2)) + for y = (- (random 1000000000000) 500000000000) + for m = (min x y) + for m2 = (if (<= x y) x y) + repeat 1000 + unless (eql m m2) + collect (list x y m m2)) nil) (deftest min.6 (let ((m (min 0 1.0s0))) (or (eqlt m 0) - (eqlt m 0.0s0))) + (eqlt m 0.0s0))) t) (deftest min.7 @@ -78,7 +78,7 @@ (deftest min.8 (let ((m (min 2 3.0f0))) (or (eqlt m 2) - (eqlt m 2.0f0))) + (eqlt m 2.0f0))) t) (deftest min.9 @@ -88,7 +88,7 @@ (deftest min.10 (let ((m (min 2 10.0d0))) (or (eqlt m 2) - (eqlt m 2.0d0))) + (eqlt m 2.0d0))) t) (deftest min.11 @@ -98,7 +98,7 @@ (deftest min.12 (let ((m (min 2 17.25l0))) (or (eqlt m 2) - (eqlt m 2.0l0))) + (eqlt m 2.0l0))) t) (deftest min.13 @@ -108,7 +108,7 @@ (deftest min.15 (let ((m (min 1.0s0 2.0f0))) (or (eqlt m 1.0s0) - (eqlt m 1.0f0))) + (eqlt m 1.0f0))) t) (deftest min.16 @@ -118,7 +118,7 @@ (deftest min.17 (let ((m (min 1.0s0 2.0d0))) (or (eqlt m 1.0s0) - (eqlt m 1.0d0))) + (eqlt m 1.0d0))) t) (deftest min.18 @@ -128,7 +128,7 @@ (deftest min.19 (let ((m (min 1.0s0 2.0l0))) (or (eqlt m 1.0s0) - (eqlt m 1.0l0))) + (eqlt m 1.0l0))) t) (deftest min.20 @@ -138,7 +138,7 @@ (deftest min.21 (let ((m (min 1.0f0 2.0d0))) (or (eqlt m 1.0f0) - (eqlt m 1.0d0))) + (eqlt m 1.0d0))) t) (deftest min.22 @@ -148,7 +148,7 @@ (deftest min.23 (let ((m (min 1.0f0 100.0l0))) (or (eqlt m 1.0f0) - (eqlt m 1.0l0))) + (eqlt m 1.0l0))) t) (deftest min.24 @@ -158,7 +158,7 @@ (deftest min.25 (let ((m (min 1.0d0 12.0l0))) (or (eqlt m 1.0d0) - (eqlt m 1.0l0))) + (eqlt m 1.0l0))) t) (deftest min.26 @@ -167,59 +167,59 @@ (deftest min.27 (loop for i from 1 to (min 256 (1- call-arguments-limit)) - for x = (make-list i :initial-element 1) - do (setf (elt x (random i)) 0) - unless (eql (apply #'min x) 0) - collect x) + for x = (make-list i :initial-element 1) + do (setf (elt x (random i)) 0) + unless (eql (apply #'min x) 0) + collect x) nil) (deftest min.28 (let ((m (min 1/3 0.8s0))) (or (eqlt m 1/3) - (eqlt m (float 1/3 0.8s0)))) + (eqlt m (float 1/3 0.8s0)))) t) (deftest min.29 (let ((m (min 1.0s0 -3 2.0f0))) (or (eqlt m -3) - (eqlt m -3.0f0))) + (eqlt m -3.0f0))) t) (deftest min.30 (let ((m (min 1.0d0 -3 2.0f0))) (or (eqlt m -3) - (eqlt m -3.0d0))) + (eqlt m -3.0d0))) t) (deftest min.31 (let ((m (min 1.0s0 -3 2.0l0))) (or (eqlt m -3) - (eqlt m -3.0l0))) + (eqlt m -3.0l0))) t) (deftest min.32 (let ((m (min 1.0l0 -3 2.0s0))) (or (eqlt m -3) - (eqlt m -3.0l0))) + (eqlt m -3.0l0))) t) (deftest min.33 (let ((m (min 1.0d0 -3 2.0l0))) (or (eqlt m -3) - (eqlt m -3.0l0))) + (eqlt m -3.0l0))) t) (deftest min.34 (let ((m (min 1.0l0 -3 2.0d0))) (or (eqlt m -3) - (eqlt m -3.0l0))) + (eqlt m -3.0l0))) t) (deftest min.order.1 (let ((i 0) x y) (values (min (progn (setf x (incf i)) 10) - (progn (setf y (incf i)) 20)) + (progn (setf y (incf i)) 20)) i x y)) 10 2 1 2) @@ -227,8 +227,8 @@ (let ((i 0) x y z) (values (min (progn (setf x (incf i)) 10) - (progn (setf y (incf i)) 20) - (progn (setf z (incf i)) 30)) + (progn (setf y (incf i)) 20) + (progn (setf z (incf i)) 30)) i x y z)) 10 3 1 2 3) @@ -236,10 +236,10 @@ (let ((i 0) u v w x y z) (values (min (progn (setf u (incf i)) 10) - (progn (setf v (incf i)) 20) - (progn (setf w (incf i)) 30) - (progn (setf x (incf i)) 10) - (progn (setf y (incf i)) 20) - (progn (setf z (incf i)) 30)) + (progn (setf v (incf i)) 20) + (progn (setf w (incf i)) 30) + (progn (setf x (incf i)) 10) + (progn (setf y (incf i)) 20) + (progn (setf z (incf i)) 30)) i u v w x y z)) 10 6 1 2 3 4 5 6) diff --git a/ansi-tests/minus.lsp b/ansi-tests/minus.lsp index 70cb2ce0..865b2625 100644 --- a/ansi-tests/minus.lsp +++ b/ansi-tests/minus.lsp @@ -14,84 +14,84 @@ ;;; Unary minus tests (deftest minus.1 (loop for x in *numbers* - unless (eql (- (- x)) x) - collect x) + unless (eql (- (- x)) x) + collect x) nil) (deftest minus.2 (locally (declare (notinline -)) (loop for x in *numbers* - unless (eql (- (- x)) x) - collect x)) + unless (eql (- (- x)) x) + collect x)) nil) (deftest minus.3 (loop for x in *reals* - when (and (integerp x) - (not (eql (- x) (- 0 x)))) - collect x) + when (and (integerp x) + (not (eql (- x) (- 0 x)))) + collect x) nil) (deftest minus.4 (loop for x in *reals* - for neg = (- x) - when (and (floatp x) - (not (zerop x)) - (not (eql neg (- 0.0s0 x))) - (eql (float 1.0s0 x) - (float 1.0s0 neg))) - collect x) + for neg = (- x) + when (and (floatp x) + (not (zerop x)) + (not (eql neg (- 0.0s0 x))) + (eql (float 1.0s0 x) + (float 1.0s0 neg))) + collect x) nil) (deftest minus.5 (loop for x in *numbers* - when (and (complexp x) - (rationalp (realpart x)) - (not (eql (- x) (- 0 x)))) - collect x) + when (and (complexp x) + (rationalp (realpart x)) + (not (eql (- x) (- 0 x)))) + collect x) nil) (deftest minus.6 (loop for x in *numbers* - for neg = (- x) - when (and (complexp x) - (floatp (realpart x)) - (eql (float 1.0s0 (realpart x)) - (float 1.0s0 (realpart neg))) - (or (/= neg (- 0 x)) - (and (not (zerop (realpart x))) - (not (eqlzt neg (- 0 x)))))) - collect x) + for neg = (- x) + when (and (complexp x) + (floatp (realpart x)) + (eql (float 1.0s0 (realpart x)) + (float 1.0s0 (realpart neg))) + (or (/= neg (- 0 x)) + (and (not (zerop (realpart x))) + (not (eqlzt neg (- 0 x)))))) + collect x) nil) (deftest minus.7 (let ((upper-bound most-positive-fixnum) - (lower-bound most-negative-fixnum)) + (lower-bound most-negative-fixnum)) (loop for x = (+ (random (- upper-bound lower-bound)) lower-bound) for neg = (- x) repeat 1000 - unless (and (integerp neg) - (eql (abs x) (abs neg)) - (if (> x 0) (< neg 0) (>= neg 0)) - (zerop (+ x neg)) - (eql x (- neg))) + unless (and (integerp neg) + (eql (abs x) (abs neg)) + (if (> x 0) (< neg 0) (>= neg 0)) + (zerop (+ x neg)) + (eql x (- neg))) collect x)) nil) (deftest minus.8 (let ((upper-bound (ash 1 1000)) - (lower-bound (- (ash 1 1000)))) + (lower-bound (- (ash 1 1000)))) (loop for x = (+ (random (- upper-bound lower-bound)) lower-bound) for neg = (- x) repeat 1000 unless (and (integerp neg) - (eql (abs x) (abs neg)) - (if (> x 0) (< neg 0) (>= neg 0)) - (zerop (+ x neg)) - (eql x (- neg))) + (eql (abs x) (abs neg)) + (if (> x 0) (< neg 0) (>= neg 0)) + (zerop (+ x neg)) + (eql x (- neg))) collect x)) nil) @@ -110,8 +110,8 @@ for y = (random-fixnum) repeat 1000 unless (and (eql (+ x (- y)) (- x y)) - (eql (+ 1 x (- y)) (- x (1- y))) - (eql (+ -1 x (- y)) (- x (1+ y)))) + (eql (+ 1 x (- y)) (- x (1- y))) + (eql (+ -1 x (- y)) (- x (1+ y)))) collect (list x y)) nil) @@ -122,16 +122,16 @@ for y = (random-from-interval bound (- bound)) repeat 1000 unless (and (eql (+ x (- y)) (- x y)) - (eql (+ 1 x (- y)) (- x (1- y))) - (eql (+ -1 x (- y)) (- x (1+ y)))) + (eql (+ 1 x (- y)) (- x (1- y))) + (eql (+ -1 x (- y)) (- x (1+ y)))) collect (list x y))) nil) (deftest subtract.3 (let ((args nil)) (loop for i from 1 below (min 256 (1- call-arguments-limit)) - do (push 1 args) - always (eql (apply #'- 1000 args) (- 1000 i)))) + do (push 1 args) + always (eql (apply #'- 1000 args) (- 1000 i)))) t) ;;; Float contagion @@ -144,41 +144,41 @@ for c1 from 1 nconc (loop for type2 in '(short-float single-float double-float long-float) - for bits2 in '(13 24 50 50) - for bound2 = (ash 1 (- bits2 2)) - for c2 from 1 - nconc - (loop - for i = (random-from-interval bound1) - for x = (coerce i type1) - for j = (random-from-interval bound2) - for y = (coerce j type2) - for idiff1 = (- i j) - for idiff2 = (- j i) - for diff1 = (- x y) - for diff2 = (- y x) - repeat 1000 - unless (or (zerop idiff1) - (and (eql idiff1 (- idiff2)) - (eql diff1 (- diff2)) - (if (<= c1 c2) - (eql (float diff1 y) diff1) - (eql (float diff1 x) diff1)) - (eql (float idiff1 diff1) diff1))) - collect (list i x j y idiff1 idiff2 diff1 diff2)))) + for bits2 in '(13 24 50 50) + for bound2 = (ash 1 (- bits2 2)) + for c2 from 1 + nconc + (loop + for i = (random-from-interval bound1) + for x = (coerce i type1) + for j = (random-from-interval bound2) + for y = (coerce j type2) + for idiff1 = (- i j) + for idiff2 = (- j i) + for diff1 = (- x y) + for diff2 = (- y x) + repeat 1000 + unless (or (zerop idiff1) + (and (eql idiff1 (- idiff2)) + (eql diff1 (- diff2)) + (if (<= c1 c2) + (eql (float diff1 y) diff1) + (eql (float diff1 x) diff1)) + (eql (float idiff1 diff1) diff1))) + collect (list i x j y idiff1 idiff2 diff1 diff2)))) nil) ;;; Complex subtraction (deftest subtract.5 (loop for i = (random-fixnum) - for ci = (complex i (+ i 100)) - for j = (random-fixnum) - for cj = (complex j (- j 200)) - for diff = (- ci cj) - repeat 1000 - unless (eql diff (complex (- i j) (+ (- i j) 300))) - collect (list i ci j cj (- ci cj))) + for ci = (complex i (+ i 100)) + for j = (random-fixnum) + for cj = (complex j (- j 200)) + for diff = (- ci cj) + repeat 1000 + unless (eql diff (complex (- i j) (+ (- i j) 300))) + collect (list i ci j cj (- ci cj))) nil) ;;; Test that explicit calls to macroexpand in subforms @@ -186,9 +186,9 @@ (deftest subtract.6 (macrolet ((%m (z) z)) - (values - (- (expand-in-current-env (%m 2)) 1) - (- 17 (expand-in-current-env (%m 5))) - (- 1/2 (expand-in-current-env (%m 1/6)) - (expand-in-current-env (%m 0))))) + (values + (- (expand-in-current-env (%m 2)) 1) + (- 17 (expand-in-current-env (%m 5))) + (- 1/2 (expand-in-current-env (%m 1/6)) + (expand-in-current-env (%m 0))))) 1 12 1/3) diff --git a/ansi-tests/minusp.lsp b/ansi-tests/minusp.lsp index af6421db..7a0c78cf 100644 --- a/ansi-tests/minusp.lsp +++ b/ansi-tests/minusp.lsp @@ -35,8 +35,8 @@ (deftest minusp.4 (loop for x in *reals* - when (if (minusp x) (>= x 0) (< x 0)) - collect x) + when (if (minusp x) (>= x 0) (< x 0)) + collect x) nil) (deftest minusp.5 @@ -45,16 +45,16 @@ (deftest minusp.6 (remove-if #'minusp - (list least-negative-short-float - least-negative-normalized-short-float - least-negative-single-float - least-negative-normalized-single-float - least-negative-double-float - least-negative-normalized-double-float - least-negative-long-float - least-negative-normalized-long-float - most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float)) + (list least-negative-short-float + least-negative-normalized-short-float + least-negative-single-float + least-negative-normalized-single-float + least-negative-double-float + least-negative-normalized-double-float + least-negative-long-float + least-negative-normalized-long-float + most-negative-short-float + most-negative-single-float + most-negative-double-float + most-negative-long-float)) nil) diff --git a/ansi-tests/misc-cmucl-type-prop.lsp b/ansi-tests/misc-cmucl-type-prop.lsp index 48016b5b..a5fbb1d9 100644 --- a/ansi-tests/misc-cmucl-type-prop.lsp +++ b/ansi-tests/misc-cmucl-type-prop.lsp @@ -16,7 +16,7 @@ nil '(lambda (p1) (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) - (type (member 2 -4 -211907662 -27215198) p1)) + (type (member 2 -4 -211907662 -27215198) p1)) (logand (the (integer * 161212781) p1) 10600829))) -27215198) 2129952) @@ -28,7 +28,7 @@ nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) - (type (integer 1619851121 1619868587) p1) (type (integer * 303689) p2)) + (type (integer 1619851121 1619868587) p1) (type (integer * 303689) p2)) (logandc2 (the (integer -5359291650 1619851136) p1) (the unsigned-byte p2)))) 1619851124 300065) 1619551060) @@ -40,7 +40,7 @@ nil '(lambda (p1) (declare (optimize (speed 2) (safety 3) (debug 0) (space 3)) - (type (integer 59087 63964) p1)) + (type (integer 59087 63964) p1)) (logior p1 -65887623))) 59967) -65869185) @@ -52,7 +52,7 @@ nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 2) (debug 0) (space 3)) - (type (integer 3585942 72924743) p1) (type (integer -70689 *) p2)) + (type (integer 3585942 72924743) p1) (type (integer -70689 *) p2)) (logorc2 (the (integer * 8514860) p1) (the (integer 1 411) p2)))) 3586455 4) -1) @@ -64,7 +64,7 @@ nil '(lambda (p2) (declare (optimize (speed 2) (safety 1) (debug 2) (space 3)) - (type (integer -257 *) p2)) + (type (integer -257 *) p2)) (lognand 1020158769 (the (integer -5275217 2381998) p2)))) 2) -1) @@ -76,7 +76,7 @@ nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) - (type (integer -96413017 -96297711) p1)) + (type (integer -96413017 -96297711) p1)) (lognand p1 3472289945))) -96413016) -3393245321) @@ -88,8 +88,8 @@ nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) - (type (integer 438294 891242) p1) - (type (member 16317 -15 -541332155 33554427) p2)) + (type (integer 438294 891242) p1) + (type (member 16317 -15 -541332155 33554427) p2)) (logand (the (integer -33116139 1759877902) p1) p2))) 438295 16317) 12309) @@ -101,7 +101,7 @@ nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) - (type (integer -728025757 -727856169) p1)) + (type (integer -728025757 -727856169) p1)) (logorc1 (the (integer -734005577 -727855553) p1) -3311))) -727856176) -2241) @@ -113,9 +113,9 @@ nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) - (type (integer * 1489068) p1) (type (integer -7455 *) p2)) + (type (integer * 1489068) p1) (type (integer -7455 *) p2)) (logeqv (the (member 9543 -15 32766 -264472) p1) - (the (integer -524303 11182721) p2)))) + (the (integer -524303 11182721) p2)))) 9543 -8) 9536) @@ -126,7 +126,7 @@ nil '(lambda (p1 p2) (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) - (type (integer -616605365 -616598658) p1) (type (eql 499113) p2)) + (type (integer -616605365 -616598658) p1) (type (eql 499113) p2)) (logeqv (the real p1) p2))) -616604953 499113) 617035953) @@ -138,7 +138,7 @@ nil '(lambda (p1) (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) - (type (integer -112225610 *) p1)) + (type (integer -112225610 *) p1)) (logeqv (the (integer -2822315666 3) p1) 1679389))) 1) -1679389) @@ -150,7 +150,7 @@ nil '(lambda (p2) (declare (optimize (speed 2) (safety 3) (debug 0) (space 3)) - (type (integer -67 268435455) p2)) + (type (integer -67 268435455) p2)) (logeqv 1038360149 (the (integer -3605943309) p2)))) -1) 1038360149) @@ -163,9 +163,9 @@ (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) - (type (eql 64848.973) p1)) - (- (the (eql 64848.973f0) p1) -2808/1031))) + (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) + (type (eql 64848.973) p1)) + (- (the (eql 64848.973f0) p1) -2808/1031))) 64848.973f0) 'single-float)) t) @@ -178,9 +178,9 @@ (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) - (type (integer 9297 *) p2)) - (- 54090.82691488265d0 (the (integer * 1263530808) p2)))) + (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) + (type (integer 9297 *) p2)) + (- 54090.82691488265d0 (the (integer * 1263530808) p2)))) 9590) 'double-float)) t) @@ -193,20 +193,20 @@ (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) - (type (eql 328536/53893) p1)) - (- p1 59218.633f0))) + (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) + (type (eql 328536/53893) p1)) + (- p1 59218.633f0))) 328536/53893) 'single-float)) t) -; X86::FAST--/FIXNUM=>FIXNUM +; X86::FAST--/FIXNUM=>FIXNUM (deftest cmucl-type-prop.16 (funcall (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 2) (debug 3) (space 3)) - (type (integer -605782 -28141) p2)) - (- -61118 p2))) + (declare (optimize (speed 2) (safety 2) (debug 3) (space 3)) + (type (integer -605782 -28141) p2)) + (- -61118 p2))) -28225) -32893) @@ -214,9 +214,9 @@ (deftest cmucl-type-prop.17 (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) - (type (integer 5535202) p1)) - (- (the (integer * 27858177) p1) 405))) + (declare (optimize (speed 2) (safety 1) (debug 1) (space 3)) + (type (integer 5535202) p1)) + (- (the (integer * 27858177) p1) 405))) 5535436) 5535031) @@ -224,9 +224,9 @@ (deftest cmucl-type-prop.18 (funcall (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) - (type (integer -1175231414 -3471291) p2)) - (- -440 p2))) + (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) + (type (integer -1175231414 -3471291) p2)) + (- -440 p2))) -3536832) 3536392) @@ -234,127 +234,127 @@ (deftest cmucl-type-prop.19 (funcall (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) - (type (integer -1015240116 5) p2)) - (+ 491841 (the unsigned-byte p2)))) + (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) + (type (integer -1015240116 5) p2)) + (+ 491841 (the unsigned-byte p2)))) 0) 491841) ; X86::+/DOUBLE-FLOAT (deftest cmucl-type-prop.20 (notnot (typep (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) - (type (rational -1255531/68466 4) p1)) - (+ p1 41888.98682005542d0))) - -1255531/68466) - 'double-float)) + (declare (optimize (speed 2) (safety 3) (debug 3) (space 3)) + (type (rational -1255531/68466 4) p1)) + (+ p1 41888.98682005542d0))) + -1255531/68466) + 'double-float)) t) ; X86::+/SINGLE-FLOAT (deftest cmucl-type-prop.21 (notnot (typep (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) - (type (integer -284887911 *) p1)) - (+ (the (integer -50006902 19512639861) p1) 68648.28f0))) - -16452463) - 'single-float)) + (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) + (type (integer -284887911 *) p1)) + (+ (the (integer -50006902 19512639861) p1) 68648.28f0))) + -16452463) + 'single-float)) t) ; X86::=0/DOUBLE-FLOAT (deftest cmucl-type-prop.22 (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 3) (debug 1) (space 3)) - (type (complex double-float) p1)) - (= p1 -1590311/896933))) - #c(1.0d0 1.0d0)) + (declare (optimize (speed 2) (safety 3) (debug 1) (space 3)) + (type (complex double-float) p1)) + (= p1 -1590311/896933))) + #c(1.0d0 1.0d0)) nil) ; X86::=/SINGLE-FLOAT (deftest cmucl-type-prop.23 (funcall (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) - (type (complex single-float) p2)) - (= -976855 (the (eql #c(-57420.04 806984.0)) p2)))) - #c(-57420.04f0 806984.0f0)) + (declare (optimize (speed 2) (safety 2) (debug 1) (space 3)) + (type (complex single-float) p2)) + (= -976855 (the (eql #c(-57420.04 806984.0)) p2)))) + #c(-57420.04f0 806984.0f0)) nil) ; X86::FAST-EQL/FIXNUM (deftest cmucl-type-prop.24 (notnot (funcall (compile nil '(lambda (p1 p2) - (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) - (type (integer -3705845 488458) p1) (type (integer * 869076010) p2)) - (/= p1 (the (integer -69832764 470) p2)))) - 488456 465)) + (declare (optimize (speed 2) (safety 1) (debug 3) (space 3)) + (type (integer -3705845 488458) p1) (type (integer * 869076010) p2)) + (/= p1 (the (integer -69832764 470) p2)))) + 488456 465)) t) ; X86::FAST-EQL-C/FIXNUM (deftest cmucl-type-prop.25 (notnot (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) - (type (integer -69741922) p1)) - (/= (the (integer * 216) p1) 182))) - 103)) + (declare (optimize (speed 2) (safety 3) (debug 2) (space 3)) + (type (integer -69741922) p1)) + (/= (the (integer * 216) p1) 182))) + 103)) t) ; X86::FAST-IF->-C/FIXNUM (deftest cmucl-type-prop.26 (funcall (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 2) (debug 3) (space 3)) - (type (integer -451 204073899) p2)) - (< 134799 (the (integer -56 8589934581) p2)))) - -2) + (declare (optimize (speed 2) (safety 2) (debug 3) (space 3)) + (type (integer -451 204073899) p2)) + (< 134799 (the (integer -56 8589934581) p2)))) + -2) nil) ; X86::FAST-IF-<-C/FIXNUM (deftest cmucl-type-prop.27 (funcall (compile nil '(lambda (p2) - (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) - (type (integer -93662 *) p2)) - (<= -1 (the (integer -2975848 16770677) p2)))) - -6548) + (declare (optimize (speed 2) (safety 2) (debug 2) (space 3)) + (type (integer -93662 *) p2)) + (<= -1 (the (integer -2975848 16770677) p2)))) + -6548) nil) ; X86::FAST-+-C/FIXNUM=>FIXNUM ; (simple example) (deftest cmucl-type-prop.28 (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) - (type (integer -65545 80818) p1)) - (1+ p1))) - -1) + (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) + (type (integer -65545 80818) p1)) + (1+ p1))) + -1) 0) ; X86::FAST-NEGATE/FIXNUM (deftest cmucl-type-prop.29 (funcall (compile nil '(lambda (p1) - (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) - (type (integer -4194320 11531) p1)) - (- (the (integer -6253866924 34530147) p1)))) - -20) + (declare (optimize (speed 2) (safety 1) (debug 0) (space 3)) + (type (integer -4194320 11531) p1)) + (- (the (integer -6253866924 34530147) p1)))) + -20) 20) ;;; Bug in COPY-SEQ (deftest cmucl-type-prop.30 (let ((a (funcall - (compile nil `(lambda () - (declare (optimize (speed 2) (safety 2) (debug 0) (space 2))) - (copy-seq - ,(make-array '(0) :adjustable t))))))) + (compile nil `(lambda () + (declare (optimize (speed 2) (safety 2) (debug 0) (space 2))) + (copy-seq + ,(make-array '(0) :adjustable t))))))) (and (not (adjustable-array-p a)) - (= (length a) 0) - t)) + (= (length a) 0) + t)) t) ; Bug for PACKAGEP (deftest cmucl-type-prop.31 (funcall (compile nil '(lambda (x) - (declare (optimize (speed 2) (space 3))) - (packagep x))) - t) + (declare (optimize (speed 2) (space 3))) + (packagep x))) + t) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -370,7 +370,7 @@ nil '(lambda (p4) (declare (optimize (speed 1) (safety 1) (debug 1) (space 0)) - (type (integer -2040 9) p4)) + (type (integer -2040 9) p4)) (string< "bbaa" "" :start1 p4))) 2) nil) @@ -382,7 +382,7 @@ nil '(lambda (p4) (declare (optimize (speed 0) (safety 0) (debug 2) (space 0)) - (type (integer -52340 *) p4)) + (type (integer -52340 *) p4)) (string< "baabbb" "bb" :start2 p4))) 1) nil) @@ -394,10 +394,10 @@ nil '(lambda (p1 p4) (declare (optimize (speed 2) (safety 0) (debug 3) (space 0)) - (type (simple-string) p1) (type real p4)) + (type (simple-string) p1) (type real p4)) (string< (the array p1) - "bbbba" - :start1 (the (integer -16382 *) p4) - :end1 7))) + "bbbba" + :start1 (the (integer -16382 *) p4) + :end1 7))) "J4sPI71C3Xn" 5) 5) diff --git a/ansi-tests/misc.lsp b/ansi-tests/misc.lsp index 9ee3cdfa..d80d48ee 100644 --- a/ansi-tests/misc.lsp +++ b/ansi-tests/misc.lsp @@ -634,7 +634,7 @@ '(lambda () (flet ((%f2 () 288213285)) (+ (%f2) (* 13 (%f2))))))) 4034985990) - + (deftest misc.44 (funcall @@ -715,7 +715,7 @@ (rem b (min -16 0)))) 108251912) 8) - + (deftest misc.53 (funcall (compile nil '(lambda () @@ -1896,7 +1896,7 @@ (v1 (apply (compile nil fn1) vals)) (v2 (apply (compile nil fn2) vals))) (if (eql v1 v2) :good (list v1 v2))) - :good) + :good) ;;; cmucl (22 Oct 2003) ;;; The assertion (EQ C::ENV @@ -2047,7 +2047,7 @@ (let* ((v4 (%f12))) a))))) -1) 16777215) - + ;;; In Lispworks 4.2 (x86 linux personal edition) ;;; 'Error: *** Ran out of patterns in (MOVE) for (edi NIL)' @@ -2237,7 +2237,7 @@ (declare (optimize (speed 3) (space 3) (safety 1) (debug 1) (compilation-speed 0))) (case 0 ((-12 -9 -12 -2 -5 -2 15) (catch 'ct7 (throw 'ct7 0))) (t 0))))) - 0) + 0) ;;; sbcl bug (0.8.5.19) ;;; "The value NIL is not of type SB-C::REF." @@ -2318,7 +2318,7 @@ 2395) ;;; "/tmp/ecl9CEiD1RL5.c:36: `lex0' undeclared (first use in this function)" - + (deftest misc.157 (funcall (compile nil @@ -2710,7 +2710,7 @@ 10) 1) - + ;;; segmentation violation at #XA4A0B59 (deftest misc.172 @@ -3921,7 +3921,7 @@ (deftest misc.217 (ceiling 0 -2549795210) 0 0) - + (deftest misc.218 (floor 0 -2549795210) 0 0) @@ -5126,7 +5126,7 @@ Broken at C::WT-C-INLINE-LOC. ;; Error: Cannot go to TAG, its body has been exited. (deftest misc.291 - (funcall + (funcall #'(lambda (a) (declare (notinline numerator)) (declare (optimize (speed 2) (space 3) (safety 2) (debug 0) @@ -5265,14 +5265,14 @@ Broken at C::WT-C-INLINE-LOC. nil '(lambda () (declare (optimize (debug 3) (safety 0) (space 2) - (compilation-speed 2) (speed 2))) + (compilation-speed 2) (speed 2))) (block b4 - (multiple-value-prog1 - 0 - (catch 'ct8 - (return-from b4 (catch 'ct2 (progn (tagbody) 0))))))))) + (multiple-value-prog1 + 0 + (catch 'ct8 + (return-from b4 (catch 'ct2 (progn (tagbody) 0))))))))) 0) - + ;;; failed AVER: "(SUBSETP START START-STACK)" @@ -6216,7 +6216,7 @@ Broken at C::WT-C-INLINE-LOC. (reduce #'(lambda (lmv6 lmv5) (mod 0 (min -86 0))) (list 0 0))))))) -512398 -156405 1140919327630) - 3327764) + 3327764) ;;; ecl ;;; Wrong value @@ -6350,12 +6350,12 @@ Broken at C::WT-C-INLINE-LOC. (reduce #'(lambda (lmv6 lmv3) lmv3) (vector 0 (max 0) 0 0 (catch 'ct2 (catch 'ct2 (throw 'ct2 0))) 0 e 0) - + :end 2 :from-end t))) 68664683637 328245 881497115 -303855 311427) 0) - + ;;; Bugs from abcl ;;; Debugger invoked on condition of type TYPE-ERROR: ;;; The value org.armedbear.lisp.Symbol@54 is not of type integer. @@ -7271,7 +7271,7 @@ Broken at C::WT-C-INLINE-LOC. (deftest misc.374 (let #+armedbear ((jvm::*catch-errors* nil)) - nil + nil (funcall (compile nil @@ -7437,7 +7437,7 @@ Broken at C::WT-C-INLINE-LOC. 399997) 1125898833500797) - + ;;; gcl (31 May 2004, cvs head) ;;; Error in SYSTEM:ASET [or a callee]: Expected a FIXNUM @@ -9195,7 +9195,7 @@ Broken at C::WT-MAKE-CLOSURE. (declare (optimize (speed 2) (debug 1) (safety 3) (compilation-speed 3) (space 1))) (aref #(41397376227 18660605846 49244777443) (min 2 (max 0 b))))) - + -71)) 41397376227) @@ -10123,7 +10123,7 @@ Broken at C::WT-MAKE-CLOSURE. t)) t) -;;; IR2 type checking of unused values in [sic] not implemented. +;;; IR2 type checking of unused values in [sic] not implemented. (deftest misc.549 (funcall @@ -10584,7 +10584,7 @@ Broken at C::WT-MAKE-CLOSURE. #c(-9003 -121)))) t) -;;; The value -27 is not of type (INTEGER -34359738403 -24). +;;; The value -27 is not of type (INTEGER -34359738403 -24). (deftest misc.584 (approx= @@ -10717,7 +10717,7 @@ Broken at C::WT-MAKE-CLOSURE. 0 -714979492 1474663829) 0) -;;; ecl +;;; ecl ;;; 10000000.0d0 is not of type INTEGER. (deftest misc.595 @@ -10914,10 +10914,10 @@ Broken at C::WT-MAKE-CLOSURE. nil '(lambda (a) (declare (optimize (space 3) (safety 1) (debug 3) - (speed 1) (compilation-speed 3))) + (speed 1) (compilation-speed 3))) (catch 'ct1 - (reduce #'(lambda (lmv6 lmv5) (throw 'ct1 0)) - (list a 0 0) :end 2)))) + (reduce #'(lambda (lmv6 lmv5) (throw 'ct1 0)) + (list a 0 0) :end 2)))) 1) 0) @@ -10931,11 +10931,11 @@ Broken at C::WT-MAKE-CLOSURE. (declare (type (integer -3873004182 -3717314779) a)) (declare (ignorable a)) (declare (optimize (debug 0) (safety 1) (speed 3) - (space 0) (compilation-speed 0))) + (space 0) (compilation-speed 0))) (let* ((v1 (make-array nil :initial-element - (reduce #'logand (list a 0 a))))) - (declare (dynamic-extent v1)) - 0))) + (reduce #'logand (list a 0 a))))) + (declare (dynamic-extent v1)) + 0))) -3755148485) 0) @@ -10943,7 +10943,7 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.615 (let* ((x -8183.7625s0) - (form `(lambda (p1) (eql p1 ,x)))) + (form `(lambda (p1) (eql p1 ,x)))) (not (not (funcall (compile nil form) x)))) t) @@ -10960,21 +10960,21 @@ Broken at C::WT-MAKE-CLOSURE. (declare (type (integer 0 15) c)) (declare (ignorable a b c)) (declare (optimize (safety 1) (space 0) (compilation-speed 0) (speed 3) - (debug 3))) + (debug 3))) (catch 'ct7 - (labels ((%f12 - (f12-1 f12-2 - &optional - &key (key1 0) - (key2 - (reduce #'(lambda (lmv2 lmv1) 0) - (vector 0 0) - :end 2 - :start 0 - :from-end t)) - &allow-other-keys) - a)) - c)))) + (labels ((%f12 + (f12-1 f12-2 + &optional + &key (key1 0) + (key2 + (reduce #'(lambda (lmv2 lmv1) 0) + (vector 0 0) + :end 2 + :start 0 + :from-end t)) + &allow-other-keys) + a)) + c)))) -134217 -3699719058 10) 10) @@ -11054,12 +11054,12 @@ Broken at C::WT-MAKE-CLOSURE. nil '(lambda () (declare (optimize (debug 1) (space 0) (compilation-speed 3) - (speed 1) (safety 3))) + (speed 1) (safety 3))) (loop for lv1 below 2 sum - (dotimes (iv2 2 0) - (mod (dotimes (iv4 2 0) (progn (count lv1 #*0) 0)) - (min -63 (rem 0 (min -67 0))))))))) - + (dotimes (iv2 2 0) + (mod (dotimes (iv4 2 0) (progn (count lv1 #*0) 0)) + (min -63 (rem 0 (min -67 0))))))))) + 0) ;;; sbcl 0.9.9.8, x86 linux @@ -11071,7 +11071,7 @@ Broken at C::WT-MAKE-CLOSURE. nil '(lambda (p2) (declare (optimize (speed 3) (safety 2) (debug 3) (space 0)) - (type real p2)) + (type real p2)) (+ 81535869 (the (member 17549.955 #:g35917) p2)))) 17549.955) #.(+ 81535869 17549.955)) @@ -11085,13 +11085,13 @@ Broken at C::WT-MAKE-CLOSURE. nil '(lambda () (declare (optimize (space 2) (speed 0) (debug 2) - (compilation-speed 3) (safety 0))) + (compilation-speed 3) (safety 0))) (loop for lv3 below 1 - count (minusp - (loop for lv2 below 2 + count (minusp + (loop for lv2 below 2 count (logbitp 0 - (bit #*1001101001001 - (min 12 (max 0 lv3)))))))))) + (bit #*1001101001001 + (min 12 (max 0 lv3)))))))))) 0) ;;; failed AVER: "(< Y 29)" @@ -11102,16 +11102,16 @@ Broken at C::WT-MAKE-CLOSURE. nil '(lambda (a) (declare (type (integer 21 28) a)) - (declare (optimize (compilation-speed 1) (safety 2) - (speed 0) (debug 0) (space 1))) + (declare (optimize (compilation-speed 1) (safety 2) + (speed 0) (debug 0) (space 1))) (let* ((v7 (flet ((%f3 (f3-1 f3-2) - (loop for lv2 below 1 - count - (logbitp 29 - (sbit #*10101111 - (min 7 (max 0 (eval '0)))))))) + (loop for lv2 below 1 + count + (logbitp 29 + (sbit #*10101111 + (min 7 (max 0 (eval '0)))))))) (%f3 0 a)))) - 0))) + 0))) 22) 0) @@ -11133,22 +11133,22 @@ Broken at C::WT-MAKE-CLOSURE. #+sbcl (sb-c:insert-step-conditions 0) (debug 3) (compilation-speed 1))) (elt '(47119 39679 57498 35248 23784 40597 53473 29454) - (min 7 - (max 0 - (flet ((%f7 - (f7-1 f7-2 - &optional - &key - (key1 - (elt '(0 25 30 12 27 5) - (min 5 (max 0 3))))) - 0)) + (min 7 + (max 0 + (flet ((%f7 + (f7-1 f7-2 + &optional + &key + (key1 + (elt '(0 25 30 12 27 5) + (min 5 (max 0 3))))) + 0)) (flet ((%f6 - (&optional - &key (key1 (progn (%f7 0 a) a)) - (key2 0)) - 0)) - (%f7 a a)))))))) + (&optional + &key (key1 (progn (%f7 0 a) a)) + (key2 0)) + 0)) + (%f7 a a)))))))) -2) 47119) @@ -11161,15 +11161,15 @@ Broken at C::WT-MAKE-CLOSURE. '(lambda (a b) (declare (type (integer 1 5) b)) (declare (optimize (safety 2) (speed 2) - (space 0) (compilation-speed 3) (debug 3))) + (space 0) (compilation-speed 3) (debug 3))) (progn - (flet ((%f3 - (f3-1 f3-2 &optional (f3-3 b) f3-4 - (f3-5 (prog1 0 (elt '(a b c d e f g h i j k l m) 12)))) - f3-1)) - (%f3 0 (%f3 0 a 0 a) a 0 a)) - (elt '(a b c d) (min 3 b)) - ))) + (flet ((%f3 + (f3-1 f3-2 &optional (f3-3 b) f3-4 + (f3-5 (prog1 0 (elt '(a b c d e f g h i j k l m) 12)))) + f3-1)) + (%f3 0 (%f3 0 a 0 a) a 0 a)) + (elt '(a b c d) (min 3 b)) + ))) 0 2) c) @@ -11182,7 +11182,7 @@ Broken at C::WT-MAKE-CLOSURE. '(lambda (a) (declare (type (integer -902970 2) a)) (declare (optimize (space 2) (debug 0) (compilation-speed 1) - (speed 0) (safety 3))) + (speed 0) (safety 3))) (prog2 (if (logbitp 30 a) 0 (block b3 0)) a))) -829253) -829253) @@ -11197,7 +11197,7 @@ Broken at C::WT-MAKE-CLOSURE. nil '(lambda () (declare (optimize (safety 3) (space 3) (compilation-speed 3) - (speed 0) (debug 1))) + (speed 0) (debug 1))) (not (not (logbitp 0 (floor 2147483651 (min -23 0)))))))) t) @@ -11208,10 +11208,10 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.629 (let* ((s (make-misc-629 :a 1 :b 3)) - (form `(lambda (x) - (declare (optimize (speed 1) (safety 3) (debug 0) (space 2)) - (type (member 0 2 ,s) x)) - (misc-629-a x)))) + (form `(lambda (x) + (declare (optimize (speed 1) (safety 3) (debug 0) (space 2)) + (type (member 0 2 ,s) x)) + (misc-629-a x)))) (funcall (compile nil form) s)) 1) @@ -11226,9 +11226,9 @@ Broken at C::WT-MAKE-CLOSURE. nil '(lambda () (declare (optimize (speed 1) (debug 0) - (space 2) (safety 0) (compilation-speed 0))) + (space 2) (safety 0) (compilation-speed 0))) (unwind-protect 0 - (* (/ (multiple-value-prog1 -29457482 -5602513511) 1)))))) + (* (/ (multiple-value-prog1 -29457482 -5602513511) 1)))))) 0) ;;; Argument X is not a INTEGER: NIL @@ -11236,8 +11236,8 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.631 (if (flet ((%f17 (&key (key2 (if (evenp (multiple-value-prog1 0)) 0 0))) - 0)) - 0) + 0)) + 0) :a :b) :a) @@ -11258,17 +11258,17 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.633 (let* ((x -17045.0) - (form `(lambda (p3 p4) - (declare (optimize (speed 1) (safety 3) (debug 0) (space 1)) - (type number p3) - (type (member -1451.1257 47889 #:|3| ,x #:|aabbaaaaaababa|) - p4)) - (min 1 - -251.2455 - (the number p3) - (the (member 1+ ,x #\b #:|u4m7k0jz6o|) p4) - -1506/1283 - 65681158/19740963)))) + (form `(lambda (p3 p4) + (declare (optimize (speed 1) (safety 3) (debug 0) (space 1)) + (type number p3) + (type (member -1451.1257 47889 #:|3| ,x #:|aabbaaaaaababa|) + p4)) + (min 1 + -251.2455 + (the number p3) + (the (member 1+ ,x #\b #:|u4m7k0jz6o|) p4) + -1506/1283 + 65681158/19740963)))) (funcall (compile nil form) 1861 x)) -17045.0) @@ -11277,9 +11277,9 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.634 (let ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 3) (debug 3) (space 2)) - (type number p2)) - (- -83659.0 (the (member 35182846) p2))))) + (declare (optimize (speed 0) (safety 3) (debug 3) (space 2)) + (type number p2)) + (- -83659.0 (the (member 35182846) p2))))) (funcall (compile nil form) 35182846)) #.(- -83659.0 35182846)) @@ -11288,10 +11288,10 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.635 (let* ((form '(lambda (p2) - (declare (optimize (speed 0) (safety 1) - (debug 2) (space 2)) - (type (member -19261719) p2)) - (ceiling -46022.094 p2)))) + (declare (optimize (speed 0) (safety 1) + (debug 2) (space 2)) + (type (member -19261719) p2)) + (ceiling -46022.094 p2)))) (values (funcall (compile nil form) -19261719))) 1) @@ -11299,10 +11299,10 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.636 (let* ((x 26899.875) - (form `(lambda (p2) - (declare (optimize (speed 3) (safety 1) (debug 3) (space 1)) - (type (member ,x #:g5437 char-code #:g5438) p2)) - (* 104102267 p2)))) + (form `(lambda (p2) + (declare (optimize (speed 3) (safety 1) (debug 3) (space 1)) + (type (member ,x #:g5437 char-code #:g5438) p2)) + (* 104102267 p2)))) (not (not (floatp (funcall (compile nil form) x))))) t) @@ -11310,33 +11310,33 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.637 (labels ((%f11 (f11-2 &key key1) - (labels ((%f8 (f8-2 &optional (f8-5 (if nil (return-from %f11 0) 0))) - :bad1)) - (%f8 (%f8 0))) - :bad2)) - :good) + (labels ((%f8 (f8-2 &optional (f8-5 (if nil (return-from %f11 0) 0))) + :bad1)) + (%f8 (%f8 0))) + :bad2)) + :good) :good) ;;; full call to SB-KERNEL:DATA-VECTOR-REF (deftest misc.638 (let* ((codes '(32779 60674 33150 60033 41146 23916 28908 58886 12776 21282 37346 25537 56184 - 40736 4845 41954 6663 44378 23466 46903 13661 36445 18784 6114 6266)) - (chars (loop for code in codes collect (or (code-char code) #\x))) - (c (elt chars 21)) - (s (make-array '(25) :element-type 'character - :initial-contents chars))) + 40736 4845 41954 6663 44378 23466 46903 13661 36445 18784 6114 6266)) + (chars (loop for code in codes collect (or (code-char code) #\x))) + (c (elt chars 21)) + (s (make-array '(25) :element-type 'character + :initial-contents chars))) (let ((form `(lambda (p1) - (declare (optimize (speed 2) (safety 0) (debug 3) (space 1)) - (type (simple-string 25) p1)) - (char - (the - (member ,(let ((s2 "abbbabbaaabbaba")) - (make-array (length s2) :element-type 'base-char - :initial-contents s2)) - ,s) - p1) - 21)))) + (declare (optimize (speed 2) (safety 0) (debug 3) (space 1)) + (type (simple-string 25) p1)) + (char + (the + (member ,(let ((s2 "abbbabbaaabbaba")) + (make-array (length s2) :element-type 'base-char + :initial-contents s2)) + ,s) + p1) + 21)))) (not (not (eql c (funcall (compile nil form) s)))))) t) @@ -11345,12 +11345,12 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.639 (let ((form '(lambda (a b d) - (declare (notinline >= eql)) - (declare (optimize (debug 2) (speed 3) (safety 0) - (compilation-speed 3) (space 0))) - (labels ((%f8 (f8-1 &optional (f8-4 (if (if (eql 0 -16) (>= d) nil) 0 0))) - a)) - (%f8 b))))) + (declare (notinline >= eql)) + (declare (optimize (debug 2) (speed 3) (safety 0) + (compilation-speed 3) (space 0))) + (labels ((%f8 (f8-1 &optional (f8-4 (if (if (eql 0 -16) (>= d) nil) 0 0))) + a)) + (%f8 b))))) (funcall (compile nil form) :good 18 0)) :good) @@ -11359,13 +11359,13 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.640 (let ((form '(lambda (b g) - (declare (type (integer 303184 791836) b)) - (declare (optimize (compilation-speed 2) (debug 0) (space 1) - (speed 1) (safety 2))) - (loop for lv1 below 2 - sum (if (<= g lv1) - (labels ((%f7 () (prog1 b 0))) (%f7)) - (setf g -16188661082)))))) + (declare (type (integer 303184 791836) b)) + (declare (optimize (compilation-speed 2) (debug 0) (space 1) + (speed 1) (safety 2))) + (loop for lv1 below 2 + sum (if (<= g lv1) + (labels ((%f7 () (prog1 b 0))) (%f7)) + (setf g -16188661082)))))) (funcall (compile nil form) 335562 4655131896)) -16188325520) @@ -11374,11 +11374,11 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.641 (let ((form '(lambda () - (declare (optimize (speed 1) (space 0) (debug 2) - (compilation-speed 0) (safety 1))) - (flet ((%f3 (f3-1 &key (key1 (count (floor 0 (min -74 0)) #()))) - 0)) - (apply #'%f3 0 nil))))) + (declare (optimize (speed 1) (space 0) (debug 2) + (compilation-speed 0) (safety 1))) + (flet ((%f3 (f3-1 &key (key1 (count (floor 0 (min -74 0)) #()))) + 0)) + (apply #'%f3 0 nil))))) (funcall (compile nil form))) 0) @@ -11387,99 +11387,99 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.642 (let ((form ' (lambda (a b c d e f g h i j) - (declare (type (integer 174130 60165950) a)) - (declare (type (integer -4076 6783) b)) - (declare (type (integer -178481569 -1) c)) - (declare (type (integer 236 954963169) d)) - (declare (type (integer -1334 407047) e)) - (declare (type (integer -507 -426) f)) - (declare (type (integer -1164301 148213922) g)) - (declare (type (integer -184324 14515) h)) - (declare (type (integer 258 323) i)) - (declare (type (integer -11825 109247) j)) - (declare (ignorable a b c d e f g h i j)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (compilation-speed 2) (debug 0) (space 1) (speed 3) - (safety 2))) - (labels ((%f4 (f4-1) - (flet ((%f2 (f2-1 f2-2 f2-3 &key) - (progn - (return-from %f4 0) - f2-2))) - (common-lisp:handler-bind nil - (/ - (coerce - (unwind-protect - (reduce - #'(lambda (lmv2 lmv4) - (reduce #'* - (vector - (let () - h) - c - (reduce - #'(lambda (lmv4 lmv3) - (return-from %f4 - (deposit-field lmv4 - (byte 23 16) - (mask-field - (byte 3 27) - (elt '(5309746) - (min 0 - (max 0 - j))))))) - (vector - (%f2 (%f2 12762 f4-1 6646240924) 1501 - -15) - 277 - (multiple-value-call #'%f2 - (values -1486981 - i - (%f2 a 16777222 j))) - 1033) - :end 4 - :start 3) - (/ 823 -1)) - :end 3 - :start 1)) - (vector - (common-lisp:handler-bind nil - (- 0 h j b -2539837 28596 d 8161548 h -61)) - -183768642 - -1 - 31404552 - 81593) - :start 3) - (dpb i (byte 14 16) e) - (dpb - (count f4-1 - #(524279 8388596 1021351 101986) - :test '/=) - (byte 4 4) - 131064) - (if (= 524287 f) - (prog2 - (denominator - (elt '(1663 120) (min 1 (max 0 -17745)))) - f - (deposit-field e (byte 31 31) 0) - (labels ((%f7 - (f7-1 f7-2 f7-3 - &optional - (f7-4 - (coerce - (coerce - (the integer (+ -11045 114)) - 'integer) - 'integer)) - (f7-5 h)) - -2286515)) - j)) - (macrolet () - (prog2 -2195 1921675 h -183085 a)))) - 'integer) - 1))))) - 0)))) + (declare (type (integer 174130 60165950) a)) + (declare (type (integer -4076 6783) b)) + (declare (type (integer -178481569 -1) c)) + (declare (type (integer 236 954963169) d)) + (declare (type (integer -1334 407047) e)) + (declare (type (integer -507 -426) f)) + (declare (type (integer -1164301 148213922) g)) + (declare (type (integer -184324 14515) h)) + (declare (type (integer 258 323) i)) + (declare (type (integer -11825 109247) j)) + (declare (ignorable a b c d e f g h i j)) + #+cmu (declare (optimize (extensions:inhibit-warnings 3))) + (declare (optimize (compilation-speed 2) (debug 0) (space 1) (speed 3) + (safety 2))) + (labels ((%f4 (f4-1) + (flet ((%f2 (f2-1 f2-2 f2-3 &key) + (progn + (return-from %f4 0) + f2-2))) + (common-lisp:handler-bind nil + (/ + (coerce + (unwind-protect + (reduce + #'(lambda (lmv2 lmv4) + (reduce #'* + (vector + (let () + h) + c + (reduce + #'(lambda (lmv4 lmv3) + (return-from %f4 + (deposit-field lmv4 + (byte 23 16) + (mask-field + (byte 3 27) + (elt '(5309746) + (min 0 + (max 0 + j))))))) + (vector + (%f2 (%f2 12762 f4-1 6646240924) 1501 + -15) + 277 + (multiple-value-call #'%f2 + (values -1486981 + i + (%f2 a 16777222 j))) + 1033) + :end 4 + :start 3) + (/ 823 -1)) + :end 3 + :start 1)) + (vector + (common-lisp:handler-bind nil + (- 0 h j b -2539837 28596 d 8161548 h -61)) + -183768642 + -1 + 31404552 + 81593) + :start 3) + (dpb i (byte 14 16) e) + (dpb + (count f4-1 + #(524279 8388596 1021351 101986) + :test '/=) + (byte 4 4) + 131064) + (if (= 524287 f) + (prog2 + (denominator + (elt '(1663 120) (min 1 (max 0 -17745)))) + f + (deposit-field e (byte 31 31) 0) + (labels ((%f7 + (f7-1 f7-2 f7-3 + &optional + (f7-4 + (coerce + (coerce + (the integer (+ -11045 114)) + 'integer) + 'integer)) + (f7-5 h)) + -2286515)) + j)) + (macrolet () + (prog2 -2195 1921675 h -183085 a)))) + 'integer) + 1))))) + 0)))) (funcall (compile nil form) 58162926 -3652 -63561386 935157597 63716 -504 108893677 -146677 308 99009)) 0) @@ -11487,9 +11487,9 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.643 (let ((form '(lambda (a) - (declare (type (integer 6 1273) a)) - (declare (optimize (space 0) (safety 0) (debug 3) (compilation-speed 2) (speed 3))) - (logorc2 0 (restart-bind nil (shiftf a 522)))))) + (declare (type (integer 6 1273) a)) + (declare (optimize (space 0) (safety 0) (debug 3) (compilation-speed 2) (speed 3))) + (logorc2 0 (restart-bind nil (shiftf a 522)))))) (funcall (compile nil form) 807)) -808) @@ -11497,16 +11497,16 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.644 (let ((form '(lambda (a) - (declare (type (integer -6568333536 -12667) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (compilation-speed 1) (safety 3) (speed 1) (debug 1) - (space 3))) - (unwind-protect 0 - (the integer - (locally - (declare (special *s3* *s4*)) - (progv '(*s4* *s3*) (list a a) (expt *s3* 0)))))))) + (declare (type (integer -6568333536 -12667) a)) + (declare (ignorable a)) + #+cmu (declare (optimize (extensions:inhibit-warnings 3))) + (declare (optimize (compilation-speed 1) (safety 3) (speed 1) (debug 1) + (space 3))) + (unwind-protect 0 + (the integer + (locally + (declare (special *s3* *s4*)) + (progv '(*s4* *s3*) (list a a) (expt *s3* 0)))))))) (let ((*s3* 0)) (declare (special *s3*)) (funcall (compile nil form) -1520586839))) @@ -11516,21 +11516,21 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.645 (let ((form '(lambda (a) - (declare (notinline abs isqrt)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (debug 3) (safety 1) (space 2) (compilation-speed 1) - (speed 0))) - (progn - (tagbody - (prog2 - a - 0 - (labels ((%f9 (&key &allow-other-keys) - (go 3))) - (%f9))) - (isqrt (abs (unwind-protect 0))) - 3) - a)))) + (declare (notinline abs isqrt)) + #+cmu (declare (optimize (extensions:inhibit-warnings 3))) + (declare (optimize (debug 3) (safety 1) (space 2) (compilation-speed 1) + (speed 0))) + (progn + (tagbody + (prog2 + a + 0 + (labels ((%f9 (&key &allow-other-keys) + (go 3))) + (%f9))) + (isqrt (abs (unwind-protect 0))) + 3) + a)))) (eval `(,form 0))) 0) @@ -11538,13 +11538,13 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.646 (let ((form '(lambda (a) - (declare (type (integer -125 -44) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (speed 0) (debug 0) (space 2) (compilation-speed 3) - (safety 3))) - (mask-field (byte 0 0) - (block b3 (isqrt (abs (catch 'ct2 (return-from b3 0))))))))) + (declare (type (integer -125 -44) a)) + (declare (ignorable a)) + #+cmu (declare (optimize (extensions:inhibit-warnings 3))) + (declare (optimize (speed 0) (debug 0) (space 2) (compilation-speed 3) + (safety 3))) + (mask-field (byte 0 0) + (block b3 (isqrt (abs (catch 'ct2 (return-from b3 0))))))))) (funcall (compile nil form) -50)) 0) @@ -11552,23 +11552,23 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.647 (let ((form '(lambda (a) - (declare (type (integer -2494 534) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (speed 0) (space 0) (compilation-speed 3) (safety 1) - (debug 1))) - (dotimes (iv3 1 0) - (block b1 - (loop for lv1 below 1 - count (logbitp 0 - (reduce - #'(lambda (lmv6 lmv2) - (if (> 2208446653 lmv6) - (return-from b1 lmv2) - lv1)) - (list 0 0 0 1928431123 iv3 iv3 a a) - :end 5 - :from-end t)))))))) + (declare (type (integer -2494 534) a)) + (declare (ignorable a)) + #+cmu (declare (optimize (extensions:inhibit-warnings 3))) + (declare (optimize (speed 0) (space 0) (compilation-speed 3) (safety 1) + (debug 1))) + (dotimes (iv3 1 0) + (block b1 + (loop for lv1 below 1 + count (logbitp 0 + (reduce + #'(lambda (lmv6 lmv2) + (if (> 2208446653 lmv6) + (return-from b1 lmv2) + lv1)) + (list 0 0 0 1928431123 iv3 iv3 a a) + :end 5 + :from-end t)))))))) (funcall (compile nil form) 1)) 0) @@ -11576,21 +11576,21 @@ Broken at C::WT-MAKE-CLOSURE. (deftest misc.648 (let ((form '(lambda (a) - (declare (type (integer -8 11754838336) a)) - (declare (ignorable a)) - #+cmu (declare (optimize (extensions:inhibit-warnings 3))) - (declare (optimize (space 0) (compilation-speed 0) (speed 3) (debug 3) - (safety 0))) - (labels ((%f13 () - (logorc1 (unwind-protect 0) - (prog1 0 - (prog2 - (max 0 a) - 0 - (progn - (return-from %f13 a) - a)))))) - 0)))) + (declare (type (integer -8 11754838336) a)) + (declare (ignorable a)) + #+cmu (declare (optimize (extensions:inhibit-warnings 3))) + (declare (optimize (space 0) (compilation-speed 0) (speed 3) (debug 3) + (safety 0))) + (labels ((%f13 () + (logorc1 (unwind-protect 0) + (prog1 0 + (prog2 + (max 0 a) + 0 + (progn + (return-from %f13 a) + a)))))) + 0)))) (funcall (compile nil form) 2582756596)) 0) diff --git a/ansi-tests/mismatch.lsp b/ansi-tests/mismatch.lsp index bcfaf301..5aafdb87 100644 --- a/ansi-tests/mismatch.lsp +++ b/ansi-tests/mismatch.lsp @@ -185,7 +185,7 @@ (deftest mismatch-vector.23 (let ((a (make-array '(9) :initial-contents '(1 2 3 4 5 6 7 8 9) - :fill-pointer 5))) + :fill-pointer 5))) (values (mismatch '(1 2 3 4 5) a) (mismatch '(1 2 3 4 5) a :from-end t) @@ -197,8 +197,8 @@ (deftest mismatch-vector.24 (let ((m (make-array '(6) :initial-contents '(1 2 3 4 5 6) - :fill-pointer 4)) - (a '(1 2 3 4 5))) + :fill-pointer 4)) + (a '(1 2 3 4 5))) (list (mismatch m a) (mismatch m a :from-end t) @@ -208,7 +208,7 @@ (setf (fill-pointer m) 6) (mismatch m a) (mismatch m a :from-end t))) - (4 4 5 nil nil 6 5 6)) + (4 4 5 nil nil 6 5 6)) ;;; tests on bit vectors @@ -366,8 +366,8 @@ (deftest mismatch-bit-vector.23 (let ((a (make-array '(9) :initial-contents #*001011000 - :fill-pointer 5 - :element-type 'bit))) + :fill-pointer 5 + :element-type 'bit))) (values (mismatch #*00101 a) (mismatch #*00101 a :from-end t) @@ -379,9 +379,9 @@ (deftest mismatch-bit-vector.24 (let ((m (make-array '(6) :initial-contents #*001011 - :fill-pointer 4 - :element-type 'bit)) - (a #*00101)) + :fill-pointer 4 + :element-type 'bit)) + (a #*00101)) (list (mismatch m a) (mismatch m a :from-end t) @@ -449,25 +449,25 @@ (deftest mismatch-string.8 (mismatch "1001" "0110" :test #'(lambda (x y) (eql x (if (eql y #\0) - #\1 #\0)))) + #\1 #\0)))) nil) (deftest mismatch-string.8a (mismatch "1001" '(5 4 4 5) :test #'(lambda (x y) - (setq x (read-from-string (string x))) - (= x (- y 4)))) + (setq x (read-from-string (string x))) + (= x (- y 4)))) nil) (deftest mismatch-string.9 (mismatch "1001" '(5 4 17 5) :test #'(lambda (x y) - (setq x (read-from-string (string x))) - (= x (- y 4)))) + (setq x (read-from-string (string x))) + (= x (- y 4)))) 2) (deftest mismatch-string.9a (mismatch '(5 4 17 5) "1001" :test #'(lambda (x y) - (setq y (read-from-string (string y))) - (= y (- x 4)))) + (setq y (read-from-string (string y))) + (= y (- x 4)))) 2) (deftest mismatch-string.9b @@ -476,16 +476,16 @@ (deftest mismatch-string.10 (mismatch "1001" "0049" :test-not #'(lambda (x y) - (setq x (read-from-string (string x))) - (setq y (read-from-string (string y))) - (eql x (- y 4)))) + (setq x (read-from-string (string x))) + (setq y (read-from-string (string y))) + (eql x (- y 4)))) 2) (deftest mismatch-string.10a (mismatch "1001" "3333" :test-not #'(lambda (x y) - (setq x (read-from-string (string x))) - (setq y (read-from-string (string y))) - (eql x (- y 4)))) + (setq x (read-from-string (string x))) + (setq y (read-from-string (string y))) + (eql x (- y 4)))) nil) (deftest mismatch-string.11 @@ -570,8 +570,8 @@ (deftest mismatch-string.23 (let ((a (make-array '(9) :initial-contents "123456789" - :fill-pointer 5 - :element-type 'character))) + :fill-pointer 5 + :element-type 'character))) (values (mismatch "12345" a) (mismatch "12345" a :from-end t) @@ -583,9 +583,9 @@ (deftest mismatch-string.24 (let ((m (make-array '(6) :initial-contents "123456" - :fill-pointer 4 - :element-type 'character)) - (a "12345")) + :fill-pointer 4 + :element-type 'character)) + (a "12345")) (list (mismatch m a) (mismatch m a :from-end t) @@ -599,8 +599,8 @@ (deftest mistmatch-string.25 (let ((s0 "12345") - (s1 "123A") - (s2 "245")) + (s1 "123A") + (s2 "245")) (do-special-strings (s s0 nil) (assert (null (mismatch s s0))) @@ -653,14 +653,14 @@ 2) (deftest mismatch.allow-other-keys.4 - (mismatch "1234" "1244" :allow-other-keys t :bad t - :allow-other-keys nil) + (mismatch "1234" "1244" :allow-other-keys t :bad t + :allow-other-keys nil) 2) (deftest mismatch.allow-other-keys.5 (mismatch "1234" "1244" :allow-other-keys t - :allow-other-keys nil - :bad t) + :allow-other-keys nil + :bad t) 2) (deftest mismatch.keywords.6 @@ -669,7 +669,7 @@ (deftest mismatch.allow-other-keys.7 (mismatch "1234" "1244" :bad t :allow-other-keys t - :test (complement #'equal)) + :test (complement #'equal)) 0) ;;; Order of evaluation @@ -678,7 +678,7 @@ (let ((i 0) a b) (values (mismatch (progn (setf a (incf i)) "abcd") - (progn (setf b (incf i)) "abzd")) + (progn (setf b (incf i)) "abzd")) i a b)) 2 2 1 2) @@ -686,14 +686,14 @@ (let ((i 0) a b c d e f g h j) (values (mismatch (progn (setf a (incf i)) "abcdef") - (progn (setf b (incf i)) "abcdef") - :key (progn (setf c (incf i)) #'identity) - :test (progn (setf d (incf i)) #'equal) - :start1 (progn (setf e (incf i)) 1) - :start2 (progn (setf f (incf i)) 1) - :end1 (progn (setf g (incf i)) 4) - :end2 (progn (setf h (incf i)) 4) - :from-end (setf j (incf i))) + (progn (setf b (incf i)) "abcdef") + :key (progn (setf c (incf i)) #'identity) + :test (progn (setf d (incf i)) #'equal) + :start1 (progn (setf e (incf i)) 1) + :start2 (progn (setf f (incf i)) 1) + :end1 (progn (setf g (incf i)) 4) + :end2 (progn (setf h (incf i)) 4) + :from-end (setf j (incf i))) i a b c d e f g h j)) nil 9 1 2 3 4 5 6 7 8 9) @@ -701,14 +701,14 @@ (let ((i 0) a b c d e f g h j) (values (mismatch (progn (setf a (incf i)) "abcdef") - (progn (setf b (incf i)) "abcdef") - :from-end (setf c (incf i)) - :end2 (progn (setf d (incf i)) 4) - :end1 (progn (setf e (incf i)) 4) - :start2 (progn (setf f (incf i)) 1) - :start1 (progn (setf g (incf i)) 1) - :test (progn (setf h (incf i)) #'equal) - :key (progn (setf j (incf i)) #'identity)) + (progn (setf b (incf i)) "abcdef") + :from-end (setf c (incf i)) + :end2 (progn (setf d (incf i)) 4) + :end1 (progn (setf e (incf i)) 4) + :start2 (progn (setf f (incf i)) 1) + :start1 (progn (setf g (incf i)) 1) + :test (progn (setf h (incf i)) #'equal) + :key (progn (setf j (incf i)) #'identity)) i a b c d e f g h j)) nil 9 1 2 3 4 5 6 7 8 9) @@ -729,7 +729,7 @@ (deftest mismatch.error.4 (signals-error (mismatch nil nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest mismatch.error.5 diff --git a/ansi-tests/modules.lsp b/ansi-tests/modules.lsp index e544e657..a9bb5b29 100644 --- a/ansi-tests/modules.lsp +++ b/ansi-tests/modules.lsp @@ -42,7 +42,7 @@ (deftest modules.7 (let ((*modules* *modules*) - (fn 'modules7-fun)) + (fn 'modules7-fun)) (when (fboundp fn) (fmakunbound fn)) (require "MODULES-7" #p"modules7.lsp") (funcall fn)) @@ -50,7 +50,7 @@ (deftest modules.8 (let ((*modules* *modules*) - (fns '(modules8a-fun modules8b-fun))) + (fns '(modules8a-fun modules8b-fun))) (dolist (fn fns) (when (fboundp fn) (fmakunbound fn))) (require "MODULES-8" '(#p"modules8a.lsp" #p"modules8b.lsp")) @@ -91,4 +91,4 @@ (provide "Z") (require #\Z) nil)) - nil) \ No newline at end of file + nil) diff --git a/ansi-tests/muffle-warning.lsp b/ansi-tests/muffle-warning.lsp index db19c418..f09b57ad 100644 --- a/ansi-tests/muffle-warning.lsp +++ b/ansi-tests/muffle-warning.lsp @@ -13,7 +13,7 @@ (deftest muffle-warning.2 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 @@ -31,7 +31,7 @@ (deftest muffle-warning.4 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 @@ -44,7 +44,7 @@ (deftest muffle-warning.5 (signals-error (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) diff --git a/ansi-tests/multiple-value-bind.lsp b/ansi-tests/multiple-value-bind.lsp index ca27c366..be31f9fc 100644 --- a/ansi-tests/multiple-value-bind.lsp +++ b/ansi-tests/multiple-value-bind.lsp @@ -43,11 +43,11 @@ (declare (special z)) (values (flet ((%x () (symbol-value 'x)) - (%y () (symbol-value 'y)) - (%z () (symbol-value 'z))) + (%y () (symbol-value 'y)) + (%z () (symbol-value 'z))) (multiple-value-bind (x y z) (values 1 2 3) - (declare (special x y)) - (list (%x) (%y) (%z)))) + (declare (special x y)) + (list (%x) (%y) (%z)))) x y z)) (1 2 0) nil nil 0) @@ -91,26 +91,26 @@ (macrolet ((%m (z) z)) (multiple-value-bind (x y z) - (expand-in-current-env (%m (values 1 2 3))) - (list x y z))) + (expand-in-current-env (%m (values 1 2 3))) + (list x y z))) (1 2 3)) ;;; Error cases (deftest multiple-value-bind.error.1 (signals-error (funcall (macro-function 'multiple-value-bind)) - program-error) + program-error) t) - + (deftest multiple-value-bind.error.2 (signals-error (funcall (macro-function 'multiple-value-bind) - '(multiple-value-bind nil nil)) - program-error) + '(multiple-value-bind nil nil)) + program-error) t) (deftest multiple-value-bind.error.3 (signals-error (funcall (macro-function 'multiple-value-bind) - '(multiple-value-bind nil nil) - nil nil) - program-error) + '(multiple-value-bind nil nil) + nil nil) + program-error) t) diff --git a/ansi-tests/multiple-value-list.lsp b/ansi-tests/multiple-value-list.lsp index ffb2ba0d..340644f8 100644 --- a/ansi-tests/multiple-value-list.lsp +++ b/ansi-tests/multiple-value-list.lsp @@ -63,18 +63,18 @@ (deftest multiple-value-list.error.1 (signals-error (funcall (macro-function 'multiple-value-list)) - program-error) + program-error) t) - + (deftest multiple-value-list.error.2 (signals-error (funcall (macro-function 'multiple-value-list) - '(multiple-value-list nil)) - program-error) + '(multiple-value-list nil)) + program-error) t) (deftest multiple-value-list.error.3 (signals-error (funcall (macro-function 'multiple-value-list) - '(multiple-value-list nil) - nil nil) - program-error) + '(multiple-value-list nil) + nil nil) + program-error) t) diff --git a/ansi-tests/multiple-value-prog1.lsp b/ansi-tests/multiple-value-prog1.lsp index 2d574761..84df4622 100644 --- a/ansi-tests/multiple-value-prog1.lsp +++ b/ansi-tests/multiple-value-prog1.lsp @@ -23,7 +23,7 @@ (deftest multiple-value-prog1.5 (let ((x 0) (y 0)) (multiple-value-prog1 (values x y) - (incf x) (incf y 2))) + (incf x) (incf y 2))) 0 0) (deftest multiple-value-prog1.6 @@ -31,7 +31,7 @@ (multiple-value-call #'list (multiple-value-prog1 (values x y) - (incf x) (incf y 2)) + (incf x) (incf y 2)) x y)) (0 0 1 2)) @@ -40,8 +40,8 @@ (multiple-value-call #'list (multiple-value-prog1 (values (incf x) y) - (incf x x) - (incf y 10)) + (incf x x) + (incf y 10)) x y)) (1 0 2 10)) @@ -50,13 +50,13 @@ (let* ((n (min 100 multiple-values-limit))) (not-mv (loop for i from 0 below n - for x = (make-int-list i) - always - (equalt - (multiple-value-list - (eval `(multiple-value-prog1 (values-list (quote ,(copy-seq x))) - nil))) - x)))) + for x = (make-int-list i) + always + (equalt + (multiple-value-list + (eval `(multiple-value-prog1 (values-list (quote ,(copy-seq x))) + nil))) + x)))) nil) @@ -65,8 +65,8 @@ (values (block foo (multiple-value-prog1 - (values (incf x) (incf y 2)) - (return-from foo 'a))) + (values (incf x) (incf y 2)) + (return-from foo 'a))) x y)) a 1 2) diff --git a/ansi-tests/multiple-value-setq.lsp b/ansi-tests/multiple-value-setq.lsp index a7a989eb..672a226d 100644 --- a/ansi-tests/multiple-value-setq.lsp +++ b/ansi-tests/multiple-value-setq.lsp @@ -52,7 +52,7 @@ (deftest multiple-value-setq.7 (let ((x (list nil)) (z (list nil))) (symbol-macrolet ((y (car x)) - (w (car z))) + (w (car z))) (multiple-value-setq (y w) (values 1 2))) (values x z)) (1) (2)) @@ -62,7 +62,7 @@ (deftest multiple-value-setq.8 (let ((x (list nil)) (z (list nil)) (i 0)) (symbol-macrolet ((y (car (progn (incf i 3) x))) - (w (car (progn (incf i i) z)))) + (w (car (progn (incf i i) z)))) (multiple-value-setq (y w) (values i 10))) (values x z)) (6) (10)) @@ -90,8 +90,8 @@ (deftest multiple-value-setq.12 (let ((n (min 100 multiple-values-limit)) - (vars nil) - (result nil)) + (vars nil) + (result nil)) (loop for i from 1 below n for form = @@ -99,10 +99,10 @@ (push (gensym) vars) (push i result) `(let ,vars - (and (eql (multiple-value-setq ,vars (values-list (quote ,result))) - ,(car result)) - (equal ,(make-list-expr vars) - (quote ,result))))) + (and (eql (multiple-value-setq ,vars (values-list (quote ,result))) + ,(car result)) + (equal ,(make-list-expr vars) + (quote ,result))))) unless (eval form) collect (list i form))) nil) @@ -127,7 +127,7 @@ ((%m (z) z)) (let ((x :bad)) (symbol-macrolet ((z (expand-in-current-env (%m x)))) - (multiple-value-setq (z) :good)) + (multiple-value-setq (z) :good)) x)) :good) @@ -144,20 +144,20 @@ (deftest multiple-value-setq.error.1 (signals-error (funcall (macro-function 'multiple-value-setq)) - program-error) + program-error) t) - + (deftest multiple-value-setq.error.2 (signals-error (funcall (macro-function 'multiple-value-setq) - '(multiple-value-setq nil nil)) - program-error) + '(multiple-value-setq nil nil)) + program-error) t) (deftest multiple-value-setq.error.3 (signals-error (funcall (macro-function 'multiple-value-setq) - '(multiple-value-setq nil nil) - nil nil) - program-error) + '(multiple-value-setq nil nil) + nil nil) + program-error) t) - \ No newline at end of file + diff --git a/ansi-tests/name-char.lsp b/ansi-tests/name-char.lsp index a7cebca1..0deabbf5 100644 --- a/ansi-tests/name-char.lsp +++ b/ansi-tests/name-char.lsp @@ -13,13 +13,13 @@ (deftest name-char.2 (loop for s in '("RubOut" "PAGe" "BacKspace" "RetUrn" "Tab" "LineFeed" - "SpaCE" "NewLine") - always - (let ((c1 (name-char (string-upcase s))) - (c2 (name-char (string-downcase s))) - (c3 (name-char (string-capitalize s))) - (c4 (name-char s))) - (and (eqlt c1 c2) (eqlt c2 c3) (eqlt c3 c4)))) + "SpaCE" "NewLine") + always + (let ((c1 (name-char (string-upcase s))) + (c2 (name-char (string-downcase s))) + (c3 (name-char (string-capitalize s))) + (c4 (name-char s))) + (and (eqlt c1 c2) (eqlt c2 c3) (eqlt c3 c4)))) t) (deftest name-char.order.1 @@ -33,50 +33,50 @@ (deftest name-char.specialized.1 (loop for etype in '(standard-char base-char character) - append - (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" - "Space" "Newline") - for s2 = (make-array (length s) :element-type 'base-char - :initial-contents s) - unless (eql (name-char s) (name-char s2)) - collect (list s s2))) + append + (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" + "Space" "Newline") + for s2 = (make-array (length s) :element-type 'base-char + :initial-contents s) + unless (eql (name-char s) (name-char s2)) + collect (list s s2))) nil) (deftest name-char.specialized.2 (loop for etype in '(standard-char base-char character) - append - (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" - "Space" "Newline") - for s2 = (make-array (length s) :element-type etype - :adjustable t - :initial-contents s) - unless (eql (name-char s) (name-char s2)) - collect (list etype s s2))) + append + (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" + "Space" "Newline") + for s2 = (make-array (length s) :element-type etype + :adjustable t + :initial-contents s) + unless (eql (name-char s) (name-char s2)) + collect (list etype s s2))) nil) (deftest name-char.specialized.3 (loop for etype in '(standard-char base-char character) - append - (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" - "Space" "Newline") - for s2 = (make-array (+ 3 (length s)) :element-type etype - :fill-pointer (length s) - :initial-contents (concatenate 'string s " ")) - unless (eql (name-char s) (name-char s2)) - collect (list etype s s2))) + append + (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" + "Space" "Newline") + for s2 = (make-array (+ 3 (length s)) :element-type etype + :fill-pointer (length s) + :initial-contents (concatenate 'string s " ")) + unless (eql (name-char s) (name-char s2)) + collect (list etype s s2))) nil) (deftest name-char.specialized.4 (loop for etype in '(standard-char base-char character) - append - (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" - "Space" "Newline") - for s1 = (make-array (+ 4 (length s)) :element-type etype - :initial-contents (concatenate 'string " " s " ")) - for s2 = (make-array (length s) :element-type etype - :displaced-to s1 :displaced-index-offset 2) - unless (eql (name-char s) (name-char s2)) - collect (list etype s s2))) + append + (loop for s in '("Rubout" "Page" "Backspace" "Return" "Tab" "Linefeed" + "Space" "Newline") + for s1 = (make-array (+ 4 (length s)) :element-type etype + :initial-contents (concatenate 'string " " s " ")) + for s2 = (make-array (length s) :element-type etype + :displaced-to s1 :displaced-index-offset 2) + unless (eql (name-char s) (name-char s2)) + collect (list etype s s2))) nil) ;;; Error tests diff --git a/ansi-tests/namestring.lsp b/ansi-tests/namestring.lsp index 794ab9c5..dee99ab6 100644 --- a/ansi-tests/namestring.lsp +++ b/ansi-tests/namestring.lsp @@ -7,11 +7,11 @@ (deftest namestring.1 (let* ((vals (multiple-value-list (namestring "namestring.lsp"))) - (s (first vals))) + (s (first vals))) (if (and (null (cdr vals)) - (stringp s) - (equal (namestring s) s)) - :good + (stringp s) + (equal (namestring s) s)) + :good vals)) :good) @@ -28,28 +28,28 @@ #| (deftest namestring.3 (let* ((name "namestring.lsp") - (pn (merge-pathnames (pathname name))) - (name2 (namestring pn)) - (pn2 (pathname name2))) + (pn (merge-pathnames (pathname name))) + (name2 (namestring pn)) + (pn2 (pathname name2))) (or (equalt pn pn2) (list (list pn (pathname-host pn) (pathname-device pn) - (pathname-directory pn) (pathname-name pn) - (pathname-type pn) (pathname-version pn)) - (list pn2 (pathname-host pn2) (pathname-device pn2) - (pathname-directory pn2) (pathname-name pn2) - (pathname-type pn2) (pathname-version pn2))))) + (pathname-directory pn) (pathname-name pn) + (pathname-type pn) (pathname-version pn)) + (list pn2 (pathname-host pn2) (pathname-device pn2) + (pathname-directory pn2) (pathname-name pn2) + (pathname-type pn2) (pathname-version pn2))))) t) (deftest namestring.4 (let* ((name "namestring.lsp") - (pn (merge-pathnames (pathname name))) - (name2 (with-open-file (s pn :direction :input) (namestring s))) - (pn2 (pathname name2))) + (pn (merge-pathnames (pathname name))) + (name2 (with-open-file (s pn :direction :input) (namestring s))) + (pn2 (pathname name2))) (or (equalt pn pn2) (list (list pn (pathname-host pn) (pathname-device pn) - (pathname-directory pn) (pathname-name pn) - (pathname-type pn) (pathname-version pn)) - (list pn2 (pathname-host pn2) (pathname-device pn2) - (pathname-directory pn2) (pathname-name pn2) - (pathname-type pn2) (pathname-version pn2))))) + (pathname-directory pn) (pathname-name pn) + (pathname-type pn) (pathname-version pn)) + (list pn2 (pathname-host pn2) (pathname-device pn2) + (pathname-directory pn2) (pathname-name pn2) + (pathname-type pn2) (pathname-version pn2))))) t) |# diff --git a/ansi-tests/nbutlast.lsp b/ansi-tests/nbutlast.lsp index d1275103..db433823 100644 --- a/ansi-tests/nbutlast.lsp +++ b/ansi-tests/nbutlast.lsp @@ -10,12 +10,12 @@ (deftest nbutlast.1 (let ((x (list 'a 'b 'c 'd 'e))) (let ((y (cdr x)) - (z (cddr x))) + (z (cddr x))) (let ((result (nbutlast x 2))) - (and (eqt x result) - (eqt (cdr x) y) - (eqt (cddr x) z) - result)))) + (and (eqt x result) + (eqt (cdr x) y) + (eqt (cddr x) z) + result)))) (a b c)) (deftest nbutlast.2 @@ -34,7 +34,7 @@ (let ((x (list* 'a 'b 'c 'd))) (let ((result (nbutlast x 1))) (and (eqt result x) - result))) + result))) (a b)) (deftest nbutlast.5 @@ -61,9 +61,9 @@ (let ((i 0) x y) (values (nbutlast (progn (setf x (incf i)) - (list 'a 'b 'c 'd 'e)) - (progn (setf y (incf i)) - 2)) + (list 'a 'b 'c 'd 'e)) + (progn (setf y (incf i)) + 2)) i x y)) (a b c) 2 1 2) @@ -78,7 +78,7 @@ (deftest nbutlast.error.1 (signals-error (let ((x (list* 'a 'b 'c 'd))) (nbutlast x 'a)) - type-error) + type-error) t) (deftest nbutlast.error.2 diff --git a/ansi-tests/nconc.lsp b/ansi-tests/nconc.lsp index 8f3faf5b..c660ca23 100644 --- a/ansi-tests/nconc.lsp +++ b/ansi-tests/nconc.lsp @@ -21,13 +21,13 @@ (deftest nconc.4 (let ((x (list 'a 'b 'c)) - (y (list 'd 'e 'f))) + (y (list 'd 'e 'f))) (let ((ycopy (make-scaffold-copy y))) (let ((result (nconc x y))) - (and - (check-scaffold-copy y ycopy) - (eqt (cdddr x) y) - result)))) + (and + (check-scaffold-copy y ycopy) + (eqt (cdddr x) y) + result)))) (a b c d e f)) (deftest nconc.5 @@ -40,8 +40,8 @@ (deftest nconc.6 (let ((x (list 'a 'b 'c)) - (y (list 'd 'e 'f 'g 'h)) - (z (list 'i 'j 'k))) + (y (list 'd 'e 'f 'g 'h)) + (z (list 'i 'j 'k))) (let ((result (nconc x y z 'foo))) (and (eqt (nthcdr 3 x) y) @@ -52,17 +52,17 @@ (deftest nconc.7 (nconc (copy-tree '(a . b)) - (copy-tree '(c . d)) - (copy-tree '(e . f)) - 'foo) + (copy-tree '(c . d)) + (copy-tree '(e . f)) + 'foo) (a c e . foo)) (deftest nconc.order.1 (let ((i 0) x y z) (values (nconc (progn (setf x (incf i)) (copy-list '(a b c))) - (progn (setf y (incf i)) (copy-list '(d e f))) - (progn (setf z (incf i)) (copy-list '(g h i)))) + (progn (setf y (incf i)) (copy-list '(d e f))) + (progn (setf z (incf i)) (copy-list '(g h i)))) i x y z)) (a b c d e f g h i) 3 1 2 3) diff --git a/ansi-tests/nintersection.lsp b/ansi-tests/nintersection.lsp index 9266823a..13d23b0d 100644 --- a/ansi-tests/nintersection.lsp +++ b/ansi-tests/nintersection.lsp @@ -21,26 +21,26 @@ (deftest nintersection.4 (let* ((x (copy-list '(a 1 c 7 b 4 3 z))) - (xc (copy-list x)) - (y (copy-list '(3 y c q z a 18))) - (result (nintersection-with-check xc y))) + (xc (copy-list x)) + (y (copy-list '(3 y c q z a 18))) + (result (nintersection-with-check xc y))) (and (not (eqt result 'failed)) (+ (loop for e in x count - (and (member e y) - (not (member e result)))) + (and (member e y) + (not (member e result)))) (loop for e in result count - (or (not (member e x)) (not (member e y)))) + (or (not (member e x)) (not (member e y)))) (loop for hd on result count - (and (consp hd) - (member (car hd) (cdr hd))))))) + (and (consp hd) + (member (car hd) (cdr hd))))))) 0) (deftest nintersection.5 (let* ((x (copy-list '(a a a))) - (y (copy-list '(a a a b b b))) - (result (nintersection-with-check x y))) + (y (copy-list '(a a a b b b))) + (result (nintersection-with-check x y))) (and (not (eqt result 'failed)) (member 'a result) @@ -55,7 +55,7 @@ (deftest nintersection.7 (nintersection-with-check (list 'a 10 'b 17) - (list 'c 'd 4 'e 'f 10 1 13 'z)) + (list 'c 'd 4 'e 'f 10 1 13 'z)) (10)) (deftest nintersection.8 @@ -89,9 +89,9 @@ (equalt (sort (let ((result - (nintersection-with-check - (loop for i from 0 to 1000 by 3 collect i) - (loop for i from 0 to 1000 by 7 collect i)))) + (nintersection-with-check + (loop for i from 0 to 1000 by 3 collect i) + (loop for i from 0 to 1000 by 7 collect i)))) (if (eqt result 'failed) () result)) #'<) (loop for i from 0 to 1000 by 21 collect i)) @@ -101,12 +101,12 @@ (equalt (sort (let ((result - (nintersection-with-check - (loop for i from 0 to 999 by 5 collect i) - (loop for i from 0 to 999 by 7 collect i) - :test #'(lambda (a b) - (and (eql a b) - (= (mod a 3) 0)))))) + (nintersection-with-check + (loop for i from 0 to 999 by 5 collect i) + (loop for i from 0 to 999 by 7 collect i) + :test #'(lambda (a b) + (and (eql a b) + (= (mod a 3) 0)))))) (if (eqt result 'failed) () result)) #'<) (loop @@ -121,12 +121,12 @@ (deftest nintersection.13 (let ((x '(0 5 8 13 31 42)) - (y (copy-list '(3 5 42 0 7 100 312 33)))) + (y (copy-list '(3 5 42 0 7 100 312 33)))) (equalt (sort (copy-list (nintersection - (copy-list x) y)) #'<) + (copy-list x) y)) #'<) (sort (copy-list (nintersection - (copy-list x) y :key #'1+)) #'<))) + (copy-list x) y :key #'1+)) #'<))) t) ;; Check that a nil key argument is ignored @@ -134,66 +134,66 @@ (deftest nintersection.14 (let ((result (nintersection - (copy-list '(a b c d)) - (copy-list '(e c f b g)) - :key nil))) + (copy-list '(a b c d)) + (copy-list '(e c f b g)) + :key nil))) (and (member 'b result) (member 'c result) (every #'(lambda (x) (member x '(b c))) result) t)) - t) + t) ;; Test that nintersection preserves the order of arguments to :test, :test-not (deftest nintersection.15 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (block fail (nintersection list1 list2 :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))))) + (when (< y x) (return-from fail 'fail)) + (eql x y))))) (4)) (deftest nintersection.16 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (block fail (nintersection list1 list2 :key #'identity :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))))) + (when (< y x) (return-from fail 'fail)) + (eql x y))))) (4)) (deftest nintersection.17 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (block fail (nintersection list1 list2 :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))))) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))))) (4)) (deftest nintersection.18 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (block fail (nintersection list1 list2 :key #'identity :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))))) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))))) (4)) (defharmless nintersection.test-and-test-not.1 @@ -208,7 +208,7 @@ (let ((i 0) x y) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd))) + (progn (setf y (incf i)) (list 'c 'd))) i x y)) nil 2 1 2) @@ -216,8 +216,8 @@ (let ((i 0) x y) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test #'eq) + (progn (setf y (incf i)) (list 'c 'd)) + :test #'eq) i x y)) nil 2 1 2) @@ -225,10 +225,10 @@ (let ((i 0) x y z w) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test (progn (setf z (incf i)) #'eq) - :test (progn (setf w (incf i)) - (complement #'eq))) + (progn (setf y (incf i)) (list 'c 'd)) + :test (progn (setf z (incf i)) #'eq) + :test (progn (setf w (incf i)) + (complement #'eq))) i x y z w)) nil 4 1 2 3 4) @@ -236,9 +236,9 @@ (let ((i 0) x y z w) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :test (progn (setf z (incf i)) #'eq) - :key (progn (setf w (incf i)) #'identity)) + (progn (setf y (incf i)) (list 'c 'd)) + :test (progn (setf z (incf i)) #'eq) + :key (progn (setf w (incf i)) #'identity)) i x y z w)) nil 4 1 2 3 4) @@ -246,9 +246,9 @@ (let ((i 0) x y z w) (values (nintersection (progn (setf x (incf i)) (list 'a 'b)) - (progn (setf y (incf i)) (list 'c 'd)) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf w (incf i)) #'eq)) + (progn (setf y (incf i)) (list 'c 'd)) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf w (incf i)) #'eq)) i x y z w)) nil 4 1 2 3 4) @@ -256,67 +256,67 @@ (deftest nintersection.allow-other-keys.1 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (nintersection list1 list2 :bad t :allow-other-keys 1)) (4)) (deftest nintersection.allow-other-keys.2 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys :foo :also-bad t)) (4)) (deftest nintersection.allow-other-keys.3 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys :foo :also-bad t - :test #'(lambda (x y) (= x (1+ y))))) + :test #'(lambda (x y) (= x (1+ y))))) nil) (deftest nintersection.allow-other-keys.4 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys t)) (4)) (deftest nintersection.allow-other-keys.5 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys nil)) (4)) (deftest nintersection.allow-other-keys.6 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys t - :allow-other-keys nil :bad t)) + :allow-other-keys nil :bad t)) (4)) (deftest nintersection.allow-other-keys.7 (sort (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys t - :allow-other-keys nil - :test #'(lambda (x y) (eql x (1- y))))) + :allow-other-keys nil + :test #'(lambda (x y) (eql x (1- y))))) #'<) (3 4)) (deftest nintersection.keywords.8 (sort (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (nintersection list1 list2 - :test #'(lambda (x y) (eql x (1- y))) - :test #'eql)) + :test #'(lambda (x y) (eql x (1- y))) + :test #'eql)) #'<) (3 4)) (deftest nintersection.allow-other-keys.9 (let ((list1 (list 1 2 3 4)) - (list2 (list 4 5 6 7))) + (list2 (list 4 5 6 7))) (nintersection list1 list2 :allow-other-keys :foo :also-bad t - :test #'(lambda (x y) (= x (1+ y))))) + :test #'(lambda (x y) (= x (1+ y))))) nil) (deftest nintersection.error.1 @@ -373,4 +373,4 @@ (deftest nintersection.error.14 (check-type-error #'(lambda (x) (nintersection (copy-seq '(a b c)) x)) #'listp) - nil) \ No newline at end of file + nil) diff --git a/ansi-tests/no-next-method.lsp b/ansi-tests/no-next-method.lsp index 0301731c..86fe61ec 100644 --- a/ansi-tests/no-next-method.lsp +++ b/ansi-tests/no-next-method.lsp @@ -15,32 +15,32 @@ (deftest no-next-method.1 (handler-case (progn (no-next-meth-gf-01 10) :bad) - (error () :good)) + (error () :good)) :good) (deftest no-next-method.2 (handler-case (progn (no-next-meth-gf-01 ) :bad) - (error () :good)) + (error () :good)) :good) ;;; (defparameter *no-next-meth-gf-02* ;;; (defgeneric no-next-meth-gf-02 (x))) -;;; +;;; ;;; (defmethod no-next-meth-gf-02 ((x integer)) ;;; (call-next-method)) -;;; +;;; ;;; (defmethod no-next-meth-gf-02 :around ((x character)) ;;; (call-next-method)) -;;; +;;; ;;; (defmethod no-next-method ((gf (eql *no-next-meth-gf-02*)) -;;; (method standard-method) -;;; &rest args) +;;; (method standard-method) +;;; &rest args) ;;; (values (copy-list args) :aborted)) -;;; +;;; ;;; (deftest no-next-method.3 ;;; (no-next-meth-gf-02 10) ;;; (10) :aborted) -;;; +;;; ;;; (deftest no-next-method.4 ;;; (no-next-meth-gf-02 #\a) ;;; (#\a) :aborted) diff --git a/ansi-tests/not-and-null.lsp b/ansi-tests/not-and-null.lsp index 6099b267..087779fc 100644 --- a/ansi-tests/not-and-null.lsp +++ b/ansi-tests/not-and-null.lsp @@ -19,8 +19,8 @@ (deftest null.4 (not (some #'null - `(1 a 1.2 "a" #\w (a) ,*terminal-io* - #'car (make-array '(10))))) + `(1 a 1.2 "a" #\w (a) ,*terminal-io* + #'car (make-array '(10))))) t) (deftest null.error.1 @@ -45,8 +45,8 @@ (deftest not.4 (not (some #'not - `(1 a 1.2 "a" #\w (a) ,*terminal-io* - #'car (make-array '(10))))) + `(1 a 1.2 "a" #\w (a) ,*terminal-io* + #'car (make-array '(10))))) t) diff --git a/ansi-tests/notany.lsp b/ansi-tests/notany.lsp index cbce88aa..bc7125f7 100644 --- a/ansi-tests/notany.lsp +++ b/ansi-tests/notany.lsp @@ -17,7 +17,7 @@ (let ((count 0)) (values (notany #'(lambda (x) (incf count) (if (>= x 10) x nil)) - '(1 2 4 13 5 1)) + '(1 2 4 13 5 1)) count)) nil 4) @@ -35,16 +35,16 @@ (deftest notany.7 (not-mv (notany #'(lambda (x y) (and x y)) - '(nil t t nil t) #(t nil nil t nil nil))) + '(nil t t nil t) #(t nil nil t nil nil))) nil) (deftest notany.8 (let* ((x '(1)) - (args (list x))) + (args (list x))) (not (loop for i from 2 below (1- (min 100 call-arguments-limit)) - do (push x args) - always (apply #'notany #'/= args)))) + do (push x args) + always (apply #'notany #'/= args)))) nil) (deftest notany.9 @@ -83,62 +83,62 @@ (deftest notany.17 (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) - :fill-pointer 4))) + :fill-pointer 4))) (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notany #'plusp v)))) + do (setf (fill-pointer v) j) + collect (not (notany #'plusp v)))) (nil nil nil nil nil t t t t t)) (deftest notany.18 (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents (loop for j in '(0 0 0 0 1 2 3 4 5 6) - collect (mod j (ash 1 i))) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notany #'plusp v))) - '(nil nil nil nil nil t t t t t))) - collect i) + for type = `(unsigned-byte ,i) + unless + (let ((v (make-array '(10) :initial-contents (loop for j in '(0 0 0 0 1 2 3 4 5 6) + collect (mod j (ash 1 i))) + :element-type type + :fill-pointer 4))) + (equal (loop for j from 0 to 9 + do (setf (fill-pointer v) j) + collect (not (notany #'plusp v))) + '(nil nil nil nil nil t t t t t))) + collect i) nil) (deftest notany.19 (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notany #'minusp v))) - '(nil nil nil nil nil t t t t t))) - collect i) + for type = `(signed-byte ,i) + unless + (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) + :element-type type + :fill-pointer 4))) + (equal (loop for j from 0 to 9 + do (setf (fill-pointer v) j) + collect (not (notany #'minusp v))) + '(nil nil nil nil nil t t t t t))) + collect i) nil) (deftest notany.20 (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'character - :fill-pointer 4))) + :element-type 'character + :fill-pointer 4))) (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notany #'digit-char-p v)))) + do (setf (fill-pointer v) j) + collect (not (notany #'digit-char-p v)))) (nil nil nil nil nil t t t t t)) (deftest notany.21 (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'base-char - :fill-pointer 4))) + :element-type 'base-char + :fill-pointer 4))) (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notany #'digit-char-p v)))) + do (setf (fill-pointer v) j) + collect (not (notany #'digit-char-p v)))) (nil nil nil nil nil t t t t t)) (deftest notany.22 (let ((v (make-array '(5) :initial-contents "abcde" - :element-type 'base-char))) + :element-type 'base-char))) (values (notnot (notany #'digit-char-p v)) (setf (aref v 2) #\0) @@ -147,42 +147,42 @@ (deftest notany.23 (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(9) - :element-type type - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) - when (notany #'zerop v) - collect (list type v)) + for v = (make-array '(9) + :element-type type + :initial-contents + (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) + when (notany #'zerop v) + collect (list type v)) nil) (deftest notany.24 (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(9) - :element-type type - :fill-pointer 6 - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) - unless (notany #'zerop v) - collect (list type v)) + for v = (make-array '(9) + :element-type type + :fill-pointer 6 + :initial-contents + (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) + unless (notany #'zerop v) + collect (list type v)) nil) (deftest notany.25 (loop for type in '(short-float single-float double-float long-float) - for ctype = `(complex ,type) - for v = (make-array '(6) - :element-type ctype - :initial-contents - (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) - unless (notany (complement #'complexp) v) - collect (list type v)) + for ctype = `(complex ,type) + for v = (make-array '(6) + :element-type ctype + :initial-contents + (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) + unless (notany (complement #'complexp) v) + collect (list type v)) nil) ;;; Displaced vectors (deftest notany.26 (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2))) + (v2 (make-array '(4) :displaced-to v1 + :displaced-index-offset 2))) (values (notany #'oddp v1) (notnot (notany #'oddp v2)))) @@ -190,53 +190,53 @@ (deftest notany.27 (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (not (notany 'oddp v1)) - (notany #'oddp v2))) - collect i) + for type = `(unsigned-byte ,i) + unless + (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) + :element-type type)) + (v2 (make-array '(4) :displaced-to v1 + :displaced-index-offset 2 + :element-type type))) + (and (not (notany 'oddp v1)) + (notany #'oddp v2))) + collect i) nil) (deftest notany.28 (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (not (notany 'oddp v1)) - (notany #'oddp v2))) - collect i) + for type = `(signed-byte ,i) + unless + (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) + :element-type type)) + (v2 (make-array '(4) :displaced-to v1 + :displaced-index-offset 2 + :element-type type))) + (and (not (notany 'oddp v1)) + (notany #'oddp v2))) + collect i) nil) (deftest notany.29 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'character - :displaced-to s1 - :displaced-index-offset i) - collect (not (notany 'digit-char-p s2)))) + for s2 = (make-array '(2) :element-type 'character + :displaced-to s1 + :displaced-index-offset i) + collect (not (notany 'digit-char-p s2)))) (t t nil nil t t t)) (deftest notany.30 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'base-char - :displaced-to s1 - :displaced-index-offset i) - collect (not (notany 'digit-char-p s2)))) + for s2 = (make-array '(2) :element-type 'base-char + :displaced-to s1 + :displaced-index-offset i) + collect (not (notany 'digit-char-p s2)))) (t t nil nil t t t)) (deftest notany.31 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :adjustable t))) + :adjustable t))) (values (notnot (notany #'minusp v)) (progn @@ -246,8 +246,8 @@ (deftest notany.32 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 10 - :adjustable t))) + :fill-pointer 10 + :adjustable t))) (values (notnot (notany #'minusp v)) (progn @@ -260,7 +260,7 @@ (let ((i 0) a b) (values (not (notany (progn (setf a (incf i)) 'null) - (progn (setf b (incf i)) '(a b c)))) + (progn (setf b (incf i)) '(a b c)))) i a b)) nil 2 1 2) @@ -268,7 +268,7 @@ (deftest notany.error.1 (check-type-error #'(lambda (x) (notany x '(a b c))) - (typef '(or symbol function))) + (typef '(or symbol function))) nil) (deftest notany.error.4 @@ -301,4 +301,4 @@ (deftest notany.error.13 (signals-error (notany #'car '(a b c)) type-error) - t) \ No newline at end of file + t) diff --git a/ansi-tests/notevery.lsp b/ansi-tests/notevery.lsp index 3d9102ef..7679aef6 100644 --- a/ansi-tests/notevery.lsp +++ b/ansi-tests/notevery.lsp @@ -17,7 +17,7 @@ (let ((count 0)) (values (not (notevery #'(lambda (x) (incf count) (< x 10)) - '(1 2 4 13 5 1))) + '(1 2 4 13 5 1))) count)) nil 4) @@ -35,16 +35,16 @@ (deftest notevery.7 (notevery #'(lambda (x y) (or x y)) - '(nil t t nil t) #(t nil t t nil nil)) + '(nil t t nil t) #(t nil t t nil nil)) nil) (deftest notevery.8 (let ((x '(1)) - (args nil)) + (args nil)) (not (loop for i from 1 below (1- (min 100 call-arguments-limit)) - do (push x args) - always (not (apply #'notevery #'= args))))) + do (push x args) + always (not (apply #'notevery #'= args))))) nil) (deftest notevery.9 @@ -83,61 +83,61 @@ (deftest notevery.17 (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) - :fill-pointer 4))) + :fill-pointer 4))) (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notevery #'zerop v)))) + do (setf (fill-pointer v) j) + collect (not (notevery #'zerop v)))) (t t t t t nil nil nil nil nil)) (deftest notevery.18 (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 1 1 1 1 1) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notevery #'zerop v))) - '(t t t t t nil nil nil nil nil))) - collect i) + for type = `(unsigned-byte ,i) + unless + (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 1 1 1 1 1) + :element-type type + :fill-pointer 4))) + (equal (loop for j from 0 to 9 + do (setf (fill-pointer v) j) + collect (not (notevery #'zerop v))) + '(t t t t t nil nil nil nil nil))) + collect i) nil) (deftest notevery.19 (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notevery #'zerop v))) - '(t t t t t nil nil nil nil nil))) - collect i) + for type = `(signed-byte ,i) + unless + (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) + :element-type type + :fill-pointer 4))) + (equal (loop for j from 0 to 9 + do (setf (fill-pointer v) j) + collect (not (notevery #'zerop v))) + '(t t t t t nil nil nil nil nil))) + collect i) nil) (deftest notevery.20 (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'character - :fill-pointer 4))) + :element-type 'character + :fill-pointer 4))) (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notevery #'alpha-char-p v)))) + do (setf (fill-pointer v) j) + collect (not (notevery #'alpha-char-p v)))) (t t t t t nil nil nil nil nil)) (deftest notevery.21 (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'base-char - :fill-pointer 4))) + :element-type 'base-char + :fill-pointer 4))) (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (not (notevery #'alpha-char-p v)))) + do (setf (fill-pointer v) j) + collect (not (notevery #'alpha-char-p v)))) (t t t t t nil nil nil nil nil)) (deftest notevery.22 (let ((v (make-array '(5) :initial-contents "abcde" - :element-type 'base-char))) + :element-type 'base-char))) (values (not (notevery #'alpha-char-p v)) (setf (aref v 2) #\0) @@ -148,8 +148,8 @@ (deftest notevery.23 (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2))) + (v2 (make-array '(4) :displaced-to v1 + :displaced-index-offset 2))) (values (not (notevery #'evenp v1)) (not (notevery 'evenp v2)))) @@ -157,55 +157,55 @@ (deftest notevery.24 (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (notevery 'evenp v1) - (not (notevery #'evenp v2)))) - collect i) + for type = `(unsigned-byte ,i) + unless + (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) + :element-type type)) + (v2 (make-array '(4) :displaced-to v1 + :displaced-index-offset 2 + :element-type type))) + (and (notevery 'evenp v1) + (not (notevery #'evenp v2)))) + collect i) nil) (deftest notevery.25 (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (notevery 'evenp v1) - (not (notevery #'evenp v2)))) - collect i) + for type = `(signed-byte ,i) + unless + (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) + :element-type type)) + (v2 (make-array '(4) :displaced-to v1 + :displaced-index-offset 2 + :element-type type))) + (and (notevery 'evenp v1) + (not (notevery #'evenp v2)))) + collect i) nil) (deftest notevery.26 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'character - :displaced-to s1 - :displaced-index-offset i) - collect (not (notevery 'alpha-char-p s2)))) + for s2 = (make-array '(2) :element-type 'character + :displaced-to s1 + :displaced-index-offset i) + collect (not (notevery 'alpha-char-p s2)))) (nil nil t t nil nil nil)) (deftest notevery.27 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'base-char - :displaced-to s1 - :displaced-index-offset i) - collect (not (notevery 'alpha-char-p s2)))) + for s2 = (make-array '(2) :element-type 'base-char + :displaced-to s1 + :displaced-index-offset i) + collect (not (notevery 'alpha-char-p s2)))) (nil nil t t nil nil nil)) ;;; adjustable vectors (deftest notevery.28 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :adjustable t))) + :adjustable t))) (values (not (notevery #'plusp v)) (progn @@ -215,8 +215,8 @@ (deftest notevery.29 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 10 - :adjustable t))) + :fill-pointer 10 + :adjustable t))) (values (not (notevery #'plusp v)) (progn @@ -228,34 +228,34 @@ (deftest notevery.30 (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(6) - :element-type type - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6))) - when (notevery #'plusp v) - collect (list type v)) + for v = (make-array '(6) + :element-type type + :initial-contents + (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6))) + when (notevery #'plusp v) + collect (list type v)) nil) (deftest notevery.31 (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(6) - :element-type type - :fill-pointer 5 - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 -1))) - when (notevery #'plusp v) - collect (list type v)) + for v = (make-array '(6) + :element-type type + :fill-pointer 5 + :initial-contents + (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 -1))) + when (notevery #'plusp v) + collect (list type v)) nil) (deftest notevery.32 (loop for type in '(short-float single-float double-float long-float) - for ctype = `(complex ,type) - for v = (make-array '(6) - :element-type ctype - :initial-contents - (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) - when (notevery #'complexp v) - collect (list type v)) + for ctype = `(complex ,type) + for v = (make-array '(6) + :element-type ctype + :initial-contents + (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) + when (notevery #'complexp v) + collect (list type v)) nil) @@ -263,7 +263,7 @@ (let ((i 0) a b) (values (notevery (progn (setf a (incf i)) #'identity) - (progn (setf b (incf i)) '(a b c d))) + (progn (setf b (incf i)) '(a b c d))) i a b)) nil 2 1 2) @@ -271,7 +271,7 @@ (deftest notevery.error.1 (check-type-error #'(lambda (x) (notevery x '(a b c))) - (typef '(or symbol function))) + (typef '(or symbol function))) nil) (deftest notevery.error.4 @@ -304,4 +304,4 @@ (deftest notevery.error.13 (signals-error (notevery #'car '(a b c)) type-error) - t) \ No newline at end of file + t) diff --git a/ansi-tests/nreconc.lsp b/ansi-tests/nreconc.lsp index b9567dcf..3ebf2789 100644 --- a/ansi-tests/nreconc.lsp +++ b/ansi-tests/nreconc.lsp @@ -9,10 +9,10 @@ (deftest nreconc.1 (let* ((x (list 'a 'b 'c)) - (y (copy-tree '(d e f))) - (result (nreconc x y))) + (y (copy-tree '(d e f))) + (result (nreconc x y))) (and (equal y '(d e f)) - result)) + result)) (c b a d e f)) (deftest nreconc.2 @@ -23,7 +23,7 @@ (let ((i 0) x y) (values (nreconc (progn (setf x (incf i)) (copy-list '(a b c))) - (progn (setf y (incf i)) (copy-list '(d e f)))) + (progn (setf y (incf i)) (copy-list '(d e f)))) i x y)) (c b a d e f) 2 1 2) diff --git a/ansi-tests/nreverse.lsp b/ansi-tests/nreverse.lsp index 394ec538..ac2b71f1 100644 --- a/ansi-tests/nreverse.lsp +++ b/ansi-tests/nreverse.lsp @@ -30,16 +30,16 @@ (deftest nreverse-vector.5 (let* ((x (make-array 5 :initial-contents '(1 2 3 4 5) - :fill-pointer t :adjustable t)) - (y (nreverse x))) + :fill-pointer t :adjustable t)) + (y (nreverse x))) (values y (equalt (type-of x) (type-of y)))) #(5 4 3 2 1) t) (deftest nreverse-vector.6 (let* ((x (make-array 10 :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 5)) - (y (nreverse x))) + :fill-pointer 5)) + (y (nreverse x))) (values y (equalt (type-of x) (type-of y)))) #(5 4 3 2 1) t) @@ -65,25 +65,25 @@ (deftest nreverse-vector.9 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float rational) - for vals = (loop for i from 1 to len collect (coerce i etype)) - for vec = (make-array len :element-type etype :initial-contents vals) - for nvec = (nreverse vec) - unless (and (eql (length nvec) len) - (every #'eql (reverse vals) nvec)) - collect (list etype vals nvec))) + for vals = (loop for i from 1 to len collect (coerce i etype)) + for vec = (make-array len :element-type etype :initial-contents vals) + for nvec = (nreverse vec) + unless (and (eql (length nvec) len) + (every #'eql (reverse vals) nvec)) + collect (list etype vals nvec))) nil) (deftest nreverse-vector.10 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float rational integer) - for etype = `(complex ,cetype) - for vals = (loop for i from 1 to len collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for vec = (make-array len :element-type etype :initial-contents vals) - for nvec = (nreverse vec) - unless (and (eql (length nvec) len) - (every #'eql (reverse vals) nvec)) - collect (list etype vals nvec))) + for etype = `(complex ,cetype) + for vals = (loop for i from 1 to len collect (complex (coerce i cetype) + (coerce (- i) cetype))) + for vec = (make-array len :element-type etype :initial-contents vals) + for nvec = (nreverse vec) + unless (and (eql (length nvec) len) + (every #'eql (reverse vals) nvec)) + collect (list etype vals nvec))) nil) @@ -100,9 +100,9 @@ (deftest nreverse-bit-vector.3 (let* ((x (make-array 10 :initial-contents '(0 0 0 1 1 0 1 0 1 0) - :fill-pointer 5 - :element-type 'bit)) - (y (nreverse x))) + :fill-pointer 5 + :element-type 'bit)) + (y (nreverse x))) y) #*11000) @@ -119,17 +119,17 @@ (deftest nreverse-string.3 (let* ((x (make-array 10 :initial-contents "abcdefghij" - :fill-pointer 5 - :element-type 'character)) - (y (nreverse x))) + :fill-pointer 5 + :element-type 'character)) + (y (nreverse x))) y) "edcba") (deftest nreverse-string.4 (let* ((x (make-array 10 :initial-contents "abcdefghij" - :fill-pointer 5 - :element-type 'base-char)) - (y (nreverse x))) + :fill-pointer 5 + :element-type 'base-char)) + (y (nreverse x))) y) "edcba") diff --git a/ansi-tests/nset-difference.lsp b/ansi-tests/nset-difference.lsp index cd756937..2e1a74a8 100644 --- a/ansi-tests/nset-difference.lsp +++ b/ansi-tests/nset-difference.lsp @@ -13,13 +13,13 @@ (deftest nset-difference.2 (let ((result - (nset-difference-with-check '(a b c) nil))) + (nset-difference-with-check '(a b c) nil))) (check-nset-difference '(a b c) nil result)) t) (deftest nset-difference.3 (let ((result - (nset-difference-with-check '(a b c d e f) '(f b d)))) + (nset-difference-with-check '(a b c d e f) '(f b d)))) (check-nset-difference '(a b c d e f) '(f b d) result)) t) @@ -27,7 +27,7 @@ (sort (copy-list (nset-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) - '(10 101 4 74 2 1391 7 17831))) + '(10 101 4 74 2 1391 7 17831))) #'<) (1 3 5 6 8)) @@ -37,7 +37,7 @@ (deftest nset-difference.6 (nset-difference-with-check '(a b c d e) '(d a b e) - :key nil) + :key nil) (c)) (deftest nset-difference.7 @@ -54,17 +54,17 @@ (deftest nset-difference.10 (nset-difference-with-check '(a b c d e) '(d a b e) - :test 'eq) + :test 'eq) (c)) (deftest nset-difference.11 (nset-difference-with-check '(a b c d e) '(d a b e) - :test 'eql) + :test 'eql) (c)) (deftest nset-difference.12 (nset-difference-with-check '(a b c d e) '(d a b e) - :test 'equal) + :test 'equal) (c)) (deftest nset-difference.13 @@ -73,14 +73,14 @@ (deftest nset-difference.14 (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) - '((a . 1) (c . 3)) - :key 'car) + '((a . 1) (c . 3)) + :key 'car) ((b . 2))) (deftest nset-difference.15 (nset-difference-with-check '((a . 1) (b . 2) (c . 3)) - '((a . 1) (c . 3)) - :key #'car) + '((a . 1) (c . 3)) + :key #'car) ((b . 2))) ;; @@ -94,10 +94,10 @@ (nset-difference-with-check '(1 2 3 4) '(e f g h) :test #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (eqt x y)))) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (eqt x y)))) #'<)) (1 2 3 4)) @@ -109,10 +109,10 @@ '(1 2 3 4) '(e f g h) :key #'identity :test #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (eqt x y)))) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (eqt x y)))) #'<)) (1 2 3 4)) @@ -124,25 +124,25 @@ '(1 2 3 4) '(e f g h) :test-not #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (not (eqt x y))))) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (not (eqt x y))))) #'<)) (1 2 3 4)) (deftest nset-difference.19 (block fail (sort (copy-list - (nset-difference-with-check - '(1 2 3 4) '(e f g h) - :test-not - #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (not (eqt x y))))) - #'<)) + (nset-difference-with-check + '(1 2 3 4) '(e f g h) + :test-not + #'(lambda (x y) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (not (eqt x y))))) + #'<)) (1 2 3 4)) (defharmless nset-difference.test-and-test-not.1 @@ -157,7 +157,7 @@ (let ((i 0) x y) (values (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4))) + (progn (setf y (incf i)) (list 2 3 4))) i x y)) (1) 2 1 2) @@ -165,9 +165,9 @@ (let ((i 0) x y z) (values (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4)) - :test (progn (setf z (incf i)) - #'(lambda (x y) (= x (1- y))))) + (progn (setf y (incf i)) (list 2 3 4)) + :test (progn (setf z (incf i)) + #'(lambda (x y) (= x (1- y))))) i x y z)) (4) 3 1 2 3) @@ -175,10 +175,10 @@ (let ((i 0) x y z w) (values (nset-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4)) - :test (progn (setf z (incf i)) - #'(lambda (x y) (= x (1- y)))) - :key (progn (setf w (incf i)) nil)) + (progn (setf y (incf i)) (list 2 3 4)) + :test (progn (setf z (incf i)) + #'(lambda (x y) (= x (1- y)))) + :key (progn (setf w (incf i)) nil)) i x y z w)) (4) 4 1 2 3 4) diff --git a/ansi-tests/nset-exclusive-or.lsp b/ansi-tests/nset-exclusive-or.lsp index 0e991d61..dcb40b79 100644 --- a/ansi-tests/nset-exclusive-or.lsp +++ b/ansi-tests/nset-exclusive-or.lsp @@ -13,13 +13,13 @@ (deftest nset-exclusive-or.2 (let ((result - (nset-exclusive-or-with-check '(a b c) nil))) + (nset-exclusive-or-with-check '(a b c) nil))) (check-set-exclusive-or '(a b c) nil result)) t) (deftest nset-exclusive-or.3 (let ((result - (nset-exclusive-or-with-check '(a b c d e f) '(f b d)))) + (nset-exclusive-or-with-check '(a b c d e f) '(f b d)))) (check-set-exclusive-or '(a b c d e f) '(f b d) result)) t) @@ -27,7 +27,7 @@ (sort (copy-list (nset-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) - '(10 101 4 74 2 1391 7 17831))) + '(10 101 4 74 2 1391 7 17831))) #'<) (1 3 5 6 8 10 74 101 1391 17831)) @@ -40,7 +40,7 @@ (deftest nset-exclusive-or.6 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :key nil) + :key nil) (c)) (deftest nset-exclusive-or.7 @@ -61,7 +61,7 @@ (deftest nset-exclusive-or.8-b (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :test-not (complement #'eql)) + :test-not (complement #'eql)) (c)) (deftest nset-exclusive-or.9 @@ -70,17 +70,17 @@ (deftest nset-exclusive-or.10 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'eq) + :test 'eq) (c)) (deftest nset-exclusive-or.11 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'eql) + :test 'eql) (c)) (deftest nset-exclusive-or.12 (nset-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'equal) + :test 'equal) (c)) ;;; (deftest nset-exclusive-or.13 @@ -89,21 +89,21 @@ (deftest nset-exclusive-or.14 (nset-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) - '((a . 10) (c . 3)) - :key 'car) + '((a . 10) (c . 3)) + :key 'car) ((b . 2))) (deftest nset-exclusive-or.15 (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) - '((a . 1) (c . 3313)) - :key #'car) + '((a . 1) (c . 3313)) + :key #'car) ((b . 2))) (deftest nset-exclusive-or.16 (nset-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) - '((a . 1) (c . 3313)) - :key #'car - :test-not (complement #'eql)) + '((a . 1) (c . 3313)) + :key #'car + :test-not (complement #'eql)) ((b . 2))) ;; @@ -112,69 +112,69 @@ ;; (deftest nset-exclusive-or.17 (let ((list1 '(a b c d)) - (list2 '(e f g h))) + (list2 '(e f g h))) (block fail (notnot-mv (nset-exclusive-or-with-check - list1 list2 - :test #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed))))))) + list1 list2 + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed))))))) t) (deftest nset-exclusive-or.17-a (let ((list1 '(a b c d)) - (list2 '(e f g h))) + (list2 '(e f g h))) (block fail (notnot-mv (nset-exclusive-or-with-check - list1 list2 - :key #'identity - :test #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed))))))) + list1 list2 + :key #'identity + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed))))))) t) (deftest nset-exclusive-or.18 (let ((list1 '(a b c d)) - (list2 '(e f g h))) + (list2 '(e f g h))) (block fail (notnot-mv (nset-exclusive-or-with-check - list1 list2 - :test-not - #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed)) - t))))) + list1 list2 + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t))))) t) (deftest nset-exclusive-or.18-a (let ((list1 '(a b c d)) - (list2 '(e f g h))) + (list2 '(e f g h))) (block fail (notnot-mv (nset-exclusive-or-with-check - list1 list2 - :key #'identity - :test-not - #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed)) - t))))) + list1 list2 + :key #'identity + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t))))) t) (defharmless nset-exclusive-or.test-and-test-not.1 (nset-exclusive-or (list 1 2 3 4) (list 1 7 3 8) - :test #'eql :test-not #'eql)) + :test #'eql :test-not #'eql)) (defharmless nset-exclusive-or.test-and-test-not.2 (nset-exclusive-or (list 1 2 3 4) (list 1 7 3 8) - :test-not #'eql :test #'eql)) + :test-not #'eql :test #'eql)) ;;; Order of argument evaluation tests @@ -183,9 +183,9 @@ (values (sort (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10))) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10))) #'<) i x y)) (2 4 6 10) 2 1 2) @@ -195,11 +195,11 @@ (values (sort (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :test (progn (setf z (incf i)) - #'eql)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :test (progn (setf z (incf i)) + #'eql)) #'<) i x y z)) (2 4 6 10) 3 1 2 3) @@ -209,12 +209,12 @@ (values (sort (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :test (progn (setf z (incf i)) - #'eql) - :key (progn (setf w (incf i)) nil)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :test (progn (setf z (incf i)) + #'eql) + :key (progn (setf w (incf i)) nil)) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) @@ -224,12 +224,12 @@ (values (sort (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :key (progn (setf z (incf i)) nil) - :test (progn (setf w (incf i)) - #'eql)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :key (progn (setf z (incf i)) nil) + :test (progn (setf w (incf i)) + #'eql)) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) @@ -239,12 +239,12 @@ (values (sort (nset-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :key (progn (setf z (incf i)) nil) - :key (progn (setf w (incf i)) - (complement #'eql))) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :key (progn (setf z (incf i)) nil) + :key (progn (setf w (incf i)) + (complement #'eql))) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) @@ -254,62 +254,62 @@ (deftest nset-exclusive.allow-other-keys.1 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :bad t :allow-other-keys t) - #'<) + :bad t :allow-other-keys t) + #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.2 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t :bad t) - #'<) + :allow-other-keys t :bad t) + #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.3 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t :bad t - :test #'(lambda (x y) (= x (1- y)))) - #'<) + :allow-other-keys t :bad t + :test #'(lambda (x y) (= x (1- y)))) + #'<) (1 6)) (deftest nset-exclusive.allow-other-keys.4 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t) - #'<) + :allow-other-keys t) + #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.5 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys nil) - #'<) + :allow-other-keys nil) + #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.6 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t - :allow-other-keys nil) - #'<) + :allow-other-keys t + :allow-other-keys nil) + #'<) (1 2 5 6)) (deftest nset-exclusive.allow-other-keys.7 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t - :allow-other-keys nil - '#:x 1) - #'<) + :allow-other-keys t + :allow-other-keys nil + '#:x 1) + #'<) (1 2 5 6)) (deftest nset-exclusive.keywords.8 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :test #'eql - :test #'/=) - #'<) + :test #'eql + :test #'/=) + #'<) (1 2 5 6)) (deftest nset-exclusive.keywords.9 (sort (nset-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :test #'/= - :test #'eql) - #'<) + :test #'/= + :test #'eql) + #'<) nil) ;;; Randomized test diff --git a/ansi-tests/nstring-capitalize.lsp b/ansi-tests/nstring-capitalize.lsp index fb16b92b..b0fb4565 100644 --- a/ansi-tests/nstring-capitalize.lsp +++ b/ansi-tests/nstring-capitalize.lsp @@ -7,52 +7,52 @@ (deftest nstring-capitalize.1 (let* ((s (copy-seq "abCd")) - (s2 (nstring-capitalize s))) + (s2 (nstring-capitalize s))) (values (eqt s s2) s)) t "Abcd") (deftest nstring-capitalize.2 (let* ((s (copy-seq "0adA2Cdd3wXy")) - (s2 (nstring-capitalize s))) + (s2 (nstring-capitalize s))) (values (eqt s s2) s)) t "0ada2cdd3wxy") (deftest nstring-capitalize.3 (let* ((s (copy-seq "1a")) - (s2 (nstring-capitalize s))) + (s2 (nstring-capitalize s))) (values (eqt s s2) s)) t "1a") (deftest nstring-capitalize.4 (let* ((s (copy-seq "a1a")) - (s2 (nstring-capitalize s))) + (s2 (nstring-capitalize s))) (values (eqt s s2) s)) t "A1a") (deftest nstring-capitalize.7 (let ((s "ABCDEF")) (loop for i from 0 to 5 - collect (nstring-capitalize (copy-seq s) :start i))) + collect (nstring-capitalize (copy-seq s) :start i))) ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) (deftest nstring-capitalize.8 (let ((s "ABCDEF")) (loop for i from 0 to 5 - collect (nstring-capitalize (copy-seq s) :start i :end nil))) + collect (nstring-capitalize (copy-seq s) :start i :end nil))) ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) (deftest nstring-capitalize.9 (let ((s "ABCDEF")) (loop for i from 0 to 6 - collect (nstring-capitalize (copy-seq s) :end i))) + collect (nstring-capitalize (copy-seq s) :end i))) ("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef")) (deftest nstring-capitalize.10 (let ((s "ABCDEF")) (loop for i from 0 to 5 - collect (loop for j from i to 6 - collect (nstring-capitalize (copy-seq s) - :start i :end j)))) + collect (loop for j from i to 6 + collect (nstring-capitalize (copy-seq s) + :start i :end j)))) (("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") ("ABCDEF" "ABCDEF" "ABcDEF" "ABcdEF" "ABcdeF" "ABcdef") ("ABCDEF" "ABCDEF" "ABCdEF" "ABCdeF" "ABCdef") @@ -71,41 +71,41 @@ (deftest nstring-capitalize.13 (loop for type in '(standard-char base-char character) - for s = (make-array '(10) :element-type type - :fill-pointer 5 - :initial-contents "aB0cDefGHi") - collect (list (copy-seq s) - (copy-seq (nstring-capitalize s)) - (copy-seq s) - (progn (setf (fill-pointer s) 10) (copy-seq s)) - )) + for s = (make-array '(10) :element-type type + :fill-pointer 5 + :initial-contents "aB0cDefGHi") + collect (list (copy-seq s) + (copy-seq (nstring-capitalize s)) + (copy-seq s) + (progn (setf (fill-pointer s) 10) (copy-seq s)) + )) (("aB0cD" "Ab0cd" "Ab0cd" "Ab0cdefGHi") ("aB0cD" "Ab0cd" "Ab0cd" "Ab0cdefGHi") ("aB0cD" "Ab0cd" "Ab0cd" "Ab0cdefGHi"))) (deftest nstring-capitalize.14 (loop for type in '(standard-char base-char character) - for s0 = (make-array '(10) :element-type type - :initial-contents "zZaB0cDefG") - for s = (make-array '(5) :element-type type - :displaced-to s0 - :displaced-index-offset 2) - collect (list (copy-seq s) - (nstring-capitalize s) - (copy-seq s) - s0)) + for s0 = (make-array '(10) :element-type type + :initial-contents "zZaB0cDefG") + for s = (make-array '(5) :element-type type + :displaced-to s0 + :displaced-index-offset 2) + collect (list (copy-seq s) + (nstring-capitalize s) + (copy-seq s) + s0)) (("aB0cD" "Ab0cd" "Ab0cd" "zZAb0cdefG") ("aB0cD" "Ab0cd" "Ab0cd" "zZAb0cdefG") ("aB0cD" "Ab0cd" "Ab0cd" "zZAb0cdefG"))) (deftest nstring-capitalize.15 (loop for type in '(standard-char base-char character) - for s = (make-array '(5) :element-type type - :adjustable t - :initial-contents "aB0cD") - collect (list (copy-seq s) - (nstring-capitalize s) - (copy-seq s))) + for s = (make-array '(5) :element-type type + :adjustable t + :initial-contents "aB0cD") + collect (list (copy-seq s) + (nstring-capitalize s) + (copy-seq s))) (("aB0cD" "Ab0cd" "Ab0cd") ("aB0cD" "Ab0cd" "Ab0cd") ("aB0cD" "Ab0cd" "Ab0cd"))) @@ -149,8 +149,8 @@ (deftest nstring-capitalize.error.4 (signals-error (nstring-capitalize (copy-seq "abc") :bad t - :allow-other-keys nil) - program-error) + :allow-other-keys nil) + program-error) t) (deftest nstring-capitalize.error.5 diff --git a/ansi-tests/nstring-downcase.lsp b/ansi-tests/nstring-downcase.lsp index 10a62742..1475cb4d 100644 --- a/ansi-tests/nstring-downcase.lsp +++ b/ansi-tests/nstring-downcase.lsp @@ -7,35 +7,35 @@ (deftest nstring-downcase.1 (let* ((s (copy-seq "A")) - (s2 (nstring-downcase s))) + (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "a") (deftest nstring-downcase.2 (let* ((s (copy-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) - (s2 (nstring-downcase s))) + (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyz") (deftest nstring-downcase.3 (let* ((s (copy-seq "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) - (s2 (nstring-downcase s))) + (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") (deftest nstring-downcase.6 (let* ((s (make-array 6 :element-type 'character - :initial-contents '(#\A #\B #\C #\D #\E #\F))) - (s2 (nstring-downcase s))) + :initial-contents '(#\A #\B #\C #\D #\E #\F))) + (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "abcdef") (deftest nstring-downcase.7 (let* ((s (make-array 6 :element-type 'standard-char - :initial-contents '(#\A #\B #\7 #\D #\E #\F))) - (s2 (nstring-downcase s))) + :initial-contents '(#\A #\B #\7 #\D #\E #\F))) + (s2 (nstring-downcase s))) (values (eqt s s2) s)) t "ab7def") @@ -45,22 +45,22 @@ (deftest nstring-downcase.8 (let ((s "ABCDEF")) (loop for i from 0 to 6 - collect (nstring-downcase (copy-seq s) :start i))) + collect (nstring-downcase (copy-seq s) :start i))) ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) (deftest nstring-downcase.9 (let ((s "ABCDEF")) (loop for i from 0 to 6 - collect (nstring-downcase (copy-seq s) :start i :end nil))) + collect (nstring-downcase (copy-seq s) :start i :end nil))) ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF")) (deftest nstring-downcase.10 (let ((s "ABCDE")) (loop for i from 0 to 4 - collect (loop for j from i to 5 - collect (string-invertcase - (nstring-downcase (copy-seq s) - :start i :end j))))) + collect (loop for j from i to 5 + collect (string-invertcase + (nstring-downcase (copy-seq s) + :start i :end j))))) (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") ("abcde" "abCde" "abCDe" "abCDE") @@ -74,41 +74,41 @@ (deftest nstring-downcase.12 (loop for type in '(standard-char base-char character) - for s = (make-array '(10) :element-type type - :fill-pointer 5 - :initial-contents "aB0cDefGHi") - collect (list (copy-seq s) - (copy-seq (nstring-downcase s)) - (copy-seq s) - (progn (setf (fill-pointer s) 10) (copy-seq s)) - )) + for s = (make-array '(10) :element-type type + :fill-pointer 5 + :initial-contents "aB0cDefGHi") + collect (list (copy-seq s) + (copy-seq (nstring-downcase s)) + (copy-seq s) + (progn (setf (fill-pointer s) 10) (copy-seq s)) + )) (("aB0cD" "ab0cd" "ab0cd" "ab0cdefGHi") ("aB0cD" "ab0cd" "ab0cd" "ab0cdefGHi") ("aB0cD" "ab0cd" "ab0cd" "ab0cdefGHi"))) (deftest nstring-downcase.13 (loop for type in '(standard-char base-char character) - for s0 = (make-array '(10) :element-type type - :initial-contents "zZaB0cDefG") - for s = (make-array '(5) :element-type type - :displaced-to s0 - :displaced-index-offset 2) - collect (list (copy-seq s) - (nstring-downcase s) - (copy-seq s) - s0)) + for s0 = (make-array '(10) :element-type type + :initial-contents "zZaB0cDefG") + for s = (make-array '(5) :element-type type + :displaced-to s0 + :displaced-index-offset 2) + collect (list (copy-seq s) + (nstring-downcase s) + (copy-seq s) + s0)) (("aB0cD" "ab0cd" "ab0cd" "zZab0cdefG") ("aB0cD" "ab0cd" "ab0cd" "zZab0cdefG") ("aB0cD" "ab0cd" "ab0cd" "zZab0cdefG"))) (deftest nstring-downcase.14 (loop for type in '(standard-char base-char character) - for s = (make-array '(5) :element-type type - :adjustable t - :initial-contents "aB0cD") - collect (list (copy-seq s) - (nstring-downcase s) - (copy-seq s))) + for s = (make-array '(5) :element-type type + :adjustable t + :initial-contents "aB0cD") + collect (list (copy-seq s) + (nstring-downcase s) + (copy-seq s))) (("aB0cD" "ab0cd" "ab0cd") ("aB0cD" "ab0cd" "ab0cd") ("aB0cD" "ab0cd" "ab0cd"))) @@ -151,8 +151,8 @@ (deftest nstring-downcase.error.4 (signals-error (nstring-downcase (copy-seq "abc") :bad t - :allow-other-keys nil) - program-error) + :allow-other-keys nil) + program-error) t) (deftest nstring-downcase.error.5 diff --git a/ansi-tests/nstring-upcase.lsp b/ansi-tests/nstring-upcase.lsp index c90676aa..49d51f24 100644 --- a/ansi-tests/nstring-upcase.lsp +++ b/ansi-tests/nstring-upcase.lsp @@ -7,35 +7,35 @@ (deftest nstring-upcase.1 (let* ((s (copy-seq "a")) - (s2 (nstring-upcase s))) + (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "A") (deftest nstring-upcase.2 (let* ((s (copy-seq "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz")) - (s2 (nstring-upcase s))) + (s2 (nstring-upcase s))) (values (eqt s s2) s)) t - "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ") + "ABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ") (deftest nstring-upcase.3 (let* ((s (copy-seq "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ")) - (s2 (nstring-upcase s))) + (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "0123456789!@#$%^&*()_-+=|\\{}[]:\";'<>?,./ ") (deftest nstring-upcase.6 (let* ((s (make-array 6 :element-type 'character - :initial-contents '(#\a #\b #\c #\d #\e #\f))) - (s2 (nstring-upcase s))) + :initial-contents '(#\a #\b #\c #\d #\e #\f))) + (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "ABCDEF") (deftest nstring-upcase.7 (let* ((s (make-array 6 :element-type 'standard-char - :initial-contents '(#\a #\b #\7 #\d #\e #\f))) - (s2 (nstring-upcase s))) + :initial-contents '(#\a #\b #\7 #\d #\e #\f))) + (s2 (nstring-upcase s))) (values (eqt s s2) s)) t "AB7DEF") @@ -44,22 +44,22 @@ (deftest nstring-upcase.8 (let ((s "abcdef")) (loop for i from 0 to 6 - collect (nstring-upcase (copy-seq s) :start i))) + collect (nstring-upcase (copy-seq s) :start i))) ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef")) (deftest nstring-upcase.9 (let ((s "abcdef")) (loop for i from 0 to 6 - collect - (nstring-upcase (copy-seq s) :start i :end nil))) + collect + (nstring-upcase (copy-seq s) :start i :end nil))) ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef")) (deftest nstring-upcase.10 (let ((s "abcde")) (loop for i from 0 to 4 - collect (loop for j from i to 5 - collect (nstring-upcase (copy-seq s) - :start i :end j)))) + collect (loop for j from i to 5 + collect (nstring-upcase (copy-seq s) + :start i :end j)))) (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") ("abcde" "abCde" "abCDe" "abCDE") @@ -73,41 +73,41 @@ (deftest nstring-upcase.12 (loop for type in '(standard-char base-char character) - for s = (make-array '(10) :element-type type - :fill-pointer 5 - :initial-contents "aB0cDefGHi") - collect (list (copy-seq s) - (copy-seq (nstring-upcase s)) - (copy-seq s) - (progn (setf (fill-pointer s) 10) (copy-seq s)) - )) + for s = (make-array '(10) :element-type type + :fill-pointer 5 + :initial-contents "aB0cDefGHi") + collect (list (copy-seq s) + (copy-seq (nstring-upcase s)) + (copy-seq s) + (progn (setf (fill-pointer s) 10) (copy-seq s)) + )) (("aB0cD" "AB0CD" "AB0CD" "AB0CDefGHi") ("aB0cD" "AB0CD" "AB0CD" "AB0CDefGHi") ("aB0cD" "AB0CD" "AB0CD" "AB0CDefGHi"))) (deftest nstring-upcase.13 (loop for type in '(standard-char base-char character) - for s0 = (make-array '(10) :element-type type - :initial-contents "zZaB0cDefG") - for s = (make-array '(5) :element-type type - :displaced-to s0 - :displaced-index-offset 2) - collect (list (copy-seq s) - (nstring-upcase s) - (copy-seq s) - s0)) + for s0 = (make-array '(10) :element-type type + :initial-contents "zZaB0cDefG") + for s = (make-array '(5) :element-type type + :displaced-to s0 + :displaced-index-offset 2) + collect (list (copy-seq s) + (nstring-upcase s) + (copy-seq s) + s0)) (("aB0cD" "AB0CD" "AB0CD" "zZAB0CDefG") ("aB0cD" "AB0CD" "AB0CD" "zZAB0CDefG") ("aB0cD" "AB0CD" "AB0CD" "zZAB0CDefG"))) (deftest nstring-upcase.14 (loop for type in '(standard-char base-char character) - for s = (make-array '(5) :element-type type - :adjustable t - :initial-contents "aB0cD") - collect (list (copy-seq s) - (nstring-upcase s) - (copy-seq s))) + for s = (make-array '(5) :element-type type + :adjustable t + :initial-contents "aB0cD") + collect (list (copy-seq s) + (nstring-upcase s) + (copy-seq s))) (("aB0cD" "AB0CD" "AB0CD") ("aB0cD" "AB0CD" "AB0CD") ("aB0cD" "AB0CD" "AB0CD"))) @@ -134,7 +134,7 @@ i a b c)) "aBCDef" 3 1 2 3) - + ;;; Error cases (deftest nstring-upcase.error.1 @@ -151,8 +151,8 @@ (deftest nstring-upcase.error.4 (signals-error (nstring-upcase (copy-seq "abc") :bad t - :allow-other-keys nil) - program-error) + :allow-other-keys nil) + program-error) t) (deftest nstring-upcase.error.5 diff --git a/ansi-tests/nsublis.lsp b/ansi-tests/nsublis.lsp index 5ee2c3a2..a33a5d59 100644 --- a/ansi-tests/nsublis.lsp +++ b/ansi-tests/nsublis.lsp @@ -9,51 +9,51 @@ (deftest nsublis.1 (check-nsublis '((a b) g (d e 10 g h) 15 . g) - '((e . e2) (g . 17))) + '((e . e2) (g . 17))) ((a b) 17 (d e2 10 17 h) 15 . 17)) (deftest nsublis.2 (check-nsublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) - '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) - :test #'equal) + '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) + :test #'equal) (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) (deftest nsublis.3 (check-nsublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) - '((30 . "foo"))) + '((30 . "foo"))) (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) (deftest nsublis.4 (check-nsublis (nsublis (copy-tree '((a . 2) (b . 4) (c . 1))) - (copy-tree '(a b c d e (a b c a d b) f))) + (copy-tree '(a b c d e (a b c a d b) f))) '((t . "yes")) :key #'(lambda (x) (and (typep x 'integer) - (evenp x)))) + (evenp x)))) ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) (deftest nsublis.5 (check-nsublis '("fee" (("fee" "Fie" "foo")) - fie ("fee" "fie")) - `((,(copy-seq "fie") . #\f))) + fie ("fee" "fie")) + `((,(copy-seq "fie") . #\f))) ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) (deftest nsublis.6 (check-nsublis '("fee" fie (("fee" "Fie" "foo") 1) - ("fee" "fie")) - `((,(copy-seq "fie") . #\f)) - :test 'equal) + ("fee" "fie")) + `((,(copy-seq "fie") . #\f)) + :test 'equal) ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) (deftest nsublis.7 (check-nsublis '(("aa" a b) - (z "bb" d) - ((x . "aa"))) - `((,(copy-seq "aa") . 1) - (,(copy-seq "bb") . 2)) - :test 'equal - :key #'(lambda (x) (if (consp x) (car x) - '*not-present*))) + (z "bb" d) + ((x . "aa"))) + `((,(copy-seq "aa") . 1) + (,(copy-seq "bb") . 2)) + :test 'equal + :key #'(lambda (x) (if (consp x) (car x) + '*not-present*))) (1 (z . 2) ((x . "aa")))) (deftest nsublis.8 @@ -63,7 +63,7 @@ ;; Check that a null key arg is ignored. (deftest nsublis.9 - (check-nsublis + (check-nsublis '(1 2 a b) '((1 . 2) (a . b)) :key nil) @@ -71,24 +71,24 @@ (deftest nsublis.10 (check-nsublis (list 0 3 8 20) - '((1 . x) (5 . y) (10 . z)) - :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) + '((1 . x) (5 . y) (10 . z)) + :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) (x y z 20)) (deftest nsublis.11 (check-nsublis (list 0 3 8 20) - '((1 . x) (5 . y) (10 . z)) - :test-not - #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) + '((1 . x) (5 . y) (10 . z)) + :test-not + #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) (x y z 20)) (defharmless nsublis.test-and-test-not.1 (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) - :test #'eql :test-not #'eql)) + :test #'eql :test-not #'eql)) (defharmless nsublis.test-and-test-not.2 (nsublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) - :test-not #'eql :test #'eql)) + :test-not #'eql :test #'eql)) ;;; Order of argument evaluation (deftest nsublis.order.1 @@ -96,9 +96,9 @@ (values (nsublis (progn (setf w (incf i)) - '((a . z))) + '((a . z))) (progn (setf x (incf i)) - (copy-tree '(a b c d))) + (copy-tree '(a b c d))) :test (progn (setf y (incf i)) #'eql) :key (progn (setf z (incf i)) #'identity)) i w x y z)) @@ -110,9 +110,9 @@ (values (nsublis (progn (setf w (incf i)) - '((a . z))) + '((a . z))) (progn (setf x (incf i)) - (copy-tree '(a b c d))) + (copy-tree '(a b c d))) :key (progn (setf y (incf i)) #'identity) :test-not (progn (setf z (incf i)) (complement #'eql)) ) @@ -144,8 +144,8 @@ (deftest nsublis.keywords.6 (nsublis '((1 . a)) (list 0 1 2) - :key #'(lambda (x) (if (numberp x) (1+ x) x)) - :key #'identity) + :key #'(lambda (x) (if (numberp x) (1+ x) x)) + :key #'identity) (a 1 2)) ;; Argument error cases @@ -168,27 +168,27 @@ (deftest nsublis.error.5 (signals-error (nsublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :test #'identity) - program-error) + (list 'a 'b 'c 'd) + :test #'identity) + program-error) t) (deftest nsublis.error.6 (signals-error (nsublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :key #'cons) - program-error) + (list 'a 'b 'c 'd) + :key #'cons) + program-error) t) (deftest nsublis.error.7 (signals-error (nsublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :test-not #'identity) - program-error) + (list 'a 'b 'c 'd) + :test-not #'identity) + program-error) t) (deftest nsublis.error.8 (signals-error (nsublis '((a . 1) . bad) - (list 'a 'b 'c 'd)) - type-error) + (list 'a 'b 'c 'd)) + type-error) t) diff --git a/ansi-tests/nsubst-if-not.lsp b/ansi-tests/nsubst-if-not.lsp index 521c2d2f..ba7131df 100644 --- a/ansi-tests/nsubst-if-not.lsp +++ b/ansi-tests/nsubst-if-not.lsp @@ -17,13 +17,13 @@ (deftest nsubst-if-not.2 (check-nsubst-if-not 'a (complement #'listp) - '((100 1) (2 3) (4 3 2 1) (a b c))) + '((100 1) (2 3) (4 3 2 1) (a b c))) a) (deftest nsubst-if-not.3 (check-nsubst-if-not 'c #'identity - '((100 1) (2 3) (4 3 2 1) (a b c)) - :key (complement #'listp)) + '((100 1) (2 3) (4 3 2 1) (a b c)) + :key (complement #'listp)) c) (deftest nsubst-if-not.4 @@ -32,14 +32,14 @@ #'(lambda (x) (not (eql x 17))) '((17) (17 22) (17 22 31) (17 21 34 54)) :key #'(lambda (x) - (and (consp x) - (car x)))) + (and (consp x) + (car x)))) (40 40 40 40)) (deftest nsubst-if-not.5 (check-nsubst-if-not 'a #'(lambda (x) (not (eql x 'b))) - '((a) (b) (c) (d)) - :key nil) + '((a) (b) (c) (d)) + :key nil) ((a) (a) (c) (d))) (deftest nsubst-if-not.6 @@ -112,7 +112,7 @@ (deftest nsubst-if-not.error.7 (signals-error (nsubst-if-not 'a #'null nil - :bad t :allow-other-keys nil) program-error) + :bad t :allow-other-keys nil) program-error) t) (deftest nsubst-if-not.error.8 diff --git a/ansi-tests/nsubst-if.lsp b/ansi-tests/nsubst-if.lsp index 6cce9fbb..ea88373a 100644 --- a/ansi-tests/nsubst-if.lsp +++ b/ansi-tests/nsubst-if.lsp @@ -17,8 +17,8 @@ (deftest nsubst-if.3 (check-nsubst-if '(z) - (complement #'consp) - '(a (a b) (c d e) (f g h i))) + (complement #'consp) + '(a (a b) (c d e) (f g h i))) ((z) ((z) (z) z) ((z) (z) (z) z) @@ -27,21 +27,21 @@ (deftest nsubst-if.4 (check-nsubst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) - :key #'listp) + :key #'listp) b) (deftest nsubst-if.5 (check-nsubst-if 4 #'(lambda (x) (eql x 1)) - '((1 3) (1) (1 10 20 30) (1 3 x y)) - :key #'(lambda (x) - (and (consp x) - (car x)))) + '((1 3) (1) (1 10 20 30) (1 3 x y)) + :key #'(lambda (x) + (and (consp x) + (car x)))) (4 4 4 4)) (deftest nsubst-if.6 (check-nsubst-if 'a #'(lambda (x) (eql x 'b)) - '((a) (b) (c) (d)) - :key nil) + '((a) (b) (c) (d)) + :key nil) ((a) (a) (c) (d))) (deftest nsubst-if.7 @@ -114,10 +114,10 @@ (deftest nsubst-if.error.7 (signals-error (nsubst-if 'a #'null nil :bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest nsubst-if.error.8 (signals-error (nsubst-if 'a #'null (list 'a nil 'c) :key #'cons) - program-error) + program-error) t) diff --git a/ansi-tests/nsubst.lsp b/ansi-tests/nsubst.lsp index f20b800f..e97863d9 100644 --- a/ansi-tests/nsubst.lsp +++ b/ansi-tests/nsubst.lsp @@ -23,7 +23,7 @@ (deftest nsubst.4 (check-nsubst 'grape 'dick - '(melville wrote (moby dick))) + '(melville wrote (moby dick))) (melville wrote (moby grape))) (deftest nsubst.5 @@ -42,8 +42,8 @@ 'foo "aaa" '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) :key #'(lambda (x) (if (and (numberp x) (evenp x)) - "aaa" - nil)) + "aaa" + nil)) :test #'string=) ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) @@ -52,26 +52,26 @@ 'foo nil '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) :key #'(lambda (x) (if (and (numberp x) (evenp x)) - (copy-seq "aaa") - nil)) + (copy-seq "aaa") + nil)) :test-not #'equal) ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) (deftest nsubst.9 (check-nsubst 'a 'b - (copy-tree '(a b c d a b)) - :key nil) + (copy-tree '(a b c d a b)) + :key nil) (a a c d a a)) (deftest nsubst.10 (check-nsubst 'x 10 (copy-tree '(1 2 10 20 30 4)) - :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) + :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) (1 2 10 x x 4)) (deftest nsubst.11 (check-nsubst 'x 10 (copy-tree '(1 2 10 20 30 4)) - :test-not #'(lambda (x y) - (not (and (realp x) (realp y) (< x y))))) + :test-not #'(lambda (x y) + (not (and (realp x) (realp y) (< x y))))) (1 2 10 x x 4)) (defharmless nsubset.test-and-test-not.1 @@ -85,10 +85,10 @@ (let ((i 0) v w x y z) (values (nsubst (progn (setf v (incf i)) 'b) - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) - :key (progn (setf y (incf i)) #'identity) - :test (progn (setf z (incf i)) #'eql)) + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) + :key (progn (setf y (incf i)) #'identity) + :test (progn (setf z (incf i)) #'eql)) i v w x y z)) ((10 b . b) b b c ((b)) z) 5 1 2 3 4 5) @@ -97,11 +97,11 @@ (let ((i 0) v w x y z) (values (nsubst (progn (setf v (incf i)) 'b) - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) - :test-not (progn (setf y (incf i)) (complement #'eql)) - :key (progn (setf z (incf i)) #'identity) - ) + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) + :test-not (progn (setf y (incf i)) (complement #'eql)) + :key (progn (setf z (incf i)) #'identity) + ) i v w x y z)) ((10 b . b) b b c ((b)) z) 5 1 2 3 4 5) @@ -126,7 +126,7 @@ (deftest nsubst.allow-other-keys.5 (nsubst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil - :bad t) + :bad t) (a a c)) (deftest nsubst.keywords.6 diff --git a/ansi-tests/nsubstitute-if-not.lsp b/ansi-tests/nsubstitute-if-not.lsp index dcfa2eb5..c37f84ad 100644 --- a/ansi-tests/nsubstitute-if-not.lsp +++ b/ansi-tests/nsubstitute-if-not.lsp @@ -63,48 +63,48 @@ (deftest nsubstitute-if-not-list.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))) + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-not-list.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :from-end t))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))) + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :from-end t))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-not-list.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) :initial-element 'a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-if-not-list.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c :from-end t))) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c :from-end t))) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) t) ;;; Tests on vectors @@ -167,94 +167,94 @@ (deftest nsubstitute-if-not-vector.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))) + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-not-vector.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :from-end t))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))) + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-not-vector.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 (+ i c)) :initial-element 'a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-if-not-vector.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c :from-end t))) - (equalp y (concatenate 'simple-vector - (make-array (- j c) :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) t) (deftest nsubstitute-if-not-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x))) + :fill-pointer 5)) + (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x))) result) #(z b z c b)) (deftest nsubstitute-if-not-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :from-end t))) + :fill-pointer 5)) + (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :from-end t))) result) #(z b z c b)) (deftest nsubstitute-if-not-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :count 1))) + :fill-pointer 5)) + (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x :count 1))) result) #(z b a c b)) (deftest nsubstitute-if-not-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x - :from-end t :count 1))) + :fill-pointer 5)) + (result (nsubstitute-if-not 'z (is-not-eql-p 'a) x + :from-end t :count 1))) result) #(a b z c b)) (deftest nsubstitute-if-not-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (nsubstitute-if-not 'x (is-not-eql-p 'c) v2 :count 1)) #(d a b x d a b c)) (deftest nsubstitute-if-not-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (nsubstitute-if-not 'x (is-not-eql-p 'c) v2 :count 1 :from-end t)) #(d a b c d a b x)) @@ -318,80 +318,80 @@ (deftest nsubstitute-if-not-string.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if-not #\x (is-not-eql-p #\a) x :start i :end j))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))) + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if-not #\x (is-not-eql-p #\a) x :start i :end j))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-if-not-string.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :from-end t))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))) + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-if-not-string.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :count c))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 (+ i c)) :initial-element #\a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :count c))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a))))))) t) (deftest nsubstitute-if-not-string.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :count c :from-end t))) - (equalp y (concatenate 'simple-string - (make-array (- j c) :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) t) (deftest nsubstitute-if-not-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x))) + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x))) result) "zbzcb") (deftest nsubstitute-if-not-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :from-end t))) + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :from-end t))) result) "zbzcb") (deftest nsubstitute-if-not-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :count 1))) + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x :count 1))) result) "zbacb") (deftest nsubstitute-if-not-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x - :from-end t :count 1))) + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if-not #\z (is-not-eql-p #\a) x + :from-end t :count 1))) result) "abzcb") @@ -418,163 +418,163 @@ (deftest nsubstitute-if-not-bit-vector.1 (let* ((orig #*) - (x (copy-seq orig)) - (result (nsubstitute-if-not 0 (is-not-eql-p 1) x))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eql-p 1) x))) result) #*) (deftest nsubstitute-if-not-bit-vector.2 (let* ((orig #*) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x))) result) #*) (deftest nsubstitute-if-not-bit-vector.3 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 0 (is-not-eql-p 1) x))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eql-p 1) x))) result) #*000000) (deftest nsubstitute-if-not-bit-vector.4 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x))) result) #*111111) (deftest nsubstitute-if-not-bit-vector.5 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :start 1))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :start 1))) result) #*011111) - + (deftest nsubstitute-if-not-bit-vector.6 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 0 (is-not-eql-p 1) x :start 2 :end nil))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eql-p 1) x :start 2 :end nil))) result) #*010000) (deftest nsubstitute-if-not-bit-vector.7 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :end 4))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :end 4))) result) #*111101) - + (deftest nsubstitute-if-not-bit-vector.8 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 0 (is-not-eql-p 1) x :end nil))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eql-p 1) x :end nil))) result) #*000000) (deftest nsubstitute-if-not-bit-vector.9 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 0 (is-not-eql-p 1) x :end 3))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eql-p 1) x :end 3))) result) #*000101) (deftest nsubstitute-if-not-bit-vector.10 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 0 (is-not-eql-p 1) x :start 2 :end 4))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 0 (is-not-eql-p 1) x :start 2 :end 4))) result) #*010001) (deftest nsubstitute-if-not-bit-vector.11 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :start 2 :end 4))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :start 2 :end 4))) result) #*011101) (deftest nsubstitute-if-not-bit-vector.12 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count 1))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count 1))) result) #*110101) (deftest nsubstitute-if-not-bit-vector.13 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count 0))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count 0))) result) #*010101) (deftest nsubstitute-if-not-bit-vector.14 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count -1))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count -1))) result) #*010101) (deftest nsubstitute-if-not-bit-vector.15 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count 1 :from-end t))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count 1 :from-end t))) result) #*010111) (deftest nsubstitute-if-not-bit-vector.16 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count 0 :from-end t))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count 0 :from-end t))) result) #*010101) (deftest nsubstitute-if-not-bit-vector.17 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count -1 :from-end t))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count -1 :from-end t))) result) #*010101) (deftest nsubstitute-if-not-bit-vector.18 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count nil))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count nil))) result) #*111111) (deftest nsubstitute-if-not-bit-vector.19 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count nil :from-end t))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 0) x :count nil :from-end t))) result) #*111111) (deftest nsubstitute-if-not-bit-vector.20 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*0000000000) - (x (copy-seq orig)) - (y (nsubstitute-if-not 1 (is-not-eql-p 0) x :start i :end j :count c))) - (equalp y (concatenate - 'simple-bit-vector - (make-list i :initial-element 0) - (make-list c :initial-element 1) - (make-list (- 10 (+ i c)) :initial-element 0))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (nsubstitute-if-not 1 (is-not-eql-p 0) x :start i :end j :count c))) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0))))))) t) (deftest nsubstitute-if-not-bit-vector.21 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*1111111111) - (x (copy-seq orig)) - (y (nsubstitute-if-not 0 (is-not-eql-p 1) x :start i :end j :count c :from-end t))) - (equalp y (concatenate - 'simple-bit-vector - (make-list (- j c) :initial-element 1) - (make-list c :initial-element 0) - (make-list (- 10 j) :initial-element 1))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (nsubstitute-if-not 0 (is-not-eql-p 1) x :start i :end j :count c :from-end t))) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1))))))) t) @@ -582,86 +582,86 @@ (deftest nsubstitute-if-not-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car))) + (x (copy-seq orig)) + (result (nsubstitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car))) result) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-if-not-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if-not '(a 10) (is-not-eql-p 'a) x - :key #'car :start 1 :end 5))) + (x (copy-seq orig)) + (result (nsubstitute-if-not '(a 10) (is-not-eql-p 'a) x + :key #'car :start 1 :end 5))) result) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-if-not-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car))) + (x (copy-seq orig)) + (result (nsubstitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car))) result) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - + (deftest nsubstitute-if-not-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car :start 1 :end 5))) + (x (copy-seq orig)) + (result (nsubstitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car :start 1 :end 5))) result) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-if-not-string.24 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute-if-not #\a (is-not-eql-p #\1) x :key #'nextdigit))) + (x (copy-seq orig)) + (result (nsubstitute-if-not #\a (is-not-eql-p #\1) x :key #'nextdigit))) result) "a1a2342a15") - + (deftest nsubstitute-if-not-string.25 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute-if-not #\a (is-not-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) + (x (copy-seq orig)) + (result (nsubstitute-if-not #\a (is-not-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) result) "01a2342015") (deftest nsubstitute-if-not-bit-vector.26 (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 1) x :key #'1+))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 1) x :key #'1+))) result) #*11111111111111111) - + (deftest nsubstitute-if-not-bit-vector.27 (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (nsubstitute-if-not 1 (is-not-eql-p 1) x :key #'1+ :start 1 :end 10))) + (x (copy-seq orig)) + (result (nsubstitute-if-not 1 (is-not-eql-p 1) x :key #'1+ :start 1 :end 10))) result) #*01111111111010110) (deftest nsubstitute-if-not-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if-not 1 #'onep x))) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if-not 1 #'onep x))) result) #*11111) (deftest nsubstitute-if-not-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if-not 1 #'onep x :from-end t))) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if-not 1 #'onep x :from-end t))) result) #*11111) (deftest nsubstitute-if-not-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if-not 1 #'onep x :count 1))) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if-not 1 #'onep x :count 1))) result) #*11011) (deftest nsubstitute-if-not-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if-not 1 #'onep x :from-end t :count 1))) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if-not 1 #'onep x :from-end t :count 1))) result) #*01111) @@ -704,37 +704,37 @@ (deftest nsubstitute-if-not.allow-other-keys.1 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :allow-other-keys t :bad t) + :allow-other-keys t :bad t) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.2 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :bad t :allow-other-keys t) + :bad t :allow-other-keys t) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.3 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :allow-other-keys nil :bad t) + :allow-other-keys nil :bad t) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.4 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t - :allow-other-keys t :allow-other-keys nil) + :allow-other-keys t :allow-other-keys nil) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.5 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :allow-other-keys t :key #'1-) + :allow-other-keys t :key #'1-) (1 a a a 1 a a)) (deftest nsubstitute-if-not.keywords.6 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :key #'1- :key #'identity) + :key #'1- :key #'identity) (1 a a a 1 a a)) (deftest nsubstitute-if-not.allow-other-keys.7 (nsubstitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :bad t :allow-other-keys nil) + :bad t :allow-other-keys nil) (a a 0 a a 0 a)) (deftest nsubstitute-if-not.allow-other-keys.8 @@ -762,8 +762,8 @@ (deftest nsubstitute-if-not.error.5 (signals-error (nsubstitute-if-not 'a #'null nil - 'bad t :allow-other-keys nil) - program-error) + 'bad t :allow-other-keys nil) + program-error) t) (deftest nsubstitute-if-not.error.6 @@ -784,14 +784,14 @@ (deftest nsubstitute-if-not.error.10 (signals-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) - :key #'car) - type-error) + :key #'car) + type-error) t) (deftest nsubstitute-if-not.error.11 (signals-error (nsubstitute-if-not 'a #'identity (list 'a 'b 'c) - :key #'cons) - program-error) + :key #'cons) + program-error) t) (deftest nsubstitute-if-not.error.12 diff --git a/ansi-tests/nsubstitute-if.lsp b/ansi-tests/nsubstitute-if.lsp index a8230f61..1f36de7e 100644 --- a/ansi-tests/nsubstitute-if.lsp +++ b/ansi-tests/nsubstitute-if.lsp @@ -63,48 +63,48 @@ (deftest nsubstitute-if-list.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))) + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-list.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))) + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-list.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :count c))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) :initial-element 'a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :count c))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-if-list.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :count c :from-end t))) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :count c :from-end t))) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) t) ;;; Tests on vectors @@ -167,86 +167,86 @@ (deftest nsubstitute-if-vector.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))) + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-vector.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))) + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-if-vector.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :count c))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 (+ i c)) :initial-element 'a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :count c))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-if-vector.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :count c :from-end t))) - (equalp y (concatenate 'simple-vector - (make-array (- j c) :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute-if 'x (is-eql-p 'a) x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) t) (deftest nsubstitute-if-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if 'z (is-eql-p 'a) x))) + :fill-pointer 5)) + (result (nsubstitute-if 'z (is-eql-p 'a) x))) result) #(z b z c b)) (deftest nsubstitute-if-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if 'z (is-eql-p 'a) x :from-end t))) + :fill-pointer 5)) + (result (nsubstitute-if 'z (is-eql-p 'a) x :from-end t))) result) #(z b z c b)) (deftest nsubstitute-if-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if 'z (is-eql-p 'a) x :count 1))) + :fill-pointer 5)) + (result (nsubstitute-if 'z (is-eql-p 'a) x :count 1))) result) #(z b a c b)) (deftest nsubstitute-if-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute-if 'z (is-eql-p 'a) x :from-end t :count 1))) + :fill-pointer 5)) + (result (nsubstitute-if 'z (is-eql-p 'a) x :from-end t :count 1))) result) #(a b z c b)) (deftest nsubstitute-if-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (nsubstitute-if 'x (is-eql-p 'c) v2 :count 1) v1)) @@ -255,8 +255,8 @@ (deftest nsubstitute-if-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (nsubstitute-if 'x (is-eql-p 'c) v2 :count 1 :from-end t) v1)) @@ -323,79 +323,79 @@ (deftest nsubstitute-if-string.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if #\x (is-eql-p #\a) x :start i :end j))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))) + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if #\x (is-eql-p #\a) x :start i :end j))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-if-string.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if #\x (is-eql-p #\a) x :start i :end j :from-end t))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))) + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if #\x (is-eql-p #\a) x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-if-string.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if #\x (is-eql-p #\a) x :start i :end j :count c))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 (+ i c)) :initial-element #\a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if #\x (is-eql-p #\a) x :start i :end j :count c))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a))))))) t) (deftest nsubstitute-if-string.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute-if #\x (is-eql-p #\a) x :start i :end j :count c :from-end t))) - (equalp y (concatenate 'simple-string - (make-array (- j c) :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute-if #\x (is-eql-p #\a) x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) t) (deftest nsubstitute-if-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if #\z (is-eql-p #\a) x))) + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if #\z (is-eql-p #\a) x))) result) "zbzcb") (deftest nsubstitute-if-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if #\z (is-eql-p #\a) x :from-end t))) + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if #\z (is-eql-p #\a) x :from-end t))) result) "zbzcb") (deftest nsubstitute-if-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if #\z (is-eql-p #\a) x :count 1))) + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if #\z (is-eql-p #\a) x :count 1))) result) "zbacb") (deftest nsubstitute-if-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute-if #\z (is-eql-p #\a) x :from-end t :count 1))) + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute-if #\z (is-eql-p #\a) x :from-end t :count 1))) result) "abzcb") @@ -425,249 +425,249 @@ (deftest nsubstitute-if-bit-vector.1 (let* ((orig #*) - (x (copy-seq orig)) - (result (nsubstitute-if 0 (is-eql-p 1) x))) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eql-p 1) x))) result) #*) (deftest nsubstitute-if-bit-vector.2 (let* ((orig #*) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x))) result) #*) (deftest nsubstitute-if-bit-vector.3 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 0 (is-eql-p 1) x))) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eql-p 1) x))) result) #*000000) (deftest nsubstitute-if-bit-vector.4 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x))) result) #*111111) (deftest nsubstitute-if-bit-vector.5 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :start 1))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x :start 1))) result) #*011111) - + (deftest nsubstitute-if-bit-vector.6 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 0 (is-eql-p 1) x :start 2 :end nil))) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eql-p 1) x :start 2 :end nil))) result) #*010000) (deftest nsubstitute-if-bit-vector.7 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :end 4))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x :end 4))) result) #*111101) - + (deftest nsubstitute-if-bit-vector.8 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 0 (is-eql-p 1) x :end nil))) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eql-p 1) x :end nil))) result) #*000000) (deftest nsubstitute-if-bit-vector.9 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 0 (is-eql-p 1) x :end 3))) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eql-p 1) x :end 3))) result) #*000101) (deftest nsubstitute-if-bit-vector.10 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 0 (is-eql-p 1) x :start 2 :end 4))) + (x (copy-seq orig)) + (result (nsubstitute-if 0 (is-eql-p 1) x :start 2 :end 4))) result) #*010001) (deftest nsubstitute-if-bit-vector.11 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :start 2 :end 4))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x :start 2 :end 4))) result) #*011101) (deftest nsubstitute-if-bit-vector.12 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count 1))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x :count 1))) result) #*110101) (deftest nsubstitute-if-bit-vector.13 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count 0))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x :count 0))) result) #*010101) (deftest nsubstitute-if-bit-vector.14 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count -1))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x :count -1))) result) #*010101) (deftest nsubstitute-if-bit-vector.15 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count 1 :from-end t))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x :count 1 :from-end t))) result) #*010111) (deftest nsubstitute-if-bit-vector.16 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count 0 :from-end t))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x :count 0 :from-end t))) result) #*010101) (deftest nsubstitute-if-bit-vector.17 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count -1 :from-end t))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x :count -1 :from-end t))) result) #*010101) (deftest nsubstitute-if-bit-vector.18 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count nil))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x :count nil))) result) #*111111) (deftest nsubstitute-if-bit-vector.19 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 0) x :count nil :from-end t))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 0) x :count nil :from-end t))) result) #*111111) (deftest nsubstitute-if-bit-vector.20 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*0000000000) - (x (copy-seq orig)) - (y (nsubstitute-if 1 (is-eql-p 0) x :start i :end j :count c))) - (equalp y (concatenate - 'simple-bit-vector - (make-list i :initial-element 0) - (make-list c :initial-element 1) - (make-list (- 10 (+ i c)) :initial-element 0))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (nsubstitute-if 1 (is-eql-p 0) x :start i :end j :count c))) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0))))))) t) (deftest nsubstitute-if-bit-vector.21 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*1111111111) - (x (copy-seq orig)) - (y (nsubstitute-if 0 (is-eql-p 1) x :start i :end j :count c :from-end t))) - (equalp y (concatenate - 'simple-bit-vector - (make-list (- j c) :initial-element 1) - (make-list c :initial-element 0) - (make-list (- 10 j) :initial-element 1))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (nsubstitute-if 0 (is-eql-p 1) x :start i :end j :count c :from-end t))) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1))))))) t) ;;; More tests (deftest nsubstitute-if-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if '(a 10) (is-eql-p 'a) x :key #'car))) + (x (copy-seq orig)) + (result (nsubstitute-if '(a 10) (is-eql-p 'a) x :key #'car))) result) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-if-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if '(a 10) (is-eql-p 'a) x - :key #'car :start 1 :end 5))) + (x (copy-seq orig)) + (result (nsubstitute-if '(a 10) (is-eql-p 'a) x + :key #'car :start 1 :end 5))) result) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-if-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if '(a 10) (is-eql-p 'a) x :key #'car))) + (x (copy-seq orig)) + (result (nsubstitute-if '(a 10) (is-eql-p 'a) x :key #'car))) result) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - + (deftest nsubstitute-if-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute-if '(a 10) (is-eql-p 'a) x :key #'car :start 1 :end 5))) + (x (copy-seq orig)) + (result (nsubstitute-if '(a 10) (is-eql-p 'a) x :key #'car :start 1 :end 5))) result) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-if-string.24 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute-if #\a (is-eql-p #\1) x :key #'nextdigit))) + (x (copy-seq orig)) + (result (nsubstitute-if #\a (is-eql-p #\1) x :key #'nextdigit))) result) "a1a2342a15") - + (deftest nsubstitute-if-string.25 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute-if #\a (is-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) + (x (copy-seq orig)) + (result (nsubstitute-if #\a (is-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) result) "01a2342015") (deftest nsubstitute-if-bit-vector.26 (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 1) x :key #'1+))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 1) x :key #'1+))) result) #*11111111111111111) - + (deftest nsubstitute-if-bit-vector.27 (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (nsubstitute-if 1 (is-eql-p 1) x :key #'1+ :start 1 :end 10))) + (x (copy-seq orig)) + (result (nsubstitute-if 1 (is-eql-p 1) x :key #'1+ :start 1 :end 10))) result) #*01111111111010110) (deftest nsubstitute-if-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if 1 #'zerop x))) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if 1 #'zerop x))) result) #*11111) (deftest nsubstitute-if-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if 1 #'zerop x :from-end t))) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if 1 #'zerop x :from-end t))) result) #*11111) (deftest nsubstitute-if-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if 1 #'zerop x :count 1))) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if 1 #'zerop x :count 1))) result) #*11011) (deftest nsubstitute-if-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute-if 1 #'zerop x :from-end t :count 1))) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute-if 1 #'zerop x :from-end t :count 1))) result) #*01111) @@ -718,17 +718,17 @@ (deftest nsubstitute-if.allow-other-keys.3 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :allow-other-keys nil :bad t) + :allow-other-keys nil :bad t) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.4 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t - :allow-other-keys t :allow-other-keys nil) + :allow-other-keys t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.5 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) - :allow-other-keys t :key #'1-) + :allow-other-keys t :key #'1-) (a 2 0 3 a 0 3)) (deftest nsubstitute-if.keywords.6 @@ -737,7 +737,7 @@ (deftest nsubstitute-if.allow-other-keys.7 (nsubstitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :bad t :allow-other-keys nil) + :bad t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest nsubstitute-if.allow-other-keys.8 @@ -784,12 +784,12 @@ (deftest nsubstitute-if.error.10 (signals-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) - :key #'car) type-error) + :key #'car) type-error) t) (deftest nsubstitute-if.error.11 (signals-error (nsubstitute-if 'a #'identity (list 'a 'b 'c) - :key #'cons) program-error) + :key #'cons) program-error) t) (deftest nsubstitute-if.error.12 diff --git a/ansi-tests/nsubstitute.lsp b/ansi-tests/nsubstitute.lsp index c91fcb8a..d84b0998 100644 --- a/ansi-tests/nsubstitute.lsp +++ b/ansi-tests/nsubstitute.lsp @@ -63,90 +63,90 @@ (deftest nsubstitute-list.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))) + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-list.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :from-end t))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))) + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :from-end t))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-list.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :count c))) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) :initial-element 'a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c))) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-list.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) t) (deftest nsubstitute-list.19 (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) + (x (copy-seq orig)) + (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) result) (1 2 x x x x x 8 9)) (deftest nsubstitute-list.20 (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) result) (1 2 x 4 5 6 7 8 9)) (deftest nsubstitute-list.21 (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) - :from-end t))) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) + :from-end t))) result) (1 2 3 4 5 6 7 x 9)) (deftest nsubstitute-list.22 (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) result) (1 2 x 4 5 6 7 8 9)) (deftest nsubstitute-list.23 (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) - :from-end t))) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) + :from-end t))) result) (1 2 3 4 5 6 7 x 9)) @@ -210,121 +210,121 @@ (deftest nsubstitute-vector.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))) + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-vector.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :from-end t))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))) + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))) t) (deftest nsubstitute-vector.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :count c))) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 (+ i c)) :initial-element 'a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c))) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a))))))) t) (deftest nsubstitute-vector.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) - (equalp y (concatenate 'simple-vector - (make-array (- j c) :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (nsubstitute 'x 'a x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) t) (deftest nsubstitute-vector.19 (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) + (x (copy-seq orig)) + (result (nsubstitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) result) #(1 2 x x x x x 8 9)) (deftest nsubstitute-vector.20 (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) result) #(1 2 x 4 5 6 7 8 9)) (deftest nsubstitute-vector.21 (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) - :from-end t))) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) + :from-end t))) result) #(1 2 3 4 5 6 7 x 9)) (deftest nsubstitute-vector.22 (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) result) #(1 2 x 4 5 6 7 8 9)) (deftest nsubstitute-vector.23 (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) - :from-end t))) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) + :from-end t))) result) #(1 2 3 4 5 6 7 x 9)) (deftest nsubstitute-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute 'z 'a x))) + :fill-pointer 5)) + (result (nsubstitute 'z 'a x))) result) #(z b z c b)) (deftest nsubstitute-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute 'z 'a x :from-end t))) + :fill-pointer 5)) + (result (nsubstitute 'z 'a x :from-end t))) result) #(z b z c b)) (deftest nsubstitute-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute 'z 'a x :count 1))) + :fill-pointer 5)) + (result (nsubstitute 'z 'a x :count 1))) result) #(z b a c b)) (deftest nsubstitute-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (nsubstitute 'z 'a x :from-end t :count 1))) + :fill-pointer 5)) + (result (nsubstitute 'z 'a x :from-end t :count 1))) result) #(a b z c b)) @@ -388,137 +388,137 @@ (deftest nsubstitute-string.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute #\x #\a x :start i :end j))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))) + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute #\x #\a x :start i :end j))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-string.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute #\x #\a x :start i :end j :from-end t))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))) + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute #\x #\a x :start i :end j :from-end t))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))) t) (deftest nsubstitute-string.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute #\x #\a x :start i :end j :count c))) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 (+ i c)) :initial-element #\a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute #\x #\a x :start i :end j :count c))) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a))))))) t) (deftest nsubstitute-string.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (nsubstitute #\x #\a x :start i :end j :count c :from-end t))) - (equalp y (concatenate 'simple-string - (make-array (- j c) :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (nsubstitute #\x #\a x :start i :end j :count c :from-end t))) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) t) (deftest nsubstitute-string.19 (let* ((orig "123456789") - (x (copy-seq orig)) - (result (nsubstitute #\x #\5 x :test #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (<= (abs (- a b)) 2))))) + (x (copy-seq orig)) + (result (nsubstitute #\x #\5 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (<= (abs (- a b)) 2))))) result) "12xxxxx89") (deftest nsubstitute-string.20 (let* ((orig "123456789") - (x (copy-seq orig)) - (c -4) - (result (nsubstitute #\x #\5 x :test #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c 2) (= (+ b c) a))))) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute #\x #\5 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c 2) (= (+ b c) a))))) result) "12x456789") (deftest nsubstitute-string.21 (let* ((orig "123456789") - (x (copy-seq orig)) - (c 5) - (result (nsubstitute #\x #\9 x :test #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c -2) (= (+ b c) a)) - :from-end t))) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute #\x #\9 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c -2) (= (+ b c) a)) + :from-end t))) result) "1234567x9") (deftest nsubstitute-string.22 (let* ((orig "123456789") - (x (copy-seq orig)) - (c -4) - (result (nsubstitute #\x #\5 x :test-not #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c 2) (/= (+ b c) a))))) + (x (copy-seq orig)) + (c -4) + (result (nsubstitute #\x #\5 x :test-not #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c 2) (/= (+ b c) a))))) result) "12x456789") (deftest nsubstitute-string.23 (let* ((orig "123456789") - (x (copy-seq orig)) - (c 5) - (result (nsubstitute #\x #\9 x :test-not #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c -2) (/= (+ b c) a)) - :from-end t))) + (x (copy-seq orig)) + (c 5) + (result (nsubstitute #\x #\9 x :test-not #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c -2) (/= (+ b c) a)) + :from-end t))) result) "1234567x9") (deftest nsubstitute-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute #\z #\a x))) + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute #\z #\a x))) result) "zbzcb") (deftest nsubstitute-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute #\z #\a x :from-end t))) + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute #\z #\a x :from-end t))) result) "zbzcb") (deftest nsubstitute-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute #\z #\a x :count 1))) + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute #\z #\a x :count 1))) result) "zbacb") (deftest nsubstitute-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (nsubstitute #\z #\a x :from-end t :count 1))) + :fill-pointer 5 :element-type 'character)) + (result (nsubstitute #\z #\a x :from-end t :count 1))) result) "abzcb") @@ -527,198 +527,198 @@ (deftest nsubstitute-bit-vector.1 (let* ((orig #*) - (x (copy-seq orig)) - (result (nsubstitute 0 1 x))) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x))) result) #*) (deftest nsubstitute-bit-vector.2 (let* ((orig #*) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x))) result) #*) (deftest nsubstitute-bit-vector.3 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 0 1 x))) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x))) result) #*000000) (deftest nsubstitute-bit-vector.4 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x))) result) #*111111) (deftest nsubstitute-bit-vector.5 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :start 1))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :start 1))) result) #*011111) - + (deftest nsubstitute-bit-vector.6 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 0 1 x :start 2 :end nil))) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x :start 2 :end nil))) result) #*010000) (deftest nsubstitute-bit-vector.7 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :end 4))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :end 4))) result) #*111101) - + (deftest nsubstitute-bit-vector.8 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 0 1 x :end nil))) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x :end nil))) result) #*000000) (deftest nsubstitute-bit-vector.9 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 0 1 x :end 3))) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x :end 3))) result) #*000101) (deftest nsubstitute-bit-vector.10 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 0 1 x :start 2 :end 4))) + (x (copy-seq orig)) + (result (nsubstitute 0 1 x :start 2 :end 4))) result) #*010001) (deftest nsubstitute-bit-vector.11 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :start 2 :end 4))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :start 2 :end 4))) result) #*011101) (deftest nsubstitute-bit-vector.12 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count 1))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count 1))) result) #*110101) (deftest nsubstitute-bit-vector.13 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count 0))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count 0))) result) #*010101) (deftest nsubstitute-bit-vector.14 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count -1))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count -1))) result) #*010101) (deftest nsubstitute-bit-vector.15 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count 1 :from-end t))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count 1 :from-end t))) result) #*010111) (deftest nsubstitute-bit-vector.16 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count 0 :from-end t))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count 0 :from-end t))) result) #*010101) (deftest nsubstitute-bit-vector.17 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count -1 :from-end t))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count -1 :from-end t))) result) #*010101) (deftest nsubstitute-bit-vector.18 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count nil))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count nil))) result) #*111111) (deftest nsubstitute-bit-vector.19 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (nsubstitute 1 0 x :count nil :from-end t))) + (x (copy-seq orig)) + (result (nsubstitute 1 0 x :count nil :from-end t))) result) #*111111) (deftest nsubstitute-bit-vector.20 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*0000000000) - (x (copy-seq orig)) - (y (nsubstitute 1 0 x :start i :end j :count c))) - (equalp y (concatenate - 'simple-bit-vector - (make-list i :initial-element 0) - (make-list c :initial-element 1) - (make-list (- 10 (+ i c)) :initial-element 0))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (nsubstitute 1 0 x :start i :end j :count c))) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0))))))) t) (deftest nsubstitute-bit-vector.21 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*1111111111) - (x (copy-seq orig)) - (y (nsubstitute 0 1 x :start i :end j :count c :from-end t))) - (equalp y (concatenate - 'simple-bit-vector - (make-list (- j c) :initial-element 1) - (make-list c :initial-element 0) - (make-list (- 10 j) :initial-element 1))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (nsubstitute 0 1 x :start i :end j :count c :from-end t))) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1))))))) t) (deftest nsubstitute-bit-vector.22 (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) + (x (copy-seq orig)) + (c 0) + (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) result) #*0111110101) (deftest nsubstitute-bit-vector.23 (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) - (not (and (<= 2 c 5) (= a b))))))) + (x (copy-seq orig)) + (c 0) + (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) + (not (and (<= 2 c 5) (= a b))))))) result) #*0111110101) (deftest nsubstitute-bit-vector.24 (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) - :from-end t))) + (x (copy-seq orig)) + (c 0) + (result (nsubstitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) + :from-end t))) result) #*0101011111) (deftest nsubstitute-bit-vector.25 (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) - (not (and (<= 2 c 5) (= a b)))) - :from-end t))) + (x (copy-seq orig)) + (c 0) + (result (nsubstitute 1 0 x :test-not #'(lambda (a b) (incf c) + (not (and (<= 2 c 5) (= a b)))) + :from-end t))) result) #*0101011111) @@ -751,64 +751,64 @@ (deftest nsubstitute-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car))) result) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest nsubstitute-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) result) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-list.26 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eql)))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eql)))) result) ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest nsubstitute-list.27 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eql))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eql))) result) - ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest nsubstitute-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car))) result) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - + (deftest nsubstitute-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :start 1 :end 5))) result) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest nsubstitute-vector.26 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eql)))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :test (complement #'eql)))) result) #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest nsubstitute-vector.27 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eql))) + (x (copy-seq orig)) + (result (nsubstitute '(a 10) 'a x :key #'car :test-not #'eql))) result) #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest nsubstitute-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (nsubstitute 'x 'c v2 :count 1) v1)) @@ -817,8 +817,8 @@ (deftest nsubstitute-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (nsubstitute 'x 'c v2 :count 1 :from-end t) v1)) @@ -828,29 +828,29 @@ (deftest nsubstitute-string.24 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute #\a #\1 x :key #'nextdigit))) + (x (copy-seq orig)) + (result (nsubstitute #\a #\1 x :key #'nextdigit))) result) "a1a2342a15") - + (deftest nsubstitute-string.25 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) + (x (copy-seq orig)) + (result (nsubstitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) result) "01a2342015") (deftest nsubstitute-string.26 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute #\a #\1 x :key #'nextdigit :test (complement #'eql)))) + (x (copy-seq orig)) + (result (nsubstitute #\a #\1 x :key #'nextdigit :test (complement #'eql)))) result) "0a0aaaa0aa") (deftest nsubstitute-string.27 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (nsubstitute #\a #\1 x :key #'nextdigit :test-not #'eql))) + (x (copy-seq orig)) + (result (nsubstitute #\a #\1 x :key #'nextdigit :test-not #'eql))) result) "0a0aaaa0aa") @@ -879,29 +879,29 @@ (deftest nsubstitute-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute 1 0 x))) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute 1 0 x))) result) #*11111) (deftest nsubstitute-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute 1 0 x :from-end t))) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute 1 0 x :from-end t))) result) #*11111) (deftest nsubstitute-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute 1 0 x :count 1))) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute 1 0 x :count 1))) result) #*11011) (deftest nsubstitute-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (nsubstitute 1 0 x :from-end t :count 1))) + :fill-pointer 5 :element-type 'bit)) + (result (nsubstitute 1 0 x :from-end t :count 1))) result) #*01111) @@ -951,17 +951,17 @@ (deftest nsubstitute.allow-other-keys.3 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t - :allow-other-keys nil :bad t) + :allow-other-keys nil :bad t) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.4 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :bad t - :allow-other-keys t :allow-other-keys nil) + :allow-other-keys t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.5 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) - :allow-other-keys t :key #'1-) + :allow-other-keys t :key #'1-) (a 2 0 3 a 0 3)) (deftest nsubstitute.keywords.6 @@ -970,7 +970,7 @@ (deftest nsubstitute.allow-other-keys.7 (nsubstitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t - :bad t :allow-other-keys nil) + :bad t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest nsubstitute.allow-other-keys.8 diff --git a/ansi-tests/nth-value.lsp b/ansi-tests/nth-value.lsp index 216601a2..bfcf99f6 100644 --- a/ansi-tests/nth-value.lsp +++ b/ansi-tests/nth-value.lsp @@ -19,8 +19,8 @@ (deftest nth-value.4 (loop for i from 0 to 19 - collect (nth-value i (values 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k - 'l 'm 'n 'o 'p 'q 'r 's))) + collect (nth-value i (values 'a 'b 'c 'd 'e 'f 'g 'h 'i 'j 'k + 'l 'm 'n 'o 'p 'q 'r 's))) (a b c d e f g h i j k l m n o p q r s nil)) (deftest nth-value.5 @@ -48,7 +48,7 @@ (let ((i 0) x y) (values (nth-value (progn (setf x (incf i)) 3) - (progn (setf y (incf i)) (values 'a 'b 'c 'd 'e 'f 'g))) + (progn (setf y (incf i)) (values 'a 'b 'c 'd 'e 'f 'g))) i x y)) d 2 1 2) @@ -56,18 +56,18 @@ (deftest nth-value.error.1 (signals-error (funcall (macro-function 'nth-value)) - program-error) + program-error) t) - + (deftest nth-value.error.2 (signals-error (funcall (macro-function 'nth-value) - '(nth-value 1 '(a b c))) - program-error) + '(nth-value 1 '(a b c))) + program-error) t) (deftest nth-value.error.3 (signals-error (funcall (macro-function 'nth-value) - '(nth-value 1 '(a b c)) - nil nil) - program-error) + '(nth-value 1 '(a b c)) + nil nil) + program-error) t) diff --git a/ansi-tests/nth.lsp b/ansi-tests/nth.lsp index 090042ae..333751e8 100644 --- a/ansi-tests/nth.lsp +++ b/ansi-tests/nth.lsp @@ -22,11 +22,11 @@ ;;; Test side effects, evaluation order in assignment to NTH (deftest nth.order.1 (let ((i 0) - (x (list 'a 'b 'c 'd)) - y z) + (x (list 'a 'b 'c 'd)) + y z) (and (eqlt (setf (nth (setf y (incf i)) x) (progn (setf z (incf i)) 'z)) - 'z) + 'z) (eqlt y 1) (eqlt z 2) x)) @@ -36,7 +36,7 @@ (let ((i 0) x y (z '(a b c d e))) (values (nth (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) z)) + (progn (setf y (incf i)) z)) i x y)) b 2 1 2) diff --git a/ansi-tests/nthcdr.lsp b/ansi-tests/nthcdr.lsp index 8441b60f..36e68151 100644 --- a/ansi-tests/nthcdr.lsp +++ b/ansi-tests/nthcdr.lsp @@ -63,7 +63,7 @@ (let ((i 0) x y) (values (nthcdr (setf x (incf i)) - (progn (setf y (incf i)) '(a b c d))) + (progn (setf y (incf i)) '(a b c d))) i x y)) (b c d) 2 1 2) diff --git a/ansi-tests/number-comparison.lsp b/ansi-tests/number-comparison.lsp index 0a004a4d..20830b56 100644 --- a/ansi-tests/number-comparison.lsp +++ b/ansi-tests/number-comparison.lsp @@ -37,20 +37,20 @@ (deftest =.1 (loop for x in *numbers* - unless (= x) - collect x) + unless (= x) + collect x) nil) (deftest =.2 (loop for x in *numbers* - unless (= x x) - collect x) + unless (= x x) + collect x) nil) (deftest =.3 (loop for x in *numbers* - unless (= x x x) - collect x) + unless (= x x x) + collect x) nil) (deftest =.4 @@ -59,34 +59,34 @@ (deftest =.5 (loop for i from 1 to 10000 - for i2 = (1+ i) - never (or (= i i2) (= i2 i))) + for i2 = (1+ i) + never (or (= i i2) (= i2 i))) t) (deftest =.6 (loop for i from 5 to 10000 by 17 - for j from 2 to i by 19 - for r = (/ i j) - unless (and (not (= r (1+ r))) - (not (= r 0)) - (not (= r (- r))) - (= r r)) - collect r) - nil) - + for j from 2 to i by 19 + for r = (/ i j) + unless (and (not (= r (1+ r))) + (not (= r 0)) + (not (= r (- r))) + (= r r)) + collect r) + nil) + (deftest =.7 (let ((args nil)) (loop for i from 1 to (min 256 (1- call-arguments-limit)) - do (push 17 args) - always (apply #'= args))) + do (push 17 args) + always (apply #'= args))) t) (deftest =.8 (loop for i from 2 to (min 256 (1- call-arguments-limit)) - for args = (append (make-list (1- i) :initial-element 7) - (list 23)) - when (apply #'= args) - collect args) + for args = (append (make-list (1- i) :initial-element 7) + (list 23)) + when (apply #'= args) + collect args) nil) @@ -108,110 +108,110 @@ (deftest =.13 (let ((nums '(0 0.0s0 0.0f0 0.0d0 0.0l0 - #c(0.0s0 0.0s0) #c(0.0f0 0.0f0) - #c(0.0d0 0.0d0) #c(0.0l0 0.0l0)))) + #c(0.0s0 0.0s0) #c(0.0f0 0.0f0) + #c(0.0d0 0.0d0) #c(0.0l0 0.0l0)))) (loop for x in nums - append - (loop for y in nums - unless (= x y) - collect (list x y)))) + append + (loop for y in nums + unless (= x y) + collect (list x y)))) nil) (deftest =.14 (let ((nums '(17 17.0s0 17.0f0 17.0d0 17.0l0 - #c(17.0s0 0.0s0) #c(17.0f0 0.0f0) - #c(17.0d0 0.0d0) #c(17.0l0 0.0l0)))) + #c(17.0s0 0.0s0) #c(17.0f0 0.0f0) + #c(17.0d0 0.0d0) #c(17.0l0 0.0l0)))) (loop for x in nums - append - (loop for y in nums - unless (= x y) - collect (list x y)))) + append + (loop for y in nums + unless (= x y) + collect (list x y)))) nil) (deftest =.15 (let ((nums '(-17 -17.0s0 -17.0f0 -17.0d0 -17.0l0 - #c(-17.0s0 0.0s0) #c(-17.0f0 0.0f0) - #c(-17.0d0 0.0d0) #c(-17.0l0 0.0l0)))) + #c(-17.0s0 0.0s0) #c(-17.0f0 0.0f0) + #c(-17.0d0 0.0d0) #c(-17.0l0 0.0l0)))) (loop for x in nums - append - (loop for y in nums - unless (= x y) - collect (list x y)))) + append + (loop for y in nums + unless (= x y) + collect (list x y)))) nil) (deftest =.16 (let ((n 60000) (m 30000)) (loop for x = (- (random n) m) - for y = (- (random n) m) - for z = (- (random n) m) - for w = (- (random n) m) - for a = (* x y) - for b = (* x w) - for c = (* y z) - for d = (* w z) - repeat 10000 - when (and (/= b 0) - (/= d 0) - (or (not (= (/ a b) (/ c d))) - (/= (/ a b) (/ c d)))) - collect (list a b c d))) + for y = (- (random n) m) + for z = (- (random n) m) + for w = (- (random n) m) + for a = (* x y) + for b = (* x w) + for c = (* y z) + for d = (* w z) + repeat 10000 + when (and (/= b 0) + (/= d 0) + (or (not (= (/ a b) (/ c d))) + (/= (/ a b) (/ c d)))) + collect (list a b c d))) nil) ;;; Comparison of a rational with a float (deftest =.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat+rat/i = (+ xrat rat/i) - nconc - (if (= x xrat+rat/i) - (list (list x i xrat+rat/i)) - nil)))) + for eps in (list short-float-epsilon single-float-epsilon + double-float-epsilon long-float-epsilon) + for exp = (nth-value 1 (decode-float eps)) + for radix = (float-radix eps) + when (< (* (log radix 2) exp) 1000) + nconc + (let* ((rat (rational eps)) + (xrat (rational x))) + (loop for i from 2 to 100 + for rat/i = (/ rat i) + for xrat+rat/i = (+ xrat rat/i) + nconc + (if (= x xrat+rat/i) + (list (list x i xrat+rat/i)) + nil)))) nil) (deftest =.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-negative-epsilon single-float-negative-epsilon - double-float-negative-epsilon long-float-negative-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat-rat/i = (- xrat rat/i) - nconc - (if (= x xrat-rat/i) - (list (list x i xrat-rat/i)) - nil)))) + for eps in (list short-float-negative-epsilon single-float-negative-epsilon + double-float-negative-epsilon long-float-negative-epsilon) + for exp = (nth-value 1 (decode-float eps)) + for radix = (float-radix eps) + when (< (* (log radix 2) exp) 1000) + nconc + (let* ((rat (rational eps)) + (xrat (rational x))) + (loop for i from 2 to 100 + for rat/i = (/ rat i) + for xrat-rat/i = (- xrat rat/i) + nconc + (if (= x xrat-rat/i) + (list (list x i xrat-rat/i)) + nil)))) nil) (deftest =.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float) - for d = (and (<= x bound) (truncate x)) - when (and d (or (= (* 3/2 d) x) - (= x (* 5/4 d)))) - collect (list x d (* 3/2 d) (* 5/4 d)))) + most-positive-double-float most-positive-long-float) + for d = (and (<= x bound) (truncate x)) + when (and d (or (= (* 3/2 d) x) + (= x (* 5/4 d)))) + collect (list x d (* 3/2 d) (* 5/4 d)))) nil) (deftest =.order.1 (let ((i 0) x y) (values (= (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2)) + (progn (setf y (incf i)) 2)) i x y)) nil 2 1 2) @@ -219,8 +219,8 @@ (let ((i 0) x y z) (values (= (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 3)) + (progn (setf y (incf i)) 2) + (progn (setf z (incf i)) 3)) i x y z)) nil 3 1 2 3) @@ -241,20 +241,20 @@ (deftest /=.1 (loop for x in *numbers* - unless (/= x) - collect x) + unless (/= x) + collect x) nil) (deftest /=.2 (loop for x in *numbers* - when (/= x x) - collect x) + when (/= x x) + collect x) nil) (deftest /=.3 (loop for x in *numbers* - when (/= x x x) - collect x) + when (/= x x x) + collect x) nil) (deftest /=.4 @@ -267,37 +267,37 @@ (deftest /=.5 (loop for i from 1 to 10000 - for i2 = (1+ i) - always (and (/= i i2) (/= i2 i))) + for i2 = (1+ i) + always (and (/= i i2) (/= i2 i))) t) (deftest /=.6 (loop for i from 5 to 10000 by 17 - for j from 2 to i by 19 - for r = (/ i j) - when (or (not (/= r (1+ r))) - (not (/= r 0)) - (not (/= r (- r))) - (/= r r)) - collect r) - nil) - + for j from 2 to i by 19 + for r = (/ i j) + when (or (not (/= r (1+ r))) + (not (/= r 0)) + (not (/= r (- r))) + (/= r r)) + collect r) + nil) + (deftest /=.7 (let ((args (list 17)) - (args2 nil)) + (args2 nil)) (loop for i from 2 to (min 256 (1- call-arguments-limit)) - do (push 17 args) - do (push i args2) - always (and (not (apply #'/= args)) - (apply #'/= args2)))) + do (push 17 args) + do (push i args2) + always (and (not (apply #'/= args)) + (apply #'/= args2)))) t) (deftest /=.8 (loop for i from 2 to (min 256 (1- call-arguments-limit)) - for args = (append (make-list (1- i) :initial-element 7) - (list 7)) - when (apply #'/= args) - collect args) + for args = (append (make-list (1- i) :initial-element 7) + (list 7)) + when (apply #'/= args) + collect args) nil) @@ -319,90 +319,90 @@ (deftest /=.13 (let ((nums '(0 0.0s0 0.0f0 0.0d0 0.0l0 - #c(0.0s0 0.0s0) #c(0.0f0 0.0f0) - #c(0.0d0 0.0d0) #c(0.0l0 0.0l0)))) + #c(0.0s0 0.0s0) #c(0.0f0 0.0f0) + #c(0.0d0 0.0d0) #c(0.0l0 0.0l0)))) (loop for x in nums - append - (loop for y in nums - when (/= x y) - collect (list x y)))) + append + (loop for y in nums + when (/= x y) + collect (list x y)))) nil) (deftest /=.14 (let ((nums '(17 17.0s0 17.0f0 17.0d0 17.0l0 - #c(17.0s0 0.0s0) #c(17.0f0 0.0f0) - #c(17.0d0 0.0d0) #c(17.0l0 0.0l0)))) + #c(17.0s0 0.0s0) #c(17.0f0 0.0f0) + #c(17.0d0 0.0d0) #c(17.0l0 0.0l0)))) (loop for x in nums - append - (loop for y in nums - when (/= x y) - collect (list x y)))) + append + (loop for y in nums + when (/= x y) + collect (list x y)))) nil) (deftest /=.15 (let ((nums '(-17 -17.0s0 -17.0f0 -17.0d0 -17.0l0 - #c(-17.0s0 0.0s0) #c(-17.0f0 0.0f0) - #c(-17.0d0 0.0d0) #c(-17.0l0 0.0l0)))) + #c(-17.0s0 0.0s0) #c(-17.0f0 0.0f0) + #c(-17.0d0 0.0d0) #c(-17.0l0 0.0l0)))) (loop for x in nums - append - (loop for y in nums - when (/= x y) - collect (list x y)))) + append + (loop for y in nums + when (/= x y) + collect (list x y)))) nil) (deftest /=.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat+rat/i = (+ xrat rat/i) - nconc - (if (/= x xrat+rat/i) - nil - (list (list x i xrat+rat/i)))))) + for eps in (list short-float-epsilon single-float-epsilon + double-float-epsilon long-float-epsilon) + for exp = (nth-value 1 (decode-float eps)) + for radix = (float-radix eps) + when (< (* (log radix 2) exp) 1000) + nconc + (let* ((rat (rational eps)) + (xrat (rational x))) + (loop for i from 2 to 100 + for rat/i = (/ rat i) + for xrat+rat/i = (+ xrat rat/i) + nconc + (if (/= x xrat+rat/i) + nil + (list (list x i xrat+rat/i)))))) nil) (deftest /=.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-negative-epsilon single-float-negative-epsilon - double-float-negative-epsilon long-float-negative-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat-rat/i = (- xrat rat/i) - nconc - (if (/= x xrat-rat/i) - nil - (list (list x i xrat-rat/i)))))) + for eps in (list short-float-negative-epsilon single-float-negative-epsilon + double-float-negative-epsilon long-float-negative-epsilon) + for exp = (nth-value 1 (decode-float eps)) + for radix = (float-radix eps) + when (< (* (log radix 2) exp) 1000) + nconc + (let* ((rat (rational eps)) + (xrat (rational x))) + (loop for i from 2 to 100 + for rat/i = (/ rat i) + for xrat-rat/i = (- xrat rat/i) + nconc + (if (/= x xrat-rat/i) + nil + (list (list x i xrat-rat/i)))))) nil) (deftest /=.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float) - for d = (and (<= x bound) (truncate x)) - unless (or (null d) (and (/= (* 3/2 d) x) - (/= x (* 5/4 d)))) - collect (list x d (* 3/2 d) (* 5/4 d)))) + most-positive-double-float most-positive-long-float) + for d = (and (<= x bound) (truncate x)) + unless (or (null d) (and (/= (* 3/2 d) x) + (/= x (* 5/4 d)))) + collect (list x d (* 3/2 d) (* 5/4 d)))) nil) (deftest /=.order.1 (let ((i 0) x y) (values (notnot (/= (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2))) + (progn (setf y (incf i)) 2))) i x y)) t 2 1 2) @@ -410,8 +410,8 @@ (let ((i 0) x y z) (values (notnot (/= (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 3))) + (progn (setf y (incf i)) 2) + (progn (setf z (incf i)) 3))) i x y z)) t 3 1 2 3) @@ -445,147 +445,147 @@ (defparameter *number-less-tests* (let* ((n (- most-positive-fixnum most-negative-fixnum)) - (n2 (* 1000 n))) + (n2 (* 1000 n))) (nconc (loop for i = (+ (random n) most-negative-fixnum) - for i2 = (+ i (random most-positive-fixnum)) - repeat 1000 - nconc - (list (list i i2 t) (list i2 i nil))) + for i2 = (+ i (random most-positive-fixnum)) + repeat 1000 + nconc + (list (list i i2 t) (list i2 i nil))) (loop for i = (random n2) - for i2 = (+ (random n2) i) - repeat 1000 - nconc - (list (list i i2 t) (list i2 i nil))) + for i2 = (+ (random n2) i) + repeat 1000 + nconc + (list (list i i2 t) (list i2 i nil))) (loop for x in *universe* - when (integerp x) - nconc (list (list x (1+ x) t) - (list (1+ x) x nil))) + when (integerp x) + nconc (list (list x (1+ x) t) + (list (1+ x) x nil))) (loop for x in *universe* - when (realp x) - collect (list x x nil)) + when (realp x) + collect (list x x nil)) (loop for x in *universe* - when (and (realp x) (>= x 1)) - nconc - (loop for epsilon in (list short-float-epsilon - single-float-epsilon - double-float-epsilon - long-float-epsilon) - for bound in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for lower-bound in (list most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - when (and (<= (abs (float-exponent lower-bound)) 500) - (<= (abs (float-exponent x)) 500) - (<= (abs (float-exponent bound)) 500)) - when (<= (rational lower-bound) - (rational x) - (rational bound)) - nconc - (let* ((y (float x one)) - (z (* y (- one (* 2 epsilon))))) - (list (list y z nil) - (list z y t))))) - + when (and (realp x) (>= x 1)) + nconc + (loop for epsilon in (list short-float-epsilon + single-float-epsilon + double-float-epsilon + long-float-epsilon) + for bound in (list most-positive-short-float + most-positive-single-float + most-positive-double-float + most-positive-long-float) + for lower-bound in (list most-negative-short-float + most-negative-single-float + most-negative-double-float + most-negative-long-float) + for one in '(1.0s0 1.0f0 1.0d0 1.0l0) + when (and (<= (abs (float-exponent lower-bound)) 500) + (<= (abs (float-exponent x)) 500) + (<= (abs (float-exponent bound)) 500)) + when (<= (rational lower-bound) + (rational x) + (rational bound)) + nconc + (let* ((y (float x one)) + (z (* y (- one (* 2 epsilon))))) + (list (list y z nil) + (list z y t))))) + (loop for x in *universe* - when (and (realp x) (<= x -1)) - nconc - (loop for epsilon in (list short-float-epsilon - single-float-epsilon - double-float-epsilon - long-float-epsilon) - for bound in (list most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float) - for upper-bound in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - when (and (<= (abs (float-exponent bound)) 500) - (<= (abs (float-exponent x)) 500) - (<= (abs (float-exponent upper-bound)) 500)) - when (<= (rational bound) - (rational x) - (rational upper-bound)) - nconc - (let* ((y (float x one))) - (let ((z (* y (- one (* 2 epsilon))))) - (list (list y z t) - (list z y nil)))))) - + when (and (realp x) (<= x -1)) + nconc + (loop for epsilon in (list short-float-epsilon + single-float-epsilon + double-float-epsilon + long-float-epsilon) + for bound in (list most-negative-short-float + most-negative-single-float + most-negative-double-float + most-negative-long-float) + for upper-bound in (list most-positive-short-float + most-positive-single-float + most-positive-double-float + most-positive-long-float) + for one in '(1.0s0 1.0f0 1.0d0 1.0l0) + when (and (<= (abs (float-exponent bound)) 500) + (<= (abs (float-exponent x)) 500) + (<= (abs (float-exponent upper-bound)) 500)) + when (<= (rational bound) + (rational x) + (rational upper-bound)) + nconc + (let* ((y (float x one))) + (let ((z (* y (- one (* 2 epsilon))))) + (list (list y z t) + (list z y nil)))))) + (loop for x in *universe* - when (and (realp x) (< -1 x 1)) - nconc - (loop for epsilon in (list short-float-epsilon - single-float-epsilon - double-float-epsilon - long-float-epsilon) - for lower-bound in (list most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float) - for upper-bound in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - when (and (<= (abs (float-exponent lower-bound)) 500) - (<= (abs (float-exponent x)) 500) - (<= (abs (float-exponent upper-bound)) 500)) - when (<= (rational lower-bound) - (rational x) - (rational upper-bound)) - nconc - (handler-case - (let* ((y (float x one)) - (z1 (+ y epsilon)) - (z2 (- y epsilon))) - (list (list y z1 t) - (list z1 y nil) - (list y z2 nil) - (list z2 y t))) - (arithmetic-error () nil))) - )))) + when (and (realp x) (< -1 x 1)) + nconc + (loop for epsilon in (list short-float-epsilon + single-float-epsilon + double-float-epsilon + long-float-epsilon) + for lower-bound in (list most-negative-short-float + most-negative-single-float + most-negative-double-float + most-negative-long-float) + for upper-bound in (list most-positive-short-float + most-positive-single-float + most-positive-double-float + most-positive-long-float) + for one in '(1.0s0 1.0f0 1.0d0 1.0l0) + when (and (<= (abs (float-exponent lower-bound)) 500) + (<= (abs (float-exponent x)) 500) + (<= (abs (float-exponent upper-bound)) 500)) + when (<= (rational lower-bound) + (rational x) + (rational upper-bound)) + nconc + (handler-case + (let* ((y (float x one)) + (z1 (+ y epsilon)) + (z2 (- y epsilon))) + (list (list y z1 t) + (list z1 y nil) + (list y z2 nil) + (list z2 y t))) + (arithmetic-error () nil))) + )))) (deftest <.4 (loop for (x y result . rest) in *number-less-tests* - unless (if (< x y) result (not result)) - collect (list* x y result rest)) + unless (if (< x y) result (not result)) + collect (list* x y result rest)) nil) (deftest <.5 (loop for x in *universe* - when (and (typep x 'real) - (not (< x))) - collect x) + when (and (typep x 'real) + (not (< x))) + collect x) nil) (deftest <.6 (let ((args (list 17)) - (args2 nil)) + (args2 nil)) (loop for i from 2 to (min 256 (1- call-arguments-limit)) - do (push 17 args) - do (push (- i) args2) - unless (and (not (apply #'< args)) - (apply #'< args2)) - collect (list args args2))) + do (push 17 args) + do (push (- i) args2) + unless (and (not (apply #'< args)) + (apply #'< args2)) + collect (list args args2))) nil) (deftest <.7 (let* ((len (min 256 (1- call-arguments-limit))) - (args-proto (loop for i from 1 to len collect i))) + (args-proto (loop for i from 1 to len collect i))) (loop for i from 1 below len - for args = (copy-list args-proto) - do (setf (elt args i) 0) - never (apply #'< args))) + for args = (copy-list args-proto) + do (setf (elt args i) 0) + never (apply #'< args))) t) ;;; Check that < is antisymmetric @@ -605,63 +605,63 @@ (deftest <.11 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - never (or (< (- x) x) - (< x (- x)))) + never (or (< (- x) x) + (< x (- x)))) t) (deftest <.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat+rat/i = (+ xrat rat/i) - nconc - (if (< x xrat+rat/i) - nil - (list (list x i xrat+rat/i)))))) + for eps in (list short-float-epsilon single-float-epsilon + double-float-epsilon long-float-epsilon) + for exp = (nth-value 1 (decode-float eps)) + for radix = (float-radix eps) + when (< (* (log radix 2) exp) 1000) + nconc + (let* ((rat (rational eps)) + (xrat (rational x))) + (loop for i from 2 to 100 + for rat/i = (/ rat i) + for xrat+rat/i = (+ xrat rat/i) + nconc + (if (< x xrat+rat/i) + nil + (list (list x i xrat+rat/i)))))) nil) (deftest <.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-negative-epsilon single-float-negative-epsilon - double-float-negative-epsilon long-float-negative-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat-rat/i = (- xrat rat/i) - nconc - (if (< x xrat-rat/i) - (list (list x i xrat-rat/i)) - nil)))) + for eps in (list short-float-negative-epsilon single-float-negative-epsilon + double-float-negative-epsilon long-float-negative-epsilon) + for exp = (nth-value 1 (decode-float eps)) + for radix = (float-radix eps) + when (< (* (log radix 2) exp) 1000) + nconc + (let* ((rat (rational eps)) + (xrat (rational x))) + (loop for i from 2 to 100 + for rat/i = (/ rat i) + for xrat-rat/i = (- xrat rat/i) + nconc + (if (< x xrat-rat/i) + (list (list x i xrat-rat/i)) + nil)))) nil) (deftest <.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float) - for d = (and (<= x bound) (truncate x)) - unless (or (null d) (and (< x (* 3/2 d)) - (not (< (* 17/16 d) x)))) - collect (list x d (* 3/2 d) (* 17/16 d)))) + most-positive-double-float most-positive-long-float) + for d = (and (<= x bound) (truncate x)) + unless (or (null d) (and (< x (* 3/2 d)) + (not (< (* 17/16 d) x)))) + collect (list x d (* 3/2 d) (* 17/16 d)))) nil) (deftest <.order.1 (let ((i 0) x y) (values (notnot (< (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2))) + (progn (setf y (incf i)) 2))) i x y)) t 2 1 2) @@ -669,8 +669,8 @@ (let ((i 0) x y z) (values (notnot (< (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 3))) + (progn (setf y (incf i)) 2) + (progn (setf z (incf i)) 3))) i x y z)) t 3 1 2 3) @@ -704,148 +704,148 @@ (defparameter *number-less-or-equal-tests* (let* ((n (- most-positive-fixnum most-negative-fixnum)) - (n2 (* 1000 n))) + (n2 (* 1000 n))) (nconc (loop for i = (+ (random n) most-negative-fixnum) - for i2 = (+ i (random most-positive-fixnum)) - repeat 1000 - nconc - (list (list i i2 t) (list i2 i nil))) + for i2 = (+ i (random most-positive-fixnum)) + repeat 1000 + nconc + (list (list i i2 t) (list i2 i nil))) (loop for i = (random n2) - for i2 = (+ (random n2) i) - repeat 1000 - nconc - (list (list i i2 t) (list i2 i nil))) + for i2 = (+ (random n2) i) + repeat 1000 + nconc + (list (list i i2 t) (list i2 i nil))) (loop for x in *universe* - when (integerp x) - nconc (list (list x (1+ x) t) - (list (1+ x) x nil))) + when (integerp x) + nconc (list (list x (1+ x) t) + (list (1+ x) x nil))) (loop for x in *universe* - when (realp x) - collect (list x x t)) + when (realp x) + collect (list x x t)) (loop for x in *universe* - when (and (realp x) (>= x 1)) - nconc - (loop for epsilon in (list short-float-epsilon - single-float-epsilon - double-float-epsilon - long-float-epsilon) - for bound in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for lower-bound in (list most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - when (and (<= (abs (float-exponent lower-bound)) 500) - (<= (abs (float-exponent x)) 500) - (<= (abs (float-exponent bound)) 500)) - when (<= (rational lower-bound) - (rational x) - (rational bound)) - nconc - (let* ((y (float x one)) - (z (* y (- one (* 2 epsilon))))) - (list (list y z nil) - (list z y t))))) + when (and (realp x) (>= x 1)) + nconc + (loop for epsilon in (list short-float-epsilon + single-float-epsilon + double-float-epsilon + long-float-epsilon) + for bound in (list most-positive-short-float + most-positive-single-float + most-positive-double-float + most-positive-long-float) + for lower-bound in (list most-negative-short-float + most-negative-single-float + most-negative-double-float + most-negative-long-float) + for one in '(1.0s0 1.0f0 1.0d0 1.0l0) + when (and (<= (abs (float-exponent lower-bound)) 500) + (<= (abs (float-exponent x)) 500) + (<= (abs (float-exponent bound)) 500)) + when (<= (rational lower-bound) + (rational x) + (rational bound)) + nconc + (let* ((y (float x one)) + (z (* y (- one (* 2 epsilon))))) + (list (list y z nil) + (list z y t))))) (loop for x in *universe* - when (and (realp x) (<= x -1)) - nconc - (loop for epsilon in (list short-float-epsilon - single-float-epsilon - double-float-epsilon - long-float-epsilon) - for bound in (list most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float) - for upper-bound in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - when (and (<= (abs (float-exponent bound)) 500) - (<= (abs (float-exponent x)) 500) - (<= (abs (float-exponent upper-bound)) 500)) - when (<= (rational bound) - (rational x) - (rational upper-bound)) - nconc - (let* ((y (float x one)) - (z (* y (- one (* 2 epsilon))))) - (list (list y z t) - (list z y nil))))) + when (and (realp x) (<= x -1)) + nconc + (loop for epsilon in (list short-float-epsilon + single-float-epsilon + double-float-epsilon + long-float-epsilon) + for bound in (list most-negative-short-float + most-negative-single-float + most-negative-double-float + most-negative-long-float) + for upper-bound in (list most-positive-short-float + most-positive-single-float + most-positive-double-float + most-positive-long-float) + for one in '(1.0s0 1.0f0 1.0d0 1.0l0) + when (and (<= (abs (float-exponent bound)) 500) + (<= (abs (float-exponent x)) 500) + (<= (abs (float-exponent upper-bound)) 500)) + when (<= (rational bound) + (rational x) + (rational upper-bound)) + nconc + (let* ((y (float x one)) + (z (* y (- one (* 2 epsilon))))) + (list (list y z t) + (list z y nil))))) (loop for x in *universe* - when (and (realp x) (< -1 x 1)) - nconc - (loop for epsilon in (list short-float-epsilon - single-float-epsilon - double-float-epsilon - long-float-epsilon) - for lower-bound in (list most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float) - for upper-bound in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - when (and (<= (abs (float-exponent lower-bound)) 500) - (<= (abs (float-exponent x)) 500) - (<= (abs (float-exponent upper-bound)) 500)) - when (<= (rational lower-bound) - (rational x) - (rational upper-bound)) - nconc - (handler-case - (let* ((y (float x one)) - (z1 (+ y epsilon)) - (z2 (- y epsilon))) - (list (list y z1 t) - (list z1 y nil) - (list y z2 nil) - (list z2 y t))) - (floating-point-underflow () nil)))) + when (and (realp x) (< -1 x 1)) + nconc + (loop for epsilon in (list short-float-epsilon + single-float-epsilon + double-float-epsilon + long-float-epsilon) + for lower-bound in (list most-negative-short-float + most-negative-single-float + most-negative-double-float + most-negative-long-float) + for upper-bound in (list most-positive-short-float + most-positive-single-float + most-positive-double-float + most-positive-long-float) + for one in '(1.0s0 1.0f0 1.0d0 1.0l0) + when (and (<= (abs (float-exponent lower-bound)) 500) + (<= (abs (float-exponent x)) 500) + (<= (abs (float-exponent upper-bound)) 500)) + when (<= (rational lower-bound) + (rational x) + (rational upper-bound)) + nconc + (handler-case + (let* ((y (float x one)) + (z1 (+ y epsilon)) + (z2 (- y epsilon))) + (list (list y z1 t) + (list z1 y nil) + (list y z2 nil) + (list z2 y t))) + (floating-point-underflow () nil)))) ))) (deftest <=.4 (loop for (x y result . rest) in *number-less-or-equal-tests* - unless (if (<= x y) result (not result)) - collect (list* x y result rest)) + unless (if (<= x y) result (not result)) + collect (list* x y result rest)) nil) (deftest <=.5 (loop for x in *universe* - when (and (typep x 'real) - (not (<= x))) - collect x) + when (and (typep x 'real) + (not (<= x))) + collect x) nil) (deftest <=.6 (let ((args (list 17)) - (args2 nil) - (args3 (list 0))) + (args2 nil) + (args3 (list 0))) (loop for i from 2 to (min 256 (1- call-arguments-limit)) - do (push 17 args) - do (push (- i) args2) - do (push i args3) - unless (and (apply #'<= args) - (apply #'<= args2) - (not (apply #'<= args3))) - collect (list args args2 args3))) + do (push 17 args) + do (push (- i) args2) + do (push i args3) + unless (and (apply #'<= args) + (apply #'<= args2) + (not (apply #'<= args3))) + collect (list args args2 args3))) nil) (deftest <=.7 (let* ((len (min 256 (1- call-arguments-limit))) - (args-proto (loop for i from 1 to len collect i))) + (args-proto (loop for i from 1 to len collect i))) (loop for i from 1 below len - for args = (copy-list args-proto) - do (setf (elt args i) 0) - never (apply #'<= args))) + for args = (copy-list args-proto) + do (setf (elt args i) 0) + never (apply #'<= args))) t) ;;; Check that <= is symmetric with >= @@ -860,63 +860,63 @@ (deftest <=.10 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - always (and (<= (- x) x) - (<= x (- x)))) + always (and (<= (- x) x) + (<= x (- x)))) t) (deftest <=.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat+rat/i = (+ xrat rat/i) - nconc - (if (<= x xrat+rat/i) - nil - (list (list x i xrat+rat/i)))))) + for eps in (list short-float-epsilon single-float-epsilon + double-float-epsilon long-float-epsilon) + for exp = (nth-value 1 (decode-float eps)) + for radix = (float-radix eps) + when (< (* (log radix 2) exp) 1000) + nconc + (let* ((rat (rational eps)) + (xrat (rational x))) + (loop for i from 2 to 100 + for rat/i = (/ rat i) + for xrat+rat/i = (+ xrat rat/i) + nconc + (if (<= x xrat+rat/i) + nil + (list (list x i xrat+rat/i)))))) nil) (deftest <=.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-negative-epsilon single-float-negative-epsilon - double-float-negative-epsilon long-float-negative-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat-rat/i = (- xrat rat/i) - nconc - (if (<= x xrat-rat/i) - (list (list x i xrat-rat/i)) - nil)))) + for eps in (list short-float-negative-epsilon single-float-negative-epsilon + double-float-negative-epsilon long-float-negative-epsilon) + for exp = (nth-value 1 (decode-float eps)) + for radix = (float-radix eps) + when (< (* (log radix 2) exp) 1000) + nconc + (let* ((rat (rational eps)) + (xrat (rational x))) + (loop for i from 2 to 100 + for rat/i = (/ rat i) + for xrat-rat/i = (- xrat rat/i) + nconc + (if (<= x xrat-rat/i) + (list (list x i xrat-rat/i)) + nil)))) nil) (deftest <=.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float) - for d = (and (<= x bound) (truncate x)) - unless (or (null d) (and (<= x (* 3/2 d)) - (not (<= (* 5/4 d) x)))) - collect (list x d (* 3/2 d) (* 5/4 d)))) + most-positive-double-float most-positive-long-float) + for d = (and (<= x bound) (truncate x)) + unless (or (null d) (and (<= x (* 3/2 d)) + (not (<= (* 5/4 d) x)))) + collect (list x d (* 3/2 d) (* 5/4 d)))) nil) (deftest <=.order.1 (let ((i 0) x y) (values (notnot (<= (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2))) + (progn (setf y (incf i)) 2))) i x y)) t 2 1 2) @@ -924,8 +924,8 @@ (let ((i 0) x y z) (values (notnot (<= (progn (setf x (incf i)) 1) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 3))) + (progn (setf y (incf i)) 2) + (progn (setf z (incf i)) 3))) i x y z)) t 3 1 2 3) @@ -960,35 +960,35 @@ (deftest >.4 (loop for (x y result . rest) in *number-less-tests* - unless (if (> y x) result (not result)) - collect (list* y x result rest)) + unless (if (> y x) result (not result)) + collect (list* y x result rest)) nil) (deftest >.5 (loop for x in *universe* - when (and (typep x 'real) - (not (> x))) - collect x) + when (and (typep x 'real) + (not (> x))) + collect x) nil) (deftest >.6 (let ((args (list 17)) - (args2 nil)) + (args2 nil)) (loop for i from 2 to (min 256 (1- call-arguments-limit)) - do (push 17 args) - do (push i args2) - unless (and (not (apply #'> args)) - (apply #'> args2)) - collect (list args args2))) + do (push 17 args) + do (push i args2) + unless (and (not (apply #'> args)) + (apply #'> args2)) + collect (list args args2))) nil) (deftest >.7 (let* ((len (min 256 (1- call-arguments-limit))) - (args-proto (loop for i from 1 to len collect i))) + (args-proto (loop for i from 1 to len collect i))) (loop for i from 1 below len - for args = (copy-list args-proto) - do (setf (elt args i) 0) - never (apply #'> args))) + for args = (copy-list args-proto) + do (setf (elt args i) 0) + never (apply #'> args))) t) ;;; > is negation of <= @@ -998,63 +998,63 @@ (deftest >.9 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - never (or (> (- x) x) - (> x (- x)))) + never (or (> (- x) x) + (> x (- x)))) t) (deftest >.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat+rat/i = (+ xrat rat/i) - nconc - (if (> x xrat+rat/i) - (list (list x i xrat+rat/i)) - nil)))) + for eps in (list short-float-epsilon single-float-epsilon + double-float-epsilon long-float-epsilon) + for exp = (nth-value 1 (decode-float eps)) + for radix = (float-radix eps) + when (< (* (log radix 2) exp) 1000) + nconc + (let* ((rat (rational eps)) + (xrat (rational x))) + (loop for i from 2 to 100 + for rat/i = (/ rat i) + for xrat+rat/i = (+ xrat rat/i) + nconc + (if (> x xrat+rat/i) + (list (list x i xrat+rat/i)) + nil)))) nil) (deftest >.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-negative-epsilon single-float-negative-epsilon - double-float-negative-epsilon long-float-negative-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat-rat/i = (- xrat rat/i) - nconc - (if (> x xrat-rat/i) - nil - (list (list x i xrat-rat/i)))))) + for eps in (list short-float-negative-epsilon single-float-negative-epsilon + double-float-negative-epsilon long-float-negative-epsilon) + for exp = (nth-value 1 (decode-float eps)) + for radix = (float-radix eps) + when (< (* (log radix 2) exp) 1000) + nconc + (let* ((rat (rational eps)) + (xrat (rational x))) + (loop for i from 2 to 100 + for rat/i = (/ rat i) + for xrat-rat/i = (- xrat rat/i) + nconc + (if (> x xrat-rat/i) + nil + (list (list x i xrat-rat/i)))))) nil) (deftest >.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float) - for d = (and (<= x bound) (truncate x)) - unless (or (null d) (and (> (* 3/2 d) x) - (not (> x (* 17/16 d))))) - collect (list x d (* 3/2 d) (* 17/16 d)))) + most-positive-double-float most-positive-long-float) + for d = (and (<= x bound) (truncate x)) + unless (or (null d) (and (> (* 3/2 d) x) + (not (> x (* 17/16 d))))) + collect (list x d (* 3/2 d) (* 17/16 d)))) nil) (deftest >.order.1 (let ((i 0) x y) (values (notnot (> (progn (setf x (incf i)) 2) - (progn (setf y (incf i)) 1))) + (progn (setf y (incf i)) 1))) i x y)) t 2 1 2) @@ -1062,8 +1062,8 @@ (let ((i 0) x y z) (values (notnot (> (progn (setf x (incf i)) 3) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 1))) + (progn (setf y (incf i)) 2) + (progn (setf z (incf i)) 1))) i x y z)) t 3 1 2 3) @@ -1097,38 +1097,38 @@ (deftest >=.4 (loop for (x y result . rest) in *number-less-or-equal-tests* - unless (if (>= y x) result (not result)) - collect (list* y x result rest)) + unless (if (>= y x) result (not result)) + collect (list* y x result rest)) nil) (deftest >=.5 (loop for x in *universe* - when (and (typep x 'real) - (not (>= x))) - collect x) + when (and (typep x 'real) + (not (>= x))) + collect x) nil) (deftest >=.6 (let ((args (list 17)) - (args2 (list 0)) - (args3 nil)) + (args2 (list 0)) + (args3 nil)) (loop for i from 2 to (min 256 (1- call-arguments-limit)) - do (push 17 args) - do (push (- i) args2) - do (push i args3) - unless (and (apply #'>= args) - (not (apply #'>= args2)) - (apply #'>= args3)) - collect (list args args2 args3))) + do (push 17 args) + do (push (- i) args2) + do (push i args3) + unless (and (apply #'>= args) + (not (apply #'>= args2)) + (apply #'>= args3)) + collect (list args args2 args3))) nil) (deftest >=.7 (let* ((len (min 256 (1- call-arguments-limit))) - (args-proto (loop for i from 1 to len collect i))) + (args-proto (loop for i from 1 to len collect i))) (loop for i from 1 below len - for args = (copy-list args-proto) - do (setf (elt args i) 0) - never (apply #'>= args))) + for args = (copy-list args-proto) + do (setf (elt args i) 0) + never (apply #'>= args))) t) ;;; Check that >= is equivalent to (or > =) @@ -1138,64 +1138,64 @@ (deftest >=.9 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - always (and (>= (- x) x) - (>= x (- x)))) + always (and (>= (- x) x) + (>= x (- x)))) t) (deftest >=.17 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat+rat/i = (+ xrat rat/i) - nconc - (if (>= x xrat+rat/i) - (list (list x i xrat+rat/i)) - nil)))) + for eps in (list short-float-epsilon single-float-epsilon + double-float-epsilon long-float-epsilon) + for exp = (nth-value 1 (decode-float eps)) + for radix = (float-radix eps) + when (< (* (log radix 2) exp) 1000) + nconc + (let* ((rat (rational eps)) + (xrat (rational x))) + (loop for i from 2 to 100 + for rat/i = (/ rat i) + for xrat+rat/i = (+ xrat rat/i) + nconc + (if (>= x xrat+rat/i) + (list (list x i xrat+rat/i)) + nil)))) nil) (deftest >=.18 (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - for eps in (list short-float-negative-epsilon single-float-negative-epsilon - double-float-negative-epsilon long-float-negative-epsilon) - for exp = (nth-value 1 (decode-float eps)) - for radix = (float-radix eps) - when (< (* (log radix 2) exp) 1000) - nconc - (let* ((rat (rational eps)) - (xrat (rational x))) - (loop for i from 2 to 100 - for rat/i = (/ rat i) - for xrat-rat/i = (- xrat rat/i) - nconc - (if (>= x xrat-rat/i) - nil - (list (list x i xrat-rat/i)))))) + for eps in (list short-float-negative-epsilon single-float-negative-epsilon + double-float-negative-epsilon long-float-negative-epsilon) + for exp = (nth-value 1 (decode-float eps)) + for radix = (float-radix eps) + when (< (* (log radix 2) exp) 1000) + nconc + (let* ((rat (rational eps)) + (xrat (rational x))) + (loop for i from 2 to 100 + for rat/i = (/ rat i) + for xrat-rat/i = (- xrat rat/i) + nconc + (if (>= x xrat-rat/i) + nil + (list (list x i xrat-rat/i)))))) nil) (deftest >=.19 (let ((bound (expt 10 1000))) (loop for x in (list most-positive-short-float most-positive-single-float - most-positive-double-float most-positive-long-float) - for d = (and (<= x bound) (truncate x)) - unless (or (null d) (and (>= (* 3/2 d) x) - (not (>= x(* 17/16 d))))) - collect (list x d (* 3/2 d) (* 17/16 d)))) + most-positive-double-float most-positive-long-float) + for d = (and (<= x bound) (truncate x)) + unless (or (null d) (and (>= (* 3/2 d) x) + (not (>= x(* 17/16 d))))) + collect (list x d (* 3/2 d) (* 17/16 d)))) nil) (deftest >=.order.1 (let ((i 0) x y) (values (notnot (>= (progn (setf x (incf i)) 2) - (progn (setf y (incf i)) 1))) + (progn (setf y (incf i)) 1))) i x y)) t 2 1 2) @@ -1203,8 +1203,8 @@ (let ((i 0) x y z) (values (notnot (>= (progn (setf x (incf i)) 3) - (progn (setf y (incf i)) 2) - (progn (setf z (incf i)) 1))) + (progn (setf y (incf i)) 2) + (progn (setf z (incf i)) 1))) i x y z)) t 3 1 2 3) @@ -1246,391 +1246,391 @@ (deftest bignum.float.compare.1a (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (+ r (ceiling (rational x))))) - (unless (< x i) - (list (list r x i)))))) + when (or (zerop x) + (< (abs (log (abs x))) 10000)) + nconc + (loop for r = (1+ (random (ash 1 (random 32)))) + repeat 200 + nconc + (let ((i (+ r (ceiling (rational x))))) + (unless (< x i) + (list (list r x i)))))) nil) (deftest bignum.float.compare.1b (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (- (floor (rational x)) r))) - (unless (< i x) - (list (list r x i)))))) + when (or (zerop x) + (< (abs (log (abs x))) 10000)) + nconc + (loop for r = (1+ (random (ash 1 (random 32)))) + repeat 200 + nconc + (let ((i (- (floor (rational x)) r))) + (unless (< i x) + (list (list r x i)))))) nil) (deftest bignum.float.compare.2a (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (+ r (ceiling (rational x))))) - (unless (> i x) - (list (list r x i)))))) + when (or (zerop x) + (< (abs (log (abs x))) 10000)) + nconc + (loop for r = (1+ (random (ash 1 (random 32)))) + repeat 200 + nconc + (let ((i (+ r (ceiling (rational x))))) + (unless (> i x) + (list (list r x i)))))) nil) (deftest bignum.float.compare.2b (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (- (floor (rational x)) r))) - (unless (> x i) - (list (list r x i)))))) + when (or (zerop x) + (< (abs (log (abs x))) 10000)) + nconc + (loop for r = (1+ (random (ash 1 (random 32)))) + repeat 200 + nconc + (let ((i (- (floor (rational x)) r))) + (unless (> x i) + (list (list r x i)))))) nil) (deftest bignum.float.compare.3a (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (+ r (ceiling (rational x))))) - (when (or (= x i) (= i x)) - (list (list r x i)))))) + when (or (zerop x) + (< (abs (log (abs x))) 10000)) + nconc + (loop for r = (1+ (random (ash 1 (random 32)))) + repeat 200 + nconc + (let ((i (+ r (ceiling (rational x))))) + (when (or (= x i) (= i x)) + (list (list r x i)))))) nil) (deftest bignum.float.compare.3b (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (- (floor (rational x)) r))) - (when (or (= x i) (= i x)) - (list (list r x i)))))) + when (or (zerop x) + (< (abs (log (abs x))) 10000)) + nconc + (loop for r = (1+ (random (ash 1 (random 32)))) + repeat 200 + nconc + (let ((i (- (floor (rational x)) r))) + (when (or (= x i) (= i x)) + (list (list r x i)))))) nil) (deftest bignum.float.compare.4a (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (+ r (ceiling (rational x))))) - (unless (and (/= i x) (/= x i)) - (list (list r x i)))))) + when (or (zerop x) + (< (abs (log (abs x))) 10000)) + nconc + (loop for r = (1+ (random (ash 1 (random 32)))) + repeat 200 + nconc + (let ((i (+ r (ceiling (rational x))))) + (unless (and (/= i x) (/= x i)) + (list (list r x i)))))) nil) (deftest bignum.float.compare.4b (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (- (floor (rational x)) r))) - (unless (and (/= i x) (/= x i)) - (list (list r x i)))))) + when (or (zerop x) + (< (abs (log (abs x))) 10000)) + nconc + (loop for r = (1+ (random (ash 1 (random 32)))) + repeat 200 + nconc + (let ((i (- (floor (rational x)) r))) + (unless (and (/= i x) (/= x i)) + (list (list r x i)))))) nil) (deftest bignum.float.compare.5a (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (+ r (ceiling (rational x))))) - (unless (<= x i) - (list (list r x i)))))) + when (or (zerop x) + (< (abs (log (abs x))) 10000)) + nconc + (loop for r = (1+ (random (ash 1 (random 32)))) + repeat 200 + nconc + (let ((i (+ r (ceiling (rational x))))) + (unless (<= x i) + (list (list r x i)))))) nil) (deftest bignum.float.compare.5b (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (- (floor (rational x)) r))) - (unless (<= i x) - (list (list r x i)))))) + when (or (zerop x) + (< (abs (log (abs x))) 10000)) + nconc + (loop for r = (1+ (random (ash 1 (random 32)))) + repeat 200 + nconc + (let ((i (- (floor (rational x)) r))) + (unless (<= i x) + (list (list r x i)))))) nil) (deftest bignum.float.compare.6a (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (+ r (ceiling (rational x))))) - (unless (>= i x) - (list (list r x i)))))) + when (or (zerop x) + (< (abs (log (abs x))) 10000)) + nconc + (loop for r = (1+ (random (ash 1 (random 32)))) + repeat 200 + nconc + (let ((i (+ r (ceiling (rational x))))) + (unless (>= i x) + (list (list r x i)))))) nil) (deftest bignum.float.compare.6b (loop for x in *floats* - when (or (zerop x) - (< (abs (log (abs x))) 10000)) - nconc - (loop for r = (1+ (random (ash 1 (random 32)))) - repeat 200 - nconc - (let ((i (- (floor (rational x)) r))) - (unless (>= x i) - (list (list r x i)))))) + when (or (zerop x) + (< (abs (log (abs x))) 10000)) + nconc + (loop for r = (1+ (random (ash 1 (random 32)))) + repeat 200 + nconc + (let ((i (- (floor (rational x)) r))) + (unless (>= x i) + (list (list r x i)))))) nil) (deftest bignum.float.compare.7 (let ((toobig (loop for x in *reals* - collect (and (> (abs x) 1.0) - (> (abs (log (abs x))) 10000))))) + collect (and (> (abs x) 1.0) + (> (abs (log (abs x))) 10000))))) (loop for x in *reals* - for xtoobig in toobig - nconc - (unless xtoobig - (let ((fx (floor x))) - (loop for y in *reals* - for ytoobig in toobig - when (and (not ytoobig) - (< x y) - (or (not (< fx y)) - (<= y fx) - (not (> y fx)) - (>= fx y))) - collect (list x y)))))) + for xtoobig in toobig + nconc + (unless xtoobig + (let ((fx (floor x))) + (loop for y in *reals* + for ytoobig in toobig + when (and (not ytoobig) + (< x y) + (or (not (< fx y)) + (<= y fx) + (not (> y fx)) + (>= fx y))) + collect (list x y)))))) nil) (deftest bignum.float.compare.8 (let ((toobig (loop for x in *reals* - collect (and (> (abs x) 1.0) - (> (abs (log (abs x))) 10000))))) + collect (and (> (abs x) 1.0) + (> (abs (log (abs x))) 10000))))) (loop for x in *reals* - for xtoobig in toobig - nconc - (unless xtoobig - (let ((fx (floor x))) - (loop for y in *reals* - for ytoobig in toobig - when (and (not ytoobig) - (<= x y) - (or (not (<= fx y)) - (> fx y) - (not (>= y fx)) - (< y fx))) - collect (list x y)))))) + for xtoobig in toobig + nconc + (unless xtoobig + (let ((fx (floor x))) + (loop for y in *reals* + for ytoobig in toobig + when (and (not ytoobig) + (<= x y) + (or (not (<= fx y)) + (> fx y) + (not (>= y fx)) + (< y fx))) + collect (list x y)))))) nil) ;;; More randomized comparisons (deftest bignum.short-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) - (upper-bound (if (< (/ most-positive-short-float 2) integer-bound) - (/ most-positive-short-float 2) - (coerce integer-bound 'short-float)))) + (upper-bound (if (< (/ most-positive-short-float 2) integer-bound) + (/ most-positive-short-float 2) + (coerce integer-bound 'short-float)))) (loop for bound = 1.0s0 then (* bound 2) - while (<= bound upper-bound) - nconc - (loop for r = (random bound) - for fr = (floor r) - for cr = (ceiling r) - repeat 20 - unless (and (<= fr r cr) - (if (= r fr) - (= r cr) - (/= r cr)) - (>= cr r fr)) - collect (list r fr cr)))) + while (<= bound upper-bound) + nconc + (loop for r = (random bound) + for fr = (floor r) + for cr = (ceiling r) + repeat 20 + unless (and (<= fr r cr) + (if (= r fr) + (= r cr) + (/= r cr)) + (>= cr r fr)) + collect (list r fr cr)))) nil) (deftest bignum.single-float.random.compare.1 (let* ((integer-bound (ash 1 100)) - (upper-bound (if (< (/ most-positive-single-float 2) integer-bound) - (/ most-positive-single-float 2) - (coerce integer-bound 'single-float)))) + (upper-bound (if (< (/ most-positive-single-float 2) integer-bound) + (/ most-positive-single-float 2) + (coerce integer-bound 'single-float)))) (loop for bound = 1.0f0 then (* bound 2) - while (<= bound upper-bound) - nconc - (loop for r = (random bound) - for fr = (floor r) - for cr = (ceiling r) - repeat 20 - unless (and (<= fr r cr) - (if (= r fr) - (= r cr) - (/= r cr)) - (>= cr r fr)) - collect (list r fr cr)))) + while (<= bound upper-bound) + nconc + (loop for r = (random bound) + for fr = (floor r) + for cr = (ceiling r) + repeat 20 + unless (and (<= fr r cr) + (if (= r fr) + (= r cr) + (/= r cr)) + (>= cr r fr)) + collect (list r fr cr)))) nil) (deftest bignum.double-float.random.compare.1 (let* ((integer-bound (ash 1 100)) - (upper-bound (if (< (/ most-positive-double-float 2) integer-bound) - (/ most-positive-double-float 2) - (coerce integer-bound 'double-float)))) + (upper-bound (if (< (/ most-positive-double-float 2) integer-bound) + (/ most-positive-double-float 2) + (coerce integer-bound 'double-float)))) (loop for bound = 1.0d0 then (* bound 2) - while (<= bound upper-bound) - nconc - (loop for r = (random bound) - for fr = (floor r) - for cr = (ceiling r) - repeat 20 - unless (and (<= fr r cr) - (if (= r fr) - (= r cr) - (/= r cr)) - (>= cr r fr)) - collect (list r fr cr)))) + while (<= bound upper-bound) + nconc + (loop for r = (random bound) + for fr = (floor r) + for cr = (ceiling r) + repeat 20 + unless (and (<= fr r cr) + (if (= r fr) + (= r cr) + (/= r cr)) + (>= cr r fr)) + collect (list r fr cr)))) nil) (deftest bignum.long-float.random.compare.1 (let* ((integer-bound (ash 1 100)) - (upper-bound (if (< (/ most-positive-long-float 2) integer-bound) - (/ most-positive-long-float 2) - (coerce integer-bound 'long-float)))) + (upper-bound (if (< (/ most-positive-long-float 2) integer-bound) + (/ most-positive-long-float 2) + (coerce integer-bound 'long-float)))) (loop for bound = 1.0l0 then (* bound 2) - while (< bound upper-bound) - nconc - (loop for r = (random bound) - for fr = (floor r) - for cr = (ceiling r) - repeat 20 - unless (and (<= fr r cr) - (if (= r fr) - (= r cr) - (/= r cr)) - (>= cr r fr)) - collect - (list r fr cr)))) + while (< bound upper-bound) + nconc + (loop for r = (random bound) + for fr = (floor r) + for cr = (ceiling r) + repeat 20 + unless (and (<= fr r cr) + (if (= r fr) + (= r cr) + (/= r cr)) + (>= cr r fr)) + collect + (list r fr cr)))) nil) ;;; Rational/float comparisons (deftest rational.short-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) - (upper-bound (if (< (/ most-positive-short-float 2) integer-bound) - (/ most-positive-short-float 2) - (coerce integer-bound 'short-float)))) + (upper-bound (if (< (/ most-positive-short-float 2) integer-bound) + (/ most-positive-short-float 2) + (coerce integer-bound 'short-float)))) (loop for bound = 1.0s0 then (* bound 2) - while (<= bound upper-bound) - nconc - (loop for r = (+ 1.s0 (random bound)) - for fr = (floor r) - for cr = (ceiling r) - for m = (ash 1 (1+ (random 30))) - for p = (1+ (random m)) - for q = (1+ (random m)) - for x = 0 - repeat 50 - when (<= p q) do (psetf p (1+ q) q p) - do (setf x (/ p q)) - unless (let ((fr/x (/ fr x)) - (cr*x (* cr x))) - (and (<= fr/x r cr*x) - (< fr/x r cr*x) - (> cr*x r fr/x) - (>= cr*x r fr/x))) - collect (list r p q x fr cr)))) + while (<= bound upper-bound) + nconc + (loop for r = (+ 1.s0 (random bound)) + for fr = (floor r) + for cr = (ceiling r) + for m = (ash 1 (1+ (random 30))) + for p = (1+ (random m)) + for q = (1+ (random m)) + for x = 0 + repeat 50 + when (<= p q) do (psetf p (1+ q) q p) + do (setf x (/ p q)) + unless (let ((fr/x (/ fr x)) + (cr*x (* cr x))) + (and (<= fr/x r cr*x) + (< fr/x r cr*x) + (> cr*x r fr/x) + (>= cr*x r fr/x))) + collect (list r p q x fr cr)))) nil) (deftest rational.single-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) - (upper-bound (if (< (/ most-positive-single-float 2) integer-bound) - (/ most-positive-single-float 2) - (coerce integer-bound 'single-float)))) + (upper-bound (if (< (/ most-positive-single-float 2) integer-bound) + (/ most-positive-single-float 2) + (coerce integer-bound 'single-float)))) (loop for bound = 1.0f0 then (* bound 2) - while (<= bound upper-bound) - nconc - (loop for r = (+ 1.s0 (random bound)) - for fr = (floor r) - for cr = (ceiling r) - for m = (ash 1 (1+ (random 30))) - for p = (1+ (random m)) - for q = (1+ (random m)) - for x = 0 - repeat 50 - when (<= p q) do (psetf p (1+ q) q p) - do (setf x (/ p q)) - unless (let ((fr/x (/ fr x)) - (cr*x (* cr x))) - (and (<= fr/x r cr*x) - (< fr/x r cr*x) - (> cr*x r fr/x) - (>= cr*x r fr/x))) - collect (list r p q x fr cr)))) + while (<= bound upper-bound) + nconc + (loop for r = (+ 1.s0 (random bound)) + for fr = (floor r) + for cr = (ceiling r) + for m = (ash 1 (1+ (random 30))) + for p = (1+ (random m)) + for q = (1+ (random m)) + for x = 0 + repeat 50 + when (<= p q) do (psetf p (1+ q) q p) + do (setf x (/ p q)) + unless (let ((fr/x (/ fr x)) + (cr*x (* cr x))) + (and (<= fr/x r cr*x) + (< fr/x r cr*x) + (> cr*x r fr/x) + (>= cr*x r fr/x))) + collect (list r p q x fr cr)))) nil) (deftest rational.double-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) - (upper-bound (if (< (/ most-positive-double-float 4) integer-bound) - (/ most-positive-double-float 4) - (coerce integer-bound 'double-float)))) + (upper-bound (if (< (/ most-positive-double-float 4) integer-bound) + (/ most-positive-double-float 4) + (coerce integer-bound 'double-float)))) (loop for bound = 1.0d0 then (* bound 4) - while (<= bound upper-bound) - nconc - (loop for r = (+ 1.s0 (random bound)) - for fr = (floor r) - for cr = (ceiling r) - for m = (ash 1 (1+ (random 30))) - for p = (1+ (random m)) - for q = (1+ (random m)) - for x = 0 - repeat 50 - when (<= p q) do (psetf p (1+ q) q p) - do (setf x (/ p q)) - unless (let ((fr/x (/ fr x)) - (cr*x (* cr x))) - (and (<= fr/x r cr*x) - (< fr/x r cr*x) - (> cr*x r fr/x) - (>= cr*x r fr/x))) - collect (list r p q x fr cr)))) + while (<= bound upper-bound) + nconc + (loop for r = (+ 1.s0 (random bound)) + for fr = (floor r) + for cr = (ceiling r) + for m = (ash 1 (1+ (random 30))) + for p = (1+ (random m)) + for q = (1+ (random m)) + for x = 0 + repeat 50 + when (<= p q) do (psetf p (1+ q) q p) + do (setf x (/ p q)) + unless (let ((fr/x (/ fr x)) + (cr*x (* cr x))) + (and (<= fr/x r cr*x) + (< fr/x r cr*x) + (> cr*x r fr/x) + (>= cr*x r fr/x))) + collect (list r p q x fr cr)))) nil) (deftest rational.long-float.random.compare.1 (let* ((integer-bound (ash 1 1000)) - (upper-bound (if (< (/ most-positive-long-float 4) integer-bound) - (/ most-positive-long-float 4) - (coerce integer-bound 'long-float)))) + (upper-bound (if (< (/ most-positive-long-float 4) integer-bound) + (/ most-positive-long-float 4) + (coerce integer-bound 'long-float)))) (loop for bound = 1.0d0 then (* bound 4) - while (<= bound upper-bound) - nconc - (loop for r = (+ 1.s0 (random bound)) - for fr = (floor r) - for cr = (ceiling r) - for m = (ash 1 (1+ (random 30))) - for p = (1+ (random m)) - for q = (1+ (random m)) - for x = 0 - repeat 50 - when (<= p q) do (psetf p (1+ q) q p) - do (setf x (/ p q)) - unless (let ((fr/x (/ fr x)) - (cr*x (* cr x))) - (and (<= fr/x r cr*x) - (< fr/x r cr*x) - (> cr*x r fr/x) - (>= cr*x r fr/x))) - collect (list r p q x fr cr)))) + while (<= bound upper-bound) + nconc + (loop for r = (+ 1.s0 (random bound)) + for fr = (floor r) + for cr = (ceiling r) + for m = (ash 1 (1+ (random 30))) + for p = (1+ (random m)) + for q = (1+ (random m)) + for x = 0 + repeat 50 + when (<= p q) do (psetf p (1+ q) q p) + do (setf x (/ p q)) + unless (let ((fr/x (/ fr x)) + (cr*x (* cr x))) + (and (<= fr/x r cr*x) + (< fr/x r cr*x) + (> cr*x r fr/x) + (>= cr*x r fr/x))) + collect (list r p q x fr cr)))) nil) ;;; Test that explicit calls to macroexpand in subforms @@ -1638,126 +1638,126 @@ (deftest =.env.1 (macrolet ((%m (z) z)) - (mapcar 'notnot - (list (= (expand-in-current-env (%m 0))) - (= 1 (expand-in-current-env (%m 1))) - (= (expand-in-current-env (%m 2)) 2) - (= (expand-in-current-env (%m 3)) - (expand-in-current-env (%m 3))) - (= (expand-in-current-env (%m #c(1 2))) - (expand-in-current-env (%m #c(1 2)))) - - (= 1 (expand-in-current-env (%m 2.0))) - (= (expand-in-current-env (%m 2)) 2/3) - (= (expand-in-current-env (%m 4)) - (expand-in-current-env (%m 5))) - - (= (expand-in-current-env (%m 0)) 0 0) - (= 0 (expand-in-current-env (%m 0)) 0) - (= 0 0 (expand-in-current-env (%m 0))) - ))) + (mapcar 'notnot + (list (= (expand-in-current-env (%m 0))) + (= 1 (expand-in-current-env (%m 1))) + (= (expand-in-current-env (%m 2)) 2) + (= (expand-in-current-env (%m 3)) + (expand-in-current-env (%m 3))) + (= (expand-in-current-env (%m #c(1 2))) + (expand-in-current-env (%m #c(1 2)))) + + (= 1 (expand-in-current-env (%m 2.0))) + (= (expand-in-current-env (%m 2)) 2/3) + (= (expand-in-current-env (%m 4)) + (expand-in-current-env (%m 5))) + + (= (expand-in-current-env (%m 0)) 0 0) + (= 0 (expand-in-current-env (%m 0)) 0) + (= 0 0 (expand-in-current-env (%m 0))) + ))) (t t t t t nil nil nil t t t)) (deftest /=.env.1 (macrolet ((%m (z) z)) - (mapcar 'notnot - (list (/= (expand-in-current-env (%m 0))) - (/= 1 (expand-in-current-env (%m 1))) - (/= (expand-in-current-env (%m 2)) 2) - (/= (expand-in-current-env (%m 3)) - (expand-in-current-env (%m 3))) - (/= (expand-in-current-env (%m #c(1 2))) - (expand-in-current-env (%m #c(1 2)))) - - (/= 1 (expand-in-current-env (%m 2.0))) - (/= (expand-in-current-env (%m 2)) 2/3) - (/= (expand-in-current-env (%m 4)) - (expand-in-current-env (%m 5))) - - (/= (expand-in-current-env (%m 2)) 0 1) - (/= 0 (expand-in-current-env (%m 2)) 1) - (/= 0 1 (expand-in-current-env (%m 2))) - ))) + (mapcar 'notnot + (list (/= (expand-in-current-env (%m 0))) + (/= 1 (expand-in-current-env (%m 1))) + (/= (expand-in-current-env (%m 2)) 2) + (/= (expand-in-current-env (%m 3)) + (expand-in-current-env (%m 3))) + (/= (expand-in-current-env (%m #c(1 2))) + (expand-in-current-env (%m #c(1 2)))) + + (/= 1 (expand-in-current-env (%m 2.0))) + (/= (expand-in-current-env (%m 2)) 2/3) + (/= (expand-in-current-env (%m 4)) + (expand-in-current-env (%m 5))) + + (/= (expand-in-current-env (%m 2)) 0 1) + (/= 0 (expand-in-current-env (%m 2)) 1) + (/= 0 1 (expand-in-current-env (%m 2))) + ))) (t nil nil nil nil t t t t t t)) (deftest <.env.1 (macrolet ((%m (z) z)) - (mapcar 'notnot - (list (< (expand-in-current-env (%m 0))) - (< 0 (expand-in-current-env (%m 1))) - (< (expand-in-current-env (%m 2)) 3) - (< (expand-in-current-env (%m 5)) - (expand-in-current-env (%m 7))) - - (< 3 (expand-in-current-env (%m 2.0))) - (< (expand-in-current-env (%m 2)) 2/3) - (< (expand-in-current-env (%m 6)) - (expand-in-current-env (%m 5))) - - (< (expand-in-current-env (%m 1)) 2 3) - (< 1 (expand-in-current-env (%m 2)) 3) - (< 1 2 (expand-in-current-env (%m 3))) - ))) + (mapcar 'notnot + (list (< (expand-in-current-env (%m 0))) + (< 0 (expand-in-current-env (%m 1))) + (< (expand-in-current-env (%m 2)) 3) + (< (expand-in-current-env (%m 5)) + (expand-in-current-env (%m 7))) + + (< 3 (expand-in-current-env (%m 2.0))) + (< (expand-in-current-env (%m 2)) 2/3) + (< (expand-in-current-env (%m 6)) + (expand-in-current-env (%m 5))) + + (< (expand-in-current-env (%m 1)) 2 3) + (< 1 (expand-in-current-env (%m 2)) 3) + (< 1 2 (expand-in-current-env (%m 3))) + ))) (t t t t nil nil nil t t t)) (deftest <=.env.1 (macrolet ((%m (z) z)) - (mapcar 'notnot - (list (<= (expand-in-current-env (%m 0))) - (<= 0 (expand-in-current-env (%m 1))) - (<= (expand-in-current-env (%m 2)) 3) - (<= (expand-in-current-env (%m 5)) - (expand-in-current-env (%m 7))) - - (<= 3 (expand-in-current-env (%m 2.0))) - (<= (expand-in-current-env (%m 2)) 2/3) - (<= (expand-in-current-env (%m 6)) - (expand-in-current-env (%m 5))) - - (<= (expand-in-current-env (%m 2)) 2 3) - (<= 1 (expand-in-current-env (%m 1)) 3) - (<= 1 2 (expand-in-current-env (%m 2))) - ))) + (mapcar 'notnot + (list (<= (expand-in-current-env (%m 0))) + (<= 0 (expand-in-current-env (%m 1))) + (<= (expand-in-current-env (%m 2)) 3) + (<= (expand-in-current-env (%m 5)) + (expand-in-current-env (%m 7))) + + (<= 3 (expand-in-current-env (%m 2.0))) + (<= (expand-in-current-env (%m 2)) 2/3) + (<= (expand-in-current-env (%m 6)) + (expand-in-current-env (%m 5))) + + (<= (expand-in-current-env (%m 2)) 2 3) + (<= 1 (expand-in-current-env (%m 1)) 3) + (<= 1 2 (expand-in-current-env (%m 2))) + ))) (t t t t nil nil nil t t t)) (deftest >.env.1 (macrolet ((%m (z) z)) - (mapcar 'notnot - (list (> (expand-in-current-env (%m 0))) - (> 2 (expand-in-current-env (%m 1))) - (> (expand-in-current-env (%m 4)) 3) - (> (expand-in-current-env (%m 10)) - (expand-in-current-env (%m 7))) - - (> 1 (expand-in-current-env (%m 2.0))) - (> (expand-in-current-env (%m -1)) 2/3) - (> (expand-in-current-env (%m 4)) - (expand-in-current-env (%m 5))) - - (> (expand-in-current-env (%m 2)) 1 0) - (> 2 (expand-in-current-env (%m 1)) 0) - (> 2 1 (expand-in-current-env (%m 0))) - ))) + (mapcar 'notnot + (list (> (expand-in-current-env (%m 0))) + (> 2 (expand-in-current-env (%m 1))) + (> (expand-in-current-env (%m 4)) 3) + (> (expand-in-current-env (%m 10)) + (expand-in-current-env (%m 7))) + + (> 1 (expand-in-current-env (%m 2.0))) + (> (expand-in-current-env (%m -1)) 2/3) + (> (expand-in-current-env (%m 4)) + (expand-in-current-env (%m 5))) + + (> (expand-in-current-env (%m 2)) 1 0) + (> 2 (expand-in-current-env (%m 1)) 0) + (> 2 1 (expand-in-current-env (%m 0))) + ))) (t t t t nil nil nil t t t)) (deftest >=.env.1 (macrolet ((%m (z) z)) - (mapcar 'notnot - (list (>= (expand-in-current-env (%m 0))) - (>= 2 (expand-in-current-env (%m 1))) - (>= (expand-in-current-env (%m 4)) 3) - (>= (expand-in-current-env (%m 7)) - (expand-in-current-env (%m 7))) - - (>= 1 (expand-in-current-env (%m 2.0))) - (>= (expand-in-current-env (%m -1)) 2/3) - (>= (expand-in-current-env (%m 4)) - (expand-in-current-env (%m 5))) - - (>= (expand-in-current-env (%m 2)) 1 1) - (>= 1 (expand-in-current-env (%m 1)) 0) - (>= 2 2 (expand-in-current-env (%m 0))) - ))) + (mapcar 'notnot + (list (>= (expand-in-current-env (%m 0))) + (>= 2 (expand-in-current-env (%m 1))) + (>= (expand-in-current-env (%m 4)) 3) + (>= (expand-in-current-env (%m 7)) + (expand-in-current-env (%m 7))) + + (>= 1 (expand-in-current-env (%m 2.0))) + (>= (expand-in-current-env (%m -1)) 2/3) + (>= (expand-in-current-env (%m 4)) + (expand-in-current-env (%m 5))) + + (>= (expand-in-current-env (%m 2)) 1 1) + (>= 1 (expand-in-current-env (%m 1)) 0) + (>= 2 2 (expand-in-current-env (%m 0))) + ))) (t t t t nil nil nil t t t)) diff --git a/ansi-tests/numbers-aux.lsp b/ansi-tests/numbers-aux.lsp index 672d0e20..b9f3c5f6 100644 --- a/ansi-tests/numbers-aux.lsp +++ b/ansi-tests/numbers-aux.lsp @@ -14,7 +14,7 @@ "FN is a function that, if true for X, is true for all Y > X. Find the smallest float in [lo,hi] for which the function return true." - + (assert (functionp fn)) (assert (floatp lo)) (assert (floatp hi)) @@ -22,21 +22,21 @@ (assert (funcall fn hi)) (loop while (<= lo hi) - do (let ((mid (/ (+ lo hi) 2))) - (if (funcall fn mid) - (if (= mid hi) - (return hi) - (setq hi mid)) - (if (= mid lo) - (return hi) - (setq lo mid)))))) + do (let ((mid (/ (+ lo hi) 2))) + (if (funcall fn mid) + (if (= mid hi) + (return hi) + (setq hi mid)) + (if (= mid lo) + (return hi) + (setq lo mid)))))) (defun integer-binary-search (fn lo hi) "FN is a function that, if true for X, is true for all Y < X. Find the largest integer in [lo,hi) for which the function return true." - + (assert (functionp fn)) (assert (integerp lo)) (assert (integerp hi)) @@ -44,21 +44,21 @@ (assert (funcall fn lo)) (loop while (< lo hi) - do (let ((mid (ceiling (+ lo hi) 2))) - (if (funcall fn mid) - (setq lo mid) - (if (= mid hi) - (return lo) - (setq hi mid)))) - finally (return lo))) + do (let ((mid (ceiling (+ lo hi) 2))) + (if (funcall fn mid) + (setq lo mid) + (if (= mid hi) + (return lo) + (setq hi mid)))) + finally (return lo))) (defun find-largest-exactly-floatable-integer (upper-bound) (integer-binary-search #'(lambda (i) (let* ((f (float i)) - (i- (1- i)) - (f- (float i-))) - (and (= f i) (= f- i-)))) + (i- (1- i)) + (f- (float i-))) + (and (= f i) (= f- i-)))) 0 upper-bound)) (defun eqlzt (x y) @@ -66,8 +66,8 @@ (cond ((complexp x) (and (complexp y) - (eqlzt (realpart x) (realpart y)) - (eqlzt (imagpart x) (imagpart y)))) + (eqlzt (realpart x) (realpart y)) + (eqlzt (imagpart x) (imagpart y)))) ((zerop x) (eqlt (abs x) (abs y))) (t (eqlt x y)))) @@ -105,31 +105,31 @@ (cond ((complexp x) (and (numbers-are-compatible (realpart x) y) - (numbers-are-compatible (imagpart x) y))) + (numbers-are-compatible (imagpart x) y))) ((complexp y) (and (numbers-are-compatible x (realpart y)) - (numbers-are-compatible x (imagpart y)))) + (numbers-are-compatible x (imagpart y)))) (t (when (floatp x) (rotatef x y)) (or (floatp x) - (not (floatp y)) - (etypecase y - (short-float - (<= +rational-most-negative-short-float+ - x - +rational-most-positive-short-float+)) - (single-float - (<= +rational-most-negative-single-float+ - x - +rational-most-positive-single-float+)) - (double-float - (<= +rational-most-negative-double-float+ - x - +rational-most-positive-double-float+)) - (long-float - (<= +rational-most-negative-long-float+ - x - +rational-most-positive-long-float+))))))) + (not (floatp y)) + (etypecase y + (short-float + (<= +rational-most-negative-short-float+ + x + +rational-most-positive-short-float+)) + (single-float + (<= +rational-most-negative-single-float+ + x + +rational-most-positive-single-float+)) + (double-float + (<= +rational-most-negative-double-float+ + x + +rational-most-positive-double-float+)) + (long-float + (<= +rational-most-negative-long-float+ + x + +rational-most-positive-long-float+))))))) ;;; NOTE! According to section 12.1.4.1, when a rational is compared ;;; to a float, the effect is as if the float is convert to a rational @@ -138,166 +138,166 @@ (defun =.4-fn () (loop for x in *numbers* - append - (loop for y in *numbers* - unless (or ;; (not (numbers-are-compatible x y)) - (if (= x y) (= y x) (not (= y x)))) - collect (list x y)))) + append + (loop for y in *numbers* + unless (or ;; (not (numbers-are-compatible x y)) + (if (= x y) (= y x) (not (= y x)))) + collect (list x y)))) (defun /=.4-fn () (loop for x in *numbers* - append - (loop for y in *numbers* - unless (or ;; (not (numbers-are-compatible x y)) - (if (/= x y) (/= y x) (not (/= y x)))) - collect (list x y)))) + append + (loop for y in *numbers* + unless (or ;; (not (numbers-are-compatible x y)) + (if (/= x y) (/= y x) (not (/= y x)))) + collect (list x y)))) (defun /=.4a-fn () (loop for x in *numbers* - append - (loop for y in *numbers* - when (and ;; (numbers-are-compatible x y) - (if (= x y) - (/= x y) - (not (/= x y)))) - collect (list x y)))) + append + (loop for y in *numbers* + when (and ;; (numbers-are-compatible x y) + (if (= x y) + (/= x y) + (not (/= x y)))) + collect (list x y)))) (defun <.8-fn () (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (and (< x y) (> x y))) - (arithmetic-error () nil)) - collect (list x y)))) + nconc + (loop for y in *reals* + when + (handler-case + (and ;; (numbers-are-compatible x y) + (and (< x y) (> x y))) + (arithmetic-error () nil)) + collect (list x y)))) (defun <.9-fn () (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (if (< x y) (not (> y x)) - (> y x))) - (arithmetic-error () nil)) - collect (list x y)))) + nconc + (loop for y in *reals* + when + (handler-case + (and ;; (numbers-are-compatible x y) + (if (< x y) (not (> y x)) + (> y x))) + (arithmetic-error () nil)) + collect (list x y)))) (defun <.10-fn () (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (if (< x y) (>= x y) - (not (>= x y)))) - (arithmetic-error () nil)) - collect (list x y)))) + nconc + (loop for y in *reals* + when + (handler-case + (and ;; (numbers-are-compatible x y) + (if (< x y) (>= x y) + (not (>= x y)))) + (arithmetic-error () nil)) + collect (list x y)))) (defun <=.8-fn () (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (if (<= x y) (not (>= y x)) - (>= y x))) - (arithmetic-error () nil)) - collect (list x y)))) - + nconc + (loop for y in *reals* + when + (handler-case + (and ;; (numbers-are-compatible x y) + (if (<= x y) (not (>= y x)) + (>= y x))) + (arithmetic-error () nil)) + collect (list x y)))) + (defun <=.9-fn () (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (if (<= x y) (not (or (= x y) (< x y))) - (or (= x y) (< x y)))) - (arithmetic-error () nil)) - collect (list x y)))) + nconc + (loop for y in *reals* + when + (handler-case + (and ;; (numbers-are-compatible x y) + (if (<= x y) (not (or (= x y) (< x y))) + (or (= x y) (< x y)))) + (arithmetic-error () nil)) + collect (list x y)))) (defun >.8-fn () (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (if (> x y) (<= x y) - (not (<= x y)))) - (arithmetic-error () nil)) - collect (list x y)))) + nconc + (loop for y in *reals* + when + (handler-case + (and ;; (numbers-are-compatible x y) + (if (> x y) (<= x y) + (not (<= x y)))) + (arithmetic-error () nil)) + collect (list x y)))) (defun >=.8-fn () (loop for x in *reals* - nconc - (loop for y in *reals* - when - (handler-case - (and ;; (numbers-are-compatible x y) - (if (>= x y) (not (or (= x y) (> x y))) - (or (= x y) (> x y)))) - (arithmetic-error () nil)) - collect (list x y)))) + nconc + (loop for y in *reals* + when + (handler-case + (and ;; (numbers-are-compatible x y) + (if (>= x y) (not (or (= x y) (> x y))) + (or (= x y) (> x y)))) + (arithmetic-error () nil)) + collect (list x y)))) ;;; Comparison of rationsls (defun compare-random-rationals (n m rep) (loop for a = (- (random n) m) - for b = (- (random n) m) - for c = (- (random n) m) - for d = (- (random n) m) - repeat rep - when - (and (/= b 0) - (/= d 0) - (let ((q1 (/ a b)) - (q2 (/ c d)) - (ad (* a d)) - (bc (* b c))) - (when (< (* b d) 0) - (setq ad (- ad)) - (setq bc (- bc))) - (or (if (< q1 q2) (not (< ad bc)) (< ad bc)) - (if (<= q1 q2) (not (<= ad bc)) (<= ad bc)) - (if (> q1 q2) (not (> ad bc)) (> ad bc)) - (if (>= q1 q2) (not (>= ad bc)) (>= ad bc)) - (if (= q1 q2) (not (= ad bc)) (= ad bc)) - (if (/= q1 q2) (not (/= ad bc)) (/= ad bc))))) - collect (list a b c d))) + for b = (- (random n) m) + for c = (- (random n) m) + for d = (- (random n) m) + repeat rep + when + (and (/= b 0) + (/= d 0) + (let ((q1 (/ a b)) + (q2 (/ c d)) + (ad (* a d)) + (bc (* b c))) + (when (< (* b d) 0) + (setq ad (- ad)) + (setq bc (- bc))) + (or (if (< q1 q2) (not (< ad bc)) (< ad bc)) + (if (<= q1 q2) (not (<= ad bc)) (<= ad bc)) + (if (> q1 q2) (not (> ad bc)) (> ad bc)) + (if (>= q1 q2) (not (>= ad bc)) (>= ad bc)) + (if (= q1 q2) (not (= ad bc)) (= ad bc)) + (if (/= q1 q2) (not (/= ad bc)) (/= ad bc))))) + collect (list a b c d))) (defun max.2-fn () (loop for x in *reals* - nconc - (loop for y in *reals* - when (numbers-are-compatible x y) - unless - (handler-case - (let ((m (max x y))) - (and (>= m x) (>= m y) - (or (= m x) (= m y)))) - (floating-point-underflow () t) - (floating-point-overflow () t)) - collect (list x y (max x y))))) + nconc + (loop for y in *reals* + when (numbers-are-compatible x y) + unless + (handler-case + (let ((m (max x y))) + (and (>= m x) (>= m y) + (or (= m x) (= m y)))) + (floating-point-underflow () t) + (floating-point-overflow () t)) + collect (list x y (max x y))))) (defun min.2-fn () (loop for x in *reals* - nconc - (loop for y in *reals* - when (numbers-are-compatible x y) - unless - (handler-case - (let ((m (min x y))) - (and (<= m x) (<= m y) - (or (= m x) (= m y)))) - (floating-point-underflow () t) - (floating-point-overflow () t)) - collect (list x y (min x y))))) + nconc + (loop for y in *reals* + when (numbers-are-compatible x y) + unless + (handler-case + (let ((m (min x y))) + (and (<= m x) (<= m y) + (or (= m x) (= m y)))) + (floating-point-underflow () t) + (floating-point-overflow () t)) + collect (list x y (min x y))))) ;;; Compute the number of digits that can be added to 1.0 in the appropriate ;;; float type, a rational representation of the smallest radix^(-k) s.t. @@ -307,8 +307,8 @@ (defun find-epsilon (x) (assert (floatp x)) (let* ((one (float 1 x)) - (radix (float-radix one)) - (eps (/ 1 radix))) + (radix (float-radix one)) + (eps (/ 1 radix))) (loop for next-eps = (/ eps radix) for i from 1 @@ -317,9 +317,9 @@ finally (return (values i eps (float eps one)))))) (defun test-log-op-with-decls (op xlo xhi ylo yhi niters - &optional - (decls '((optimize (speed 3) (safety 1) - (debug 1))))) + &optional + (decls '((optimize (speed 3) (safety 1) + (debug 1))))) "Test that a compiled form of the LOG* function OP computes the expected result on two random integers drawn from the types `(integer ,xlo ,xhi) and `(integer ,ylo ,yhi). Try @@ -335,32 +335,32 @@ (assert (<= ylo yhi)) (let* ((source - `(lambda (x y) - (declare (type (integer ,xlo ,xhi) x) - (type (integer ,ylo ,yhi) y) - ,@ decls) - (,op x y))) - (fn (compile nil source))) + `(lambda (x y) + (declare (type (integer ,xlo ,xhi) x) + (type (integer ,ylo ,yhi) y) + ,@ decls) + (,op x y))) + (fn (compile nil source))) (loop for i below niters - for x = (random-from-interval (1+ xhi) xlo) - for y = (random-from-interval (1+ yhi) ylo) - unless (eql (funcall (the symbol op) x y) - (funcall fn x y)) - collect (list x y)))) + for x = (random-from-interval (1+ xhi) xlo) + for y = (random-from-interval (1+ yhi) ylo) + unless (eql (funcall (the symbol op) x y) + (funcall fn x y)) + collect (list x y)))) (defun test-log-op (op n1 n2) (flet ((%r () (let ((r (random 33))) - (- (random (ash 1 (1+ r))) (ash 1 r))))) + (- (random (ash 1 (1+ r))) (ash 1 r))))) (loop for x1 = (%r) - for x2 = (%r) - for y1 = (%r) - for y2 = (%r) - repeat n1 - nconc - (test-log-op-with-decls op - (min x1 x2) (max x1 x2) - (min y1 y2) (max y1 y2) - n2)))) + for x2 = (%r) + for y1 = (%r) + for y2 = (%r) + repeat n1 + nconc + (test-log-op-with-decls op + (min x1 x2) (max x1 x2) + (min y1 y2) (max y1 y2) + n2)))) (defun safe-tan (x &optional (default 0.0)) (handler-case (let ((result (multiple-value-list (tan x)))) diff --git a/ansi-tests/numerator-denominator.lsp b/ansi-tests/numerator-denominator.lsp index 72ef3d66..7f487b17 100644 --- a/ansi-tests/numerator-denominator.lsp +++ b/ansi-tests/numerator-denominator.lsp @@ -25,20 +25,20 @@ (deftest numerator-denominator.1 (loop for n = (abs (random-fixnum)) - for d = (1+ (abs (random-fixnum))) - for g = (gcd n d) - for n1 = (/ n g) - for d1 = (/ d g) - for r = (/ n d) - for n2 = (numerator r) - for d2 = (denominator r) - repeat 1000 - unless (and (eql (gcd n1 d1) 1) - (>= n1 0) - (>= d1 1) - (eql n1 n2) - (eql d1 d2)) - collect (list n1 d1 r n2 d2)) + for d = (1+ (abs (random-fixnum))) + for g = (gcd n d) + for n1 = (/ n g) + for d1 = (/ d g) + for r = (/ n d) + for n2 = (numerator r) + for d2 = (denominator r) + repeat 1000 + unless (and (eql (gcd n1 d1) 1) + (>= n1 0) + (>= d1 1) + (eql n1 n2) + (eql d1 d2)) + collect (list n1 d1 r n2 d2)) nil) (deftest numerator-denominator.2 @@ -54,29 +54,29 @@ for d2 = (denominator r) repeat 1000 unless (and (eql (gcd n1 d1) 1) - (>= n1 0) - (>= d1 1) - (eql n1 n2) - (eql d1 d2)) + (>= n1 0) + (>= d1 1) + (eql n1 n2) + (eql d1 d2)) collect (list n1 d1 r n2 d2))) nil) (deftest numerator-denominator.3 (loop for n = (abs (random-fixnum)) - for d = (1+ (abs (random-fixnum))) - for g = (gcd n d) - for n1 = (/ n g) - for d1 = (/ d g) - for r = (/ n (- d)) - for n2 = (numerator r) - for d2 = (denominator r) - repeat 1000 - unless (and (eql (gcd n1 d1) 1) - (>= n1 0) - (>= d1 1) - (eql n1 (- n2)) - (eql d1 d2)) - collect (list n1 d1 r n2 d2)) + for d = (1+ (abs (random-fixnum))) + for g = (gcd n d) + for n1 = (/ n g) + for d1 = (/ d g) + for r = (/ n (- d)) + for n2 = (numerator r) + for d2 = (denominator r) + repeat 1000 + unless (and (eql (gcd n1 d1) 1) + (>= n1 0) + (>= d1 1) + (eql n1 (- n2)) + (eql d1 d2)) + collect (list n1 d1 r n2 d2)) nil) (deftest numerator-denominator.4 @@ -92,21 +92,21 @@ for d2 = (denominator r) repeat 1000 unless (and (eql (gcd n1 d1) 1) - (>= n1 0) - (>= d1 1) - (eql n1 (- n2)) - (eql d1 d2)) + (>= n1 0) + (>= d1 1) + (eql n1 (- n2)) + (eql d1 d2)) collect (list n1 d1 r n2 d2))) nil) - + (deftest numerator-denominator.5 (loop for r in *rationals* - for n = (numerator r) - for d = (denominator r) - unless (and (integerp n) - (integerp d) - (eql (gcd n d) 1) - (>= d 1) - (eql (/ n d) r)) - collect (list r n d)) + for n = (numerator r) + for d = (denominator r) + unless (and (integerp n) + (integerp d) + (eql (gcd n d) 1) + (>= d 1) + (eql (/ n d) r)) + collect (list r n d)) nil) diff --git a/ansi-tests/nunion.lsp b/ansi-tests/nunion.lsp index aa48149e..4a9974e5 100644 --- a/ansi-tests/nunion.lsp +++ b/ansi-tests/nunion.lsp @@ -30,135 +30,135 @@ (deftest nunion.6 (let ((x '(a b c d e f)) - (y '(z c y a v b))) + (y '(z c y a v b))) (let ((result (nunion-with-copy x y))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.6-a (let ((x '(a b c d e f)) - (y '(z c y a v b))) + (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test #'eq))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.7 (let ((x '(a b c d e f)) - (y '(z c y a v b))) + (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test #'eql))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.8 (let ((x '(a b c d e f)) - (y '(z c y a v b))) + (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test #'equal))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.9 (let ((x '(a b c d e f)) - (y '(z c y a v b))) + (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test-not (complement #'eql)))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.10 (let ((x '(a b c d e f)) - (y '(z c y a v b))) + (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test-not (complement #'equal)))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.11 (let ((x '(a b c d e f)) - (y '(z c y a v b))) + (y '(z c y a v b))) (let ((result (nunion-with-copy x y :test-not (complement #'eq)))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.12 (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) + (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.13 (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) + (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y :test #'equal))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.14 (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) + (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y :test #'eql))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.15 (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) + (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y :test-not (complement #'equal)))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.16 (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) + (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy x y :test-not (complement #'eql)))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.17 (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) + (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.18 (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) + (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+ :test #'equal))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.19 (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) + (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+ :test #'eql))) - (check-union x y result))) + (check-union x y result))) t) (deftest nunion.20 (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) + (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+ - :test-not (complement #'equal)))) - (check-union x y result))) + :test-not (complement #'equal)))) + (check-union x y result))) t) (deftest nunion.21 (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) + (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y #'1+ - :test-not (complement #'equal)))) - (check-union x y result))) + :test-not (complement #'equal)))) + (check-union x y result))) t) (deftest nunion.22 (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) + (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y nil))) (check-union x y result))) t) (deftest nunion.23 (let ((x '(1 2 3 4 5 6 7)) - (y '(10 19 5 3 17 1001 2))) + (y '(10 19 5 3 17 1001 2))) (let ((result (nunion-with-copy-and-key x y '1+))) (check-union x y result))) t) @@ -171,14 +171,14 @@ (deftest nunion.25 (let ((x (shuffle '(1 4 6 10 45 101))) - (y '(102 5 2 11 44 6))) + (y '(102 5 2 11 44 6))) (let ((result (nunion-with-copy x y - :test #'(lambda (a b) - (<= (abs (- a b)) 1))))) + :test #'(lambda (a b) + (<= (abs (- a b)) 1))))) (sort (sublis - '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) - (copy-list result)) + '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) + (copy-list result)) #'<))) (1 4 6 10 44 101)) @@ -186,23 +186,23 @@ (deftest nunion.26 (let ((x 1000) - (y 1000)) + (y 1000)) (loop while (not (typep x 'bignum)) do (progn - (setf x (* x x)) - (setf y (* y y)))) + (setf x (* x x)) + (setf y (* y y)))) (notnot-mv (or (eqt x y) ;; if bignums are eq, the test is worthless (eql (length - (nunion-with-copy (list x) (list x))) - 1)))) + (nunion-with-copy (list x) (list x))) + 1)))) t) (deftest nunion.27 (nunion-with-copy (list (copy-seq "aa")) - (list (copy-seq "aa"))) + (list (copy-seq "aa"))) ("aa" "aa")) (defharmless nunion.test-and-test-not.1 @@ -217,11 +217,11 @@ (block fail (sort (nunion-with-copy - '(1 2 3) - '(4 5 6) - :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))) + '(1 2 3) + '(4 5 6) + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))) #'<)) (1 2 3 4 5 6)) @@ -229,12 +229,12 @@ (block fail (sort (nunion-with-copy-and-key - '(1 2 3) - '(4 5 6) - #'identity - :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))) + '(1 2 3) + '(4 5 6) + #'identity + :test #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (eql x y))) #'<)) (1 2 3 4 5 6)) @@ -242,12 +242,12 @@ (block fail (sort (nunion-with-copy - '(1 2 3) - '(4 5 6) - :test-not - #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))) + '(1 2 3) + '(4 5 6) + :test-not + #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))) #'<)) (1 2 3 4 5 6)) @@ -255,12 +255,12 @@ (block fail (sort (nunion-with-copy-and-key - '(1 2 3) - '(4 5 6) - #'identity - :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))) + '(1 2 3) + '(4 5 6) + #'identity + :test-not #'(lambda (x y) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))) #'<)) (1 2 3 4 5 6)) @@ -271,7 +271,7 @@ (values (sort (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) - (progn (setf y (incf i)) (copy-list '(2 5 8)))) + (progn (setf y (incf i)) (copy-list '(2 5 8)))) #'<) i x y)) (1 2 3 5 8) @@ -282,9 +282,9 @@ (values (sort (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) - (progn (setf y (incf i)) (copy-list '(2 5 8))) - :test (progn (setf z (incf i)) #'eql) - :key (progn (setf w (incf i)) #'identity)) + (progn (setf y (incf i)) (copy-list '(2 5 8))) + :test (progn (setf z (incf i)) #'eql) + :key (progn (setf w (incf i)) #'identity)) #'<) i x y z w)) (1 2 3 5 8) @@ -296,9 +296,9 @@ (values (sort (nunion (progn (setf x (incf i)) (copy-list '(1 3 5))) - (progn (setf y (incf i)) (copy-list '(2 5 8))) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf w (incf i)) #'eql)) + (progn (setf y (incf i)) (copy-list '(2 5 8))) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf w (incf i)) #'eql)) #'<) i x y z w)) (1 2 3 5 8) @@ -308,55 +308,55 @@ (deftest nunion.allow-other-keys.1 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) :bad t - :allow-other-keys "yes") - #'<) + :allow-other-keys "yes") + #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.2 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t :also-bad t) - #'<) + :allow-other-keys t :also-bad t) + #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.3 (sort (nunion (list 1 2 3) (list 1 2 3) - :allow-other-keys t :also-bad t - :test #'(lambda (x y) (= x (+ y 100)))) - #'<) + :allow-other-keys t :also-bad t + :test #'(lambda (x y) (= x (+ y 100)))) + #'<) (1 1 2 2 3 3)) (deftest nunion.allow-other-keys.4 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t) - #'<) + :allow-other-keys t) + #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.5 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys nil) - #'<) + :allow-other-keys nil) + #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.6 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t - :allow-other-keys nil) - #'<) + :allow-other-keys t + :allow-other-keys nil) + #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.allow-other-keys.7 (sort (nunion (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t - :allow-other-keys nil - '#:x 1) - #'<) + :allow-other-keys t + :allow-other-keys nil + '#:x 1) + #'<) (1 2 5 7 9 10 11 20)) (deftest nunion.keywords.9 (sort (nunion (list 1 2 3) (list 1 2 3) - :test #'(lambda (x y) (= x (+ y 100))) - :test #'eql) - #'<) + :test #'(lambda (x y) (= x (+ y 100))) + :test #'eql) + #'<) (1 1 2 2 3 3)) ;;; Error tests diff --git a/ansi-tests/oddp.lsp b/ansi-tests/oddp.lsp index 2277e128..8fd3ec42 100644 --- a/ansi-tests/oddp.lsp +++ b/ansi-tests/oddp.lsp @@ -25,42 +25,42 @@ (deftest oddp.1 (loop for x in *numbers* - when (integerp x) - do (oddp x)) + when (integerp x) + do (oddp x)) nil) (deftest oddp.3 (loop for x = (random-fixnum) - repeat 10000 - when (or - (oddp (+ x x)) - (not (oddp (+ x x 1))) - (if (oddp x) - (or (oddp (1+ x)) - (oddp (1- x)) - (/= (mod x 2) 1)) - (or (not (oddp (1+ x))) - (not (oddp (1- x))) - (/= (mod x 2) 0)))) - collect x) + repeat 10000 + when (or + (oddp (+ x x)) + (not (oddp (+ x x 1))) + (if (oddp x) + (or (oddp (1+ x)) + (oddp (1- x)) + (/= (mod x 2) 1)) + (or (not (oddp (1+ x))) + (not (oddp (1- x))) + (/= (mod x 2) 0)))) + collect x) nil) (deftest oddp.4 (let ((upper-bound 1000000000000000) - (lower-bound -1000000000000000)) + (lower-bound -1000000000000000)) (loop for x = (random-from-interval upper-bound lower-bound) - repeat 10000 - when (or - (oddp (+ x x)) - (not (oddp (+ x x 1))) - (if (oddp x) - (or (oddp (1+ x)) - (oddp (1- x)) - (/= (mod x 2) 1)) - (or (not (oddp (1+ x))) - (not (oddp (1- x))) - (/= (mod x 2) 0)))) - collect x)) + repeat 10000 + when (or + (oddp (+ x x)) + (not (oddp (+ x x 1))) + (if (oddp x) + (or (oddp (1+ x)) + (oddp (1- x)) + (/= (mod x 2) 1)) + (or (not (oddp (1+ x))) + (not (oddp (1- x))) + (/= (mod x 2) 0)))) + collect x)) nil) (deftest oddp.5 @@ -79,4 +79,4 @@ (oddp 100000000000000000000000000000000) nil) - \ No newline at end of file + diff --git a/ansi-tests/oneminus.lsp b/ansi-tests/oneminus.lsp index a0a5a3e5..afac16ee 100644 --- a/ansi-tests/oneminus.lsp +++ b/ansi-tests/oneminus.lsp @@ -25,148 +25,148 @@ (deftest 1-.1 (loop for x = (random-fixnum) - for y = (1- x) - for z = (- x 1) - repeat 1000 - unless (eql y z) - collect (list x y z)) + for y = (1- x) + for z = (- x 1) + repeat 1000 + unless (eql y z) + collect (list x y z)) nil) (deftest 1-.2 (loop for x = (random-from-interval (ash 1 1000)) - for y = (1- x) - for z = (- x 1) - repeat 1000 - unless (eql y z) - collect (list x y z)) + for y = (1- x) + for z = (- x 1) + repeat 1000 + unless (eql y z) + collect (list x y z)) nil) (deftest 1-.3 (loop for x = (random (1- most-positive-short-float)) - for y = (1- x) - for z = (- x 1.0s0) - repeat 1000 - unless (eql y z) - collect (list x y z)) + for y = (1- x) + for z = (- x 1.0s0) + repeat 1000 + unless (eql y z) + collect (list x y z)) nil) (deftest 1-.4 (loop for x = (random (1- most-positive-single-float)) - for y = (1- x) - for z = (- x 1.0f0) - repeat 1000 - unless (eql y z) - collect (list x y z)) + for y = (1- x) + for z = (- x 1.0f0) + repeat 1000 + unless (eql y z) + collect (list x y z)) nil) (deftest 1-.5 (loop for x = (random (1- most-positive-double-float)) - for y = (1- x) - for z = (- x 1.0d0) - repeat 1000 - unless (eql y z) - collect (list x y z)) + for y = (1- x) + for z = (- x 1.0d0) + repeat 1000 + unless (eql y z) + collect (list x y z)) nil) (deftest 1-.6 (loop for x = (random (1- most-positive-long-float)) - for y = (1- x) - for z = (- x 1.0l0) - repeat 1000 - unless (eql y z) - collect (list x y z)) + for y = (1- x) + for z = (- x 1.0l0) + repeat 1000 + unless (eql y z) + collect (list x y z)) nil) (deftest 1-.7 (loop for x = (random-fixnum) - for y = (random-fixnum) - for y2 = (if (zerop y) 1 y) - for r = (/ x y2) - for r1 = (1- r) - for r2 = (- r 1) - repeat 1000 - unless (eql r1 r2) - collect (list x y2 r1 r2)) + for y = (random-fixnum) + for y2 = (if (zerop y) 1 y) + for r = (/ x y2) + for r1 = (1- r) + for r2 = (- r 1) + repeat 1000 + unless (eql r1 r2) + collect (list x y2 r1 r2)) nil) (deftest 1-.8 (let ((bound (ash 1 200))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for y2 = (if (zerop y) 1 y) - for r = (/ x y2) - for r1 = (1- r) - for r2 = (- r 1) - repeat 1000 - unless (eql r1 r2) - collect (list x y2 r1 r2))) + for y = (random-from-interval bound) + for y2 = (if (zerop y) 1 y) + for r = (/ x y2) + for r1 = (1- r) + for r2 = (- r 1) + repeat 1000 + unless (eql r1 r2) + collect (list x y2 r1 r2))) nil) ;;; Complex numbers (deftest 1-.9 (loop for xr = (random-fixnum) - for xi = (random-fixnum) - for xc = (complex xr xi) - for xc1 = (1- xc) - repeat 1000 - unless (eql xc1 (complex (- xr 1) xi)) - collect (list xr xi xc xc1)) + for xi = (random-fixnum) + for xc = (complex xr xi) + for xc1 = (1- xc) + repeat 1000 + unless (eql xc1 (complex (- xr 1) xi)) + collect (list xr xi xc xc1)) nil) (deftest 1-.10 (let ((bound (ash 1 100))) (loop for xr = (random-from-interval bound) - for xi = (random-from-interval bound) - for xc = (complex xr xi) - for xc1 = (1- xc) - repeat 1000 - unless (eql xc1 (complex (- xr 1) xi)) - collect (list xr xi xc xc1))) + for xi = (random-from-interval bound) + for xc = (complex xr xi) + for xc1 = (1- xc) + repeat 1000 + unless (eql xc1 (complex (- xr 1) xi)) + collect (list xr xi xc xc1))) nil) (deftest 1-.11 (let ((bound (1- most-positive-short-float))) (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1- xc) - repeat 1000 - unless (eql xc1 (complex (- xr 1) xi)) - collect (list xr xi xc xc1))) + for xi = (random bound) + for xc = (complex xr xi) + for xc1 = (1- xc) + repeat 1000 + unless (eql xc1 (complex (- xr 1) xi)) + collect (list xr xi xc xc1))) nil) (deftest 1-.12 (let ((bound (1- most-positive-single-float))) (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1- xc) - repeat 1000 - unless (eql xc1 (complex (- xr 1) xi)) - collect (list xr xi xc xc1))) + for xi = (random bound) + for xc = (complex xr xi) + for xc1 = (1- xc) + repeat 1000 + unless (eql xc1 (complex (- xr 1) xi)) + collect (list xr xi xc xc1))) nil) (deftest 1-.13 (let ((bound (1- most-positive-double-float))) (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1- xc) - repeat 1000 - unless (eql xc1 (complex (- xr 1) xi)) - collect (list xr xi xc xc1))) + for xi = (random bound) + for xc = (complex xr xi) + for xc1 = (1- xc) + repeat 1000 + unless (eql xc1 (complex (- xr 1) xi)) + collect (list xr xi xc xc1))) nil) (deftest 1-.14 (let ((bound (1- most-positive-long-float))) (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1- xc) - repeat 1000 - unless (eql xc1 (complex (- xr 1) xi)) - collect (list xr xi xc xc1))) + for xi = (random bound) + for xc = (complex xr xi) + for xc1 = (1- xc) + repeat 1000 + unless (eql xc1 (complex (- xr 1) xi)) + collect (list xr xi xc xc1))) nil) (deftest 1-.15 diff --git a/ansi-tests/oneplus.lsp b/ansi-tests/oneplus.lsp index b70da29c..0646df8e 100644 --- a/ansi-tests/oneplus.lsp +++ b/ansi-tests/oneplus.lsp @@ -21,148 +21,148 @@ (deftest 1+.1 (loop for x = (random-fixnum) - for y = (1+ x) - for z = (+ x 1) - repeat 1000 - unless (eql y z) - collect (list x y z)) + for y = (1+ x) + for z = (+ x 1) + repeat 1000 + unless (eql y z) + collect (list x y z)) nil) (deftest 1+.2 (loop for x = (random-from-interval (ash 1 1000)) - for y = (1+ x) - for z = (+ x 1) - repeat 1000 - unless (eql y z) - collect (list x y z)) + for y = (1+ x) + for z = (+ x 1) + repeat 1000 + unless (eql y z) + collect (list x y z)) nil) (deftest 1+.3 (loop for x = (random (1- most-positive-short-float)) - for y = (1+ x) - for z = (+ x 1.0s0) - repeat 1000 - unless (eql y z) - collect (list x y z)) + for y = (1+ x) + for z = (+ x 1.0s0) + repeat 1000 + unless (eql y z) + collect (list x y z)) nil) (deftest 1+.4 (loop for x = (random (1- most-positive-single-float)) - for y = (1+ x) - for z = (+ x 1.0f0) - repeat 1000 - unless (eql y z) - collect (list x y z)) + for y = (1+ x) + for z = (+ x 1.0f0) + repeat 1000 + unless (eql y z) + collect (list x y z)) nil) (deftest 1+.5 (loop for x = (random (1- most-positive-double-float)) - for y = (1+ x) - for z = (+ x 1.0d0) - repeat 1000 - unless (eql y z) - collect (list x y z)) + for y = (1+ x) + for z = (+ x 1.0d0) + repeat 1000 + unless (eql y z) + collect (list x y z)) nil) (deftest 1+.6 (loop for x = (random (1- most-positive-long-float)) - for y = (1+ x) - for z = (+ x 1.0l0) - repeat 1000 - unless (eql y z) - collect (list x y z)) + for y = (1+ x) + for z = (+ x 1.0l0) + repeat 1000 + unless (eql y z) + collect (list x y z)) nil) (deftest 1+.7 (loop for x = (random-fixnum) - for y = (random-fixnum) - for y2 = (if (zerop y) 1 y) - for r = (/ x y2) - for r1 = (1+ r) - for r2 = (+ r 1) - repeat 1000 - unless (eql r1 r2) - collect (list x y2 r1 r2)) + for y = (random-fixnum) + for y2 = (if (zerop y) 1 y) + for r = (/ x y2) + for r1 = (1+ r) + for r2 = (+ r 1) + repeat 1000 + unless (eql r1 r2) + collect (list x y2 r1 r2)) nil) (deftest 1+.8 (let ((bound (ash 1 200))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for y2 = (if (zerop y) 1 y) - for r = (/ x y2) - for r1 = (1+ r) - for r2 = (+ r 1) - repeat 1000 - unless (eql r1 r2) - collect (list x y2 r1 r2))) + for y = (random-from-interval bound) + for y2 = (if (zerop y) 1 y) + for r = (/ x y2) + for r1 = (1+ r) + for r2 = (+ r 1) + repeat 1000 + unless (eql r1 r2) + collect (list x y2 r1 r2))) nil) ;;; Complex numbers (deftest 1+.9 (loop for xr = (random-fixnum) - for xi = (random-fixnum) - for xc = (complex xr xi) - for xc1 = (1+ xc) - repeat 1000 - unless (eql xc1 (complex (+ xr 1) xi)) - collect (list xr xi xc xc1)) + for xi = (random-fixnum) + for xc = (complex xr xi) + for xc1 = (1+ xc) + repeat 1000 + unless (eql xc1 (complex (+ xr 1) xi)) + collect (list xr xi xc xc1)) nil) (deftest 1+.10 (let ((bound (ash 1 100))) (loop for xr = (random-from-interval bound) - for xi = (random-from-interval bound) - for xc = (complex xr xi) - for xc1 = (1+ xc) - repeat 1000 - unless (eql xc1 (complex (+ xr 1) xi)) - collect (list xr xi xc xc1))) + for xi = (random-from-interval bound) + for xc = (complex xr xi) + for xc1 = (1+ xc) + repeat 1000 + unless (eql xc1 (complex (+ xr 1) xi)) + collect (list xr xi xc xc1))) nil) (deftest 1+.11 (let ((bound (1- most-positive-short-float))) (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1+ xc) - repeat 1000 - unless (eql xc1 (complex (+ xr 1) xi)) - collect (list xr xi xc xc1))) + for xi = (random bound) + for xc = (complex xr xi) + for xc1 = (1+ xc) + repeat 1000 + unless (eql xc1 (complex (+ xr 1) xi)) + collect (list xr xi xc xc1))) nil) (deftest 1+.12 (let ((bound (1- most-positive-single-float))) (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1+ xc) - repeat 1000 - unless (eql xc1 (complex (+ xr 1) xi)) - collect (list xr xi xc xc1))) + for xi = (random bound) + for xc = (complex xr xi) + for xc1 = (1+ xc) + repeat 1000 + unless (eql xc1 (complex (+ xr 1) xi)) + collect (list xr xi xc xc1))) nil) (deftest 1+.13 (let ((bound (1- most-positive-double-float))) (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1+ xc) - repeat 1000 - unless (eql xc1 (complex (+ xr 1) xi)) - collect (list xr xi xc xc1))) + for xi = (random bound) + for xc = (complex xr xi) + for xc1 = (1+ xc) + repeat 1000 + unless (eql xc1 (complex (+ xr 1) xi)) + collect (list xr xi xc xc1))) nil) (deftest 1+.14 (let ((bound (1- most-positive-long-float))) (loop for xr = (random bound) - for xi = (random bound) - for xc = (complex xr xi) - for xc1 = (1+ xc) - repeat 1000 - unless (eql xc1 (complex (+ xr 1) xi)) - collect (list xr xi xc xc1))) + for xi = (random bound) + for xc = (complex xr xi) + for xc1 = (1+ xc) + repeat 1000 + unless (eql xc1 (complex (+ xr 1) xi)) + collect (list xr xi xc xc1))) nil) (deftest 1+.15 diff --git a/ansi-tests/open-stream-p.lsp b/ansi-tests/open-stream-p.lsp index ea4ed222..08e45327 100644 --- a/ansi-tests/open-stream-p.lsp +++ b/ansi-tests/open-stream-p.lsp @@ -7,23 +7,23 @@ (deftest open-stream-p.1 (loop for s in (list *debug-io* *error-output* *query-io* - *standard-input* *standard-output* - *trace-output* *terminal-io*) - for results = (multiple-value-list (open-stream-p s)) - unless (and (eql (length results) 1) - (car results)) - collect s) + *standard-input* *standard-output* + *trace-output* *terminal-io*) + for results = (multiple-value-list (open-stream-p s)) + unless (and (eql (length results) 1) + (car results)) + collect s) nil) (deftest open-stream-p.2 (with-open-file (s "open-stream-p.lsp" :direction :input) - (notnot-mv (open-stream-p s))) + (notnot-mv (open-stream-p s))) t) (deftest open-stream-p.3 (with-open-file (s "foo.txt" :direction :output - :if-exists :supersede) - (notnot-mv (open-stream-p s))) + :if-exists :supersede) + (notnot-mv (open-stream-p s))) t) (deftest open-stream-p.4 @@ -34,7 +34,7 @@ (deftest open-stream-p.5 (let ((s (open "foo.txt" :direction :output - :if-exists :supersede))) + :if-exists :supersede))) (close s) (open-stream-p s)) nil) diff --git a/ansi-tests/open.lsp b/ansi-tests/open.lsp index e8d1790a..8ae6a7dd 100644 --- a/ansi-tests/open.lsp +++ b/ansi-tests/open.lsp @@ -15,84 +15,84 @@ #'(lambda (i) (logand i 1))) (cons (let ((op (car type)) - (arg1 (cadr type)) - (arg2 (caddr type))) + (arg1 (cadr type)) + (arg2 (caddr type))) (ecase op - (unsigned-byte - (let ((mask (1- (ash 1 arg1)))) - #'(lambda (i) (logand i mask)))) - (signed-byte - (let ((mask (1- (ash 1 (1- arg1))))) - #'(lambda (i) (logand i mask)))) - (integer - (let* ((lo arg1) - (hi arg2) - (lower-bound - (etypecase lo - (integer lo) - (cons (1+ (car lo))))) - (upper-bound - (etypecase hi - (integer hi) - (cons (1- (car hi))))) - (range (1+ (- upper-bound lower-bound)))) - #'(lambda (i) (+ lower-bound (mod i range)))))))))) + (unsigned-byte + (let ((mask (1- (ash 1 arg1)))) + #'(lambda (i) (logand i mask)))) + (signed-byte + (let ((mask (1- (ash 1 (1- arg1))))) + #'(lambda (i) (logand i mask)))) + (integer + (let* ((lo arg1) + (hi arg2) + (lower-bound + (etypecase lo + (integer lo) + (cons (1+ (car lo))))) + (upper-bound + (etypecase hi + (integer hi) + (cons (1- (car hi))))) + (range (1+ (- upper-bound lower-bound)))) + #'(lambda (i) (+ lower-bound (mod i range)))))))))) (compile 'generator-for-element-type) (defmacro def-open-test (name args form expected - &key - (notes nil notes-p) - (build-form nil build-form-p) - (element-type 'character element-type-p) - (pathname #p"tmp.dat")) - + &key + (notes nil notes-p) + (build-form nil build-form-p) + (element-type 'character element-type-p) + (pathname #p"tmp.dat")) + (when element-type-p (setf args (append args (list :element-type `',element-type)))) (unless build-form-p (let ((write-element-form - (cond - ((subtypep element-type 'integer) - `(write-byte - (funcall (the function - (generator-for-element-type ',element-type)) i) - os)) - ((subtypep element-type 'character) - `(write-char - (funcall (the function - (generator-for-element-type ',element-type)) i) - os))))) + (cond + ((subtypep element-type 'integer) + `(write-byte + (funcall (the function + (generator-for-element-type ',element-type)) i) + os)) + ((subtypep element-type 'character) + `(write-char + (funcall (the function + (generator-for-element-type ',element-type)) i) + os))))) (setq build-form - `(with-open-file - (os pn :direction :output - ,@(if element-type-p - `(:element-type ',element-type)) - :if-exists :supersede) - (assert (open-stream-p os)) - (dotimes (i 10) ,write-element-form) - (finish-output os) - )))) - + `(with-open-file + (os pn :direction :output + ,@(if element-type-p + `(:element-type ',element-type)) + :if-exists :supersede) + (assert (open-stream-p os)) + (dotimes (i 10) ,write-element-form) + (finish-output os) + )))) + `(deftest ,name ,@(when notes-p `(:notes ,notes)) (let ((pn ,pathname)) (delete-all-versions pn) ,build-form (let ((s (open pn ,@args))) - (unwind-protect - (progn - (assert (open-stream-p s)) - (assert (typep s 'file-stream)) - ,@ - (unless (member element-type '(signed-byte unsigned-byte)) - #-allegro - `((assert (subtypep ',element-type - (stream-element-type s)))) - #+allegro nil - ) - ,form) - (close s)))) + (unwind-protect + (progn + (assert (open-stream-p s)) + (assert (typep s 'file-stream)) + ,@ + (unless (member element-type '(signed-byte unsigned-byte)) + #-allegro + `((assert (subtypep ',element-type + (stream-element-type s)))) + #+allegro nil + ) + ,form) + (close s)))) ,@expected)) ;; (compile 'def-open-test) @@ -286,23 +286,23 @@ ;;; It works on recognizable subtypes. (deftest open.65 (let ((type '(or (integer 0 1) (integer 100 200))) - (pn #p"tmp.dat") - (vals '(0 1 100 120 130 190 200 1 0 150))) + (pn #p"tmp.dat") + (vals '(0 1 100 120 130 190 200 1 0 150))) (or (not (subtypep type 'integer)) (progn (with-open-file - (os pn :direction :output - :element-type type - :if-exists :supersede) - (dolist (e vals) (write-byte e os))) + (os pn :direction :output + :element-type type + :if-exists :supersede) + (dolist (e vals) (write-byte e os))) (let ((s (open pn :direction :input - :element-type type)) - (seq (make-array 10))) - (unwind-protect - (progn (read-sequence seq s) seq) - (close s)) - (notnot (every #'eql seq vals)))))) + :element-type type)) + (seq (make-array 10))) + (unwind-protect + (progn (read-sequence seq s) seq) + (close s)) + (notnot (every #'eql seq vals)))))) t) ;;; FIXME: Add -- tests for when the filespec is a stream @@ -312,17 +312,17 @@ (delete-all-versions pn) (with-open-file (s pn :direction :io :if-exists :rename-and-delete - :if-does-not-exist :create) + :if-does-not-exist :create) (format s "some stuff~%") (finish-output s) (let ((is (open s :direction :input))) (unwind-protect - (values - (read-char is) - (notnot (file-position s :start)) - (read-line is) - (read-line s)) - (close is))))) + (values + (read-char is) + (notnot (file-position s :start)) + (read-line is) + (read-line s)) + (close is))))) #\s t "ome stuff" @@ -333,15 +333,15 @@ (delete-all-versions pn) (let ((s (open pn :direction :output))) (unwind-protect - (progn - (format s "some stuff~%") - (finish-output s) - (close s) - (let ((is (open s :direction :input))) - (unwind-protect - (values (read-line is)) - (close is)))) - (when (open-stream-p s) (close s))))) + (progn + (format s "some stuff~%") + (finish-output s) + (close s) + (let ((is (open s :direction :input))) + (unwind-protect + (values (read-line is)) + (close is)))) + (when (open-stream-p s) (close s))))) "some stuff") ;;; FIXME: Add -- tests for when element-type is :default @@ -350,23 +350,23 @@ (defmacro def-open-output-test (name args form expected - &rest keyargs - &key - (element-type 'character) - (build-form - `(dotimes (i 10) - ,(cond - ((subtypep element-type 'integer) - `(write-byte - (funcall (the function - (generator-for-element-type ',element-type)) i) - s)) - ((subtypep element-type 'character) - `(write-char - (funcall (the function - (generator-for-element-type ',element-type)) i) - s))))) - &allow-other-keys) + &rest keyargs + &key + (element-type 'character) + (build-form + `(dotimes (i 10) + ,(cond + ((subtypep element-type 'integer) + `(write-byte + (funcall (the function + (generator-for-element-type ',element-type)) i) + s)) + ((subtypep element-type 'character) + `(write-char + (funcall (the function + (generator-for-element-type ',element-type)) i) + s))))) + &allow-other-keys) `(def-open-test ,name (:direction :output ,@args) (progn ,build-form @@ -380,161 +380,161 @@ (def-open-output-test open.output.1 () (progn (close s) - (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) + (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.2 () (progn (close s) - (with-open-file (is "tmp.dat") (values (read-line is nil)))) + (with-open-file (is "tmp.dat") (values (read-line is nil)))) ("abcdefghij") :pathname "tmp.dat") (def-open-output-test open.output.3 () (progn (close s) - (with-open-file (is (logical-pathname "CLTEST:TMP.DAT")) - (values (read-line is nil)))) + (with-open-file (is (logical-pathname "CLTEST:TMP.DAT")) + (values (read-line is nil)))) ("abcdefghij") :pathname (logical-pathname "CLTEST:TMP.DAT")) (def-open-output-test open.output.4 () (progn (close s) - (with-open-file (is #p"tmp.dat" :element-type 'character) - (values (read-line is nil)))) + (with-open-file (is #p"tmp.dat" :element-type 'character) + (values (read-line is nil)))) ("abcdefghij") :element-type character) (def-open-output-test open.output.5 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type 'base-char) - (values (read-line is nil)))) + :element-type 'base-char) + (values (read-line is nil)))) ("abcdefghij") :element-type base-char) (def-open-output-test open.output.6 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(integer 0 1)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(integer 0 1)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (integer 0 1)) (def-open-output-test open.output.7 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type 'bit) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type 'bit) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 0 1 0 1 0 1 0 1)) :element-type bit) (def-open-output-test open.output.8 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 1)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(unsigned-byte 1)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1)) (def-open-output-test open.output.9 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 2)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(unsigned-byte 2)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2)) (def-open-output-test open.output.10 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 3)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(unsigned-byte 3)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3)) (def-open-output-test open.output.11 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 4)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(unsigned-byte 4)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4)) (def-open-output-test open.output.12 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 6)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(unsigned-byte 6)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6)) (def-open-output-test open.output.13 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 8)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(unsigned-byte 8)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8)) (def-open-output-test open.output.14 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 12)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(unsigned-byte 12)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 12)) (def-open-output-test open.output.15 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 16)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(unsigned-byte 16)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 16)) (def-open-output-test open.output.16 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 24)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(unsigned-byte 24)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 24)) (def-open-output-test open.output.17 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 32)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(unsigned-byte 32)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32)) (def-open-output-test open.output.18 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 64)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(unsigned-byte 64)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 64)) (def-open-output-test open.output.19 () (progn (close s) (with-open-file (is #p"tmp.dat" - :element-type '(unsigned-byte 100)) - (let ((seq (make-array 10))) - (read-sequence seq is) - seq))) + :element-type '(unsigned-byte 100)) + (let ((seq (make-array 10))) + (read-sequence seq is) + seq))) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 100)) @@ -546,64 +546,64 @@ (def-open-test open.output.21 (:if-exists :new-version :direction :output) (progn (write-sequence "wxyz" s) - (close s) - (with-open-file - (s pn :direction :input) - (values (read-line s nil)))) + (close s) + (with-open-file + (s pn :direction :input) + (values (read-line s nil)))) ("wxyz") :notes (:open-if-exists-new-version-no-error) ) (def-open-test open.output.22 (:if-exists :rename :direction :output) (progn (write-sequence "wxyz" s) - (close s) - (with-open-file - (s pn :direction :input) - (values (read-line s nil)))) + (close s) + (with-open-file + (s pn :direction :input) + (values (read-line s nil)))) ("wxyz")) (def-open-test open.output.23 (:if-exists :rename-and-delete - :direction :output) + :direction :output) (progn (write-sequence "wxyz" s) - (close s) - (with-open-file - (s pn :direction :input) - (values (read-line s nil)))) + (close s) + (with-open-file + (s pn :direction :input) + (values (read-line s nil)))) ("wxyz")) (def-open-test open.output.24 (:if-exists :overwrite - :direction :output) + :direction :output) (progn (write-sequence "wxyz" s) - (close s) - (with-open-file - (s pn :direction :input) - (values (read-line s nil)))) + (close s) + (with-open-file + (s pn :direction :input) + (values (read-line s nil)))) ("wxyzefghij")) (def-open-test open.output.25 (:if-exists :append - :direction :output) + :direction :output) (progn (write-sequence "wxyz" s) - (close s) - (with-open-file - (s pn :direction :input) - (values (read-line s nil)))) + (close s) + (with-open-file + (s pn :direction :input) + (values (read-line s nil)))) ("abcdefghijwxyz")) (def-open-test open.output.26 (:if-exists :supersede - :direction :output) + :direction :output) (progn (write-sequence "wxyz" s) - (close s) - (with-open-file - (s pn :direction :input) - (values (read-line s nil)))) + (close s) + (with-open-file + (s pn :direction :input) + (values (read-line s nil)))) ("wxyz")) (def-open-output-test open.output.27 (:if-does-not-exist :create - :direction :output) + :direction :output) (progn (close s) - (with-open-file - (is pn :direction :input) - (values (read-line is nil)))) + (with-open-file + (is pn :direction :input) + (values (read-line is nil)))) ("abcdefghij")) (deftest open.output.28 @@ -614,18 +614,18 @@ (def-open-output-test open.output.28a (:external-format :default) (progn (close s) - (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) + (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.29 (:external-format (prog1 - (with-open-file (s "foo.dat" :direction :output - :if-exists :supersede) - (stream-external-format s)) - (delete-all-versions "foo.dat") - )) + (with-open-file (s "foo.dat" :direction :output + :if-exists :supersede) + (stream-external-format s)) + (delete-all-versions "foo.dat") + )) (progn (close s) - (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) + (with-open-file (is #p"tmp.dat") (values (read-line is nil)))) ("abcdefghij")) ;;; Default behavior of open :if-exists is :create when the version @@ -635,65 +635,65 @@ :notes (:open-if-exists-new-version-no-error) (let ((pn (make-pathname :name "tmp" :type "dat" :version :newest))) (or (not (eql (pathname-version pn) :newest)) - (progn - ;; Create file - (let ((s1 (open pn :direction :output :if-exists :overwrite - :if-does-not-exist :create))) - (unwind-protect - ;; Now try again - (let ((s2 (open pn :direction :output))) - (unwind-protect - (write-line "abcdef" s2) - (close s2)) - (unwind-protect - (progn - (setq s2 (open s1 :direction :input)) - (equalt (read-line s2 nil) "abcdef")) - (close s2))) - (close s1) - (delete-all-versions pn) - ))))) + (progn + ;; Create file + (let ((s1 (open pn :direction :output :if-exists :overwrite + :if-does-not-exist :create))) + (unwind-protect + ;; Now try again + (let ((s2 (open pn :direction :output))) + (unwind-protect + (write-line "abcdef" s2) + (close s2)) + (unwind-protect + (progn + (setq s2 (open s1 :direction :input)) + (equalt (read-line s2 nil) "abcdef")) + (close s2))) + (close s1) + (delete-all-versions pn) + ))))) t) (def-open-output-test open.output.31 (:if-exists :rename - :direction :output) + :direction :output) (progn (close s) - (with-open-file - (is pn :direction :input) - (values (read-line is nil)))) + (with-open-file + (is pn :direction :input) + (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.32 (:if-exists :rename-and-delete - :direction :output) + :direction :output) (progn (close s) - (with-open-file - (is pn :direction :input) - (values (read-line is nil)))) + (with-open-file + (is pn :direction :input) + (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.33 (:if-exists :new-version - :direction :output) + :direction :output) (progn (close s) - (with-open-file - (is pn :direction :input) - (values (read-line is nil)))) + (with-open-file + (is pn :direction :input) + (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.34 (:if-exists :supersede - :direction :output) + :direction :output) (progn (close s) - (with-open-file - (is pn :direction :input) - (values (read-line is nil)))) + (with-open-file + (is pn :direction :input) + (values (read-line is nil)))) ("abcdefghij")) (def-open-output-test open.output.35 (:if-exists nil - :direction :output) + :direction :output) (progn (close s) - (with-open-file - (is pn :direction :input) - (values (read-line is nil)))) - ("abcdefghij")) + (with-open-file + (is pn :direction :input) + (values (read-line is nil)))) + ("abcdefghij")) ;;; Add -- tests for when the filespec is a stream @@ -702,23 +702,23 @@ (defmacro def-open-io-test (name args form expected - &rest keyargs - &key - (element-type 'character) - (build-form - `(dotimes (i 10) - ,(cond - ((subtypep element-type 'integer) - `(write-byte - (funcall (the function - (generator-for-element-type ',element-type)) i) - s)) - ((subtypep element-type 'character) - `(write-char - (funcall (the function - (generator-for-element-type ',element-type)) i) - s))))) - &allow-other-keys) + &rest keyargs + &key + (element-type 'character) + (build-form + `(dotimes (i 10) + ,(cond + ((subtypep element-type 'integer) + `(write-byte + (funcall (the function + (generator-for-element-type ',element-type)) i) + s)) + ((subtypep element-type 'character) + `(write-char + (funcall (the function + (generator-for-element-type ',element-type)) i) + s))))) + &allow-other-keys) `(def-open-test ,name (:direction :io ,@args) (progn ,build-form @@ -733,144 +733,144 @@ (def-open-io-test open.io.1 () (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.2 () (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij") :pathname "tmp.dat") (def-open-io-test open.io.3 () (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij") :pathname (logical-pathname "CLTEST:TMP.DAT")) (def-open-io-test open.io.4 () (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij") :element-type character) (def-open-io-test open.io.5 () (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij") :element-type base-char) (def-open-io-test open.io.6 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (integer 0 1)) (def-open-io-test open.io.7 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 0 1 0 1 0 1 0 1)) :element-type bit) (def-open-io-test open.io.8 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 0 1 0 1 0 1 0 1)) :element-type (unsigned-byte 1)) (def-open-io-test open.io.9 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 2 3 0 1 2 3 0 1)) :element-type (unsigned-byte 2)) (def-open-io-test open.io.10 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 2 3 4 5 6 7 0 1)) :element-type (unsigned-byte 3)) (def-open-io-test open.io.11 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 4)) (def-open-io-test open.io.12 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 6)) (def-open-io-test open.io.13 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 8)) (def-open-io-test open.io.14 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 12)) (def-open-io-test open.io.15 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 16)) (def-open-io-test open.io.16 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 24)) (def-open-io-test open.io.17 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 32)) (def-open-io-test open.io.18 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 64)) (def-open-io-test open.io.19 () (progn (file-position s :start) - (let ((seq (make-array 10))) - (read-sequence seq s) - seq)) + (let ((seq (make-array 10))) + (read-sequence seq s) + seq)) (#(0 1 2 3 4 5 6 7 8 9)) :element-type (unsigned-byte 100)) @@ -882,50 +882,50 @@ (def-open-test open.io.21 (:if-exists :new-version :direction :io) (progn (write-sequence "wxyz" s) - (file-position s :start) - (values (read-line s nil))) + (file-position s :start) + (values (read-line s nil))) ("wxyz") :notes (:open-if-exists-new-version-no-error) ) (def-open-test open.io.22 (:if-exists :rename :direction :io) (progn (write-sequence "wxyz" s) - (file-position s :start) - (values (read-line s nil))) + (file-position s :start) + (values (read-line s nil))) ("wxyz")) (def-open-test open.io.23 (:if-exists :rename-and-delete - :direction :io) + :direction :io) (progn (write-sequence "wxyz" s) - (file-position s :start) - (values (read-line s nil))) + (file-position s :start) + (values (read-line s nil))) ("wxyz")) (def-open-test open.io.24 (:if-exists :overwrite - :direction :io) + :direction :io) (progn (write-sequence "wxyz" s) - (file-position s :start) - (values (read-line s nil))) + (file-position s :start) + (values (read-line s nil))) ("wxyzefghij")) (def-open-test open.io.25 (:if-exists :append - :direction :io) + :direction :io) (progn (write-sequence "wxyz" s) - (file-position s :start) - (values (read-line s nil))) + (file-position s :start) + (values (read-line s nil))) ("abcdefghijwxyz")) (def-open-test open.io.26 (:if-exists :supersede - :direction :io) + :direction :io) (progn (write-sequence "wxyz" s) - (file-position s :start) - (values (read-line s nil))) + (file-position s :start) + (values (read-line s nil))) ("wxyz")) (def-open-io-test open.io.27 (:if-does-not-exist :create - :direction :io) + :direction :io) (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij")) (deftest open.io.28 @@ -936,18 +936,18 @@ (def-open-io-test open.io.28a (:external-format :default) (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.29 (:external-format (prog1 - (with-open-file (s "foo.dat" :direction :io - :if-exists :supersede) - (stream-external-format s)) - (delete-all-versions "foo.dat") - )) + (with-open-file (s "foo.dat" :direction :io + :if-exists :supersede) + (stream-external-format s)) + (delete-all-versions "foo.dat") + )) (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij")) ;;; Default behavior of open :if-exists is :create when the version @@ -957,79 +957,79 @@ :notes (:open-if-exists-new-version-no-error) (let ((pn (make-pathname :name "tmp" :type "dat" :version :newest))) (or (not (eql (pathname-version pn) :newest)) - (progn - ;; Create file - (let ((s1 (open pn :direction :io :if-exists :overwrite - :if-does-not-exist :create))) - (unwind-protect - ;; Now try again - (let ((s2 (open pn :direction :io))) - (unwind-protect - (write-line "abcdef" s2) - (close s2)) - (unwind-protect - (progn - (setq s2 (open s1 :direction :input)) - (equalt (read-line s2 nil) "abcdef")) - (close s2))) - (close s1) - (delete-all-versions pn) - ))))) + (progn + ;; Create file + (let ((s1 (open pn :direction :io :if-exists :overwrite + :if-does-not-exist :create))) + (unwind-protect + ;; Now try again + (let ((s2 (open pn :direction :io))) + (unwind-protect + (write-line "abcdef" s2) + (close s2)) + (unwind-protect + (progn + (setq s2 (open s1 :direction :input)) + (equalt (read-line s2 nil) "abcdef")) + (close s2))) + (close s1) + (delete-all-versions pn) + ))))) t) (def-open-io-test open.io.31 (:if-exists :rename - :direction :io) + :direction :io) (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.32 (:if-exists :rename-and-delete - :direction :io) + :direction :io) (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.33 (:if-exists :new-version - :direction :io) + :direction :io) (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.34 (:if-exists :supersede - :direction :io) + :direction :io) (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij")) (def-open-io-test open.io.35 (:if-exists nil - :direction :io) + :direction :io) (progn (file-position s :start) - (values (read-line s nil))) + (values (read-line s nil))) ("abcdefghij")) ;;;; :PROBE tests (defmacro def-open-probe-test (name args form - &key (build-form nil build-form-p) - (pathname #p"tmp.dat")) + &key (build-form nil build-form-p) + (pathname #p"tmp.dat")) (unless build-form-p (setf build-form - `(with-open-file (s pn :direction :output - :if-exists :supersede)))) + `(with-open-file (s pn :direction :output + :if-exists :supersede)))) `(deftest ,name (let ((pn ,pathname)) (delete-all-versions pn) ,build-form (let ((s (open pn :direction :probe ,@args))) - (values - ,(if build-form - `(and - (typep s 'file-stream) - (not (open-stream-p s)) - ) - `(not s)) - ,form))) + (values + ,(if build-form + `(and + (typep s 'file-stream) + (not (open-stream-p s)) + ) + `(not s)) + ,form))) t t)) (def-open-probe-test open.probe.1 () t) @@ -1074,7 +1074,7 @@ (let ((pn #p"tmp.dat")) (delete-all-versions pn) (let ((s (open pn :direction :probe :if-does-not-exist :create - :if-exists :error))) + :if-exists :error))) (values (notnot s) (notnot (probe-file pn))))) @@ -1228,7 +1228,7 @@ (deftest open.error.18 (signals-error-always (open #p"tmp.dat" :direction :output :if-exists :supersede - :external-form (gensym)) + :external-form (gensym)) error) t t) diff --git a/ansi-tests/optimize.lsp b/ansi-tests/optimize.lsp index 4b5db278..20671444 100644 --- a/ansi-tests/optimize.lsp +++ b/ansi-tests/optimize.lsp @@ -31,24 +31,24 @@ (deftest optimize.7 (loop for d in '(speed space safety debug compilation-speed) - nconc (loop for n from 0 to 3 - for form = `(locally (declare (optimize (,d ,n))) t) - for val = (eval form) - unless (eql val t) - collect (list d n val))) + nconc (loop for n from 0 to 3 + for form = `(locally (declare (optimize (,d ,n))) t) + for val = (eval form) + unless (eql val t) + collect (list d n val))) nil) (deftest optimize.8 (loop for d in '(speed space safety debug compilation-speed) - nconc (loop for n from 0 to 3 - for form = `(lambda () - (declare (optimize (,d ,n))) - t) - for val = (funcall (compile nil form)) - unless (eql val t) - collect (list d n val))) + nconc (loop for n from 0 to 3 + for form = `(lambda () + (declare (optimize (,d ,n))) + t) + for val = (funcall (compile nil form)) + unless (eql val t) + collect (list d n val))) nil) - \ No newline at end of file + diff --git a/ansi-tests/or.lsp b/ansi-tests/or.lsp index 577409c9..4142d9dc 100644 --- a/ansi-tests/or.lsp +++ b/ansi-tests/or.lsp @@ -34,7 +34,7 @@ (deftest or.8 (let ((x 0)) (values (or t (incf x)) - x)) + x)) t 0) (deftest or.9 @@ -59,7 +59,7 @@ (or (expand-in-current-env (%m nil)) (expand-in-current-env (%m 'a)) nil)) - a) + a) ;;; Error tests diff --git a/ansi-tests/output-stream-p.lsp b/ansi-tests/output-stream-p.lsp index e4f13c09..09e3afda 100644 --- a/ansi-tests/output-stream-p.lsp +++ b/ansi-tests/output-stream-p.lsp @@ -15,13 +15,13 @@ (deftest output-stream-p.3 (with-open-file (s "output-stream-p.lsp" :direction :input) - (output-stream-p s)) + (output-stream-p s)) nil) (deftest output-stream-p.4 (with-open-file (s "foo.txt" :direction :output - :if-exists :supersede) - (notnot-mv (output-stream-p s))) + :if-exists :supersede) + (notnot-mv (output-stream-p s))) t) ;;; Error tests diff --git a/ansi-tests/package-aux.lsp b/ansi-tests/package-aux.lsp index 34b02b76..ac0d9728 100644 --- a/ansi-tests/package-aux.lsp +++ b/ansi-tests/package-aux.lsp @@ -8,81 +8,81 @@ (defmacro test-with-package-iterator (package-list-expr &rest symbol-types) "Build an expression that tests the with-package-iterator form." (let ((name (gensym)) - (cht-var (gensym)) - (pkg-list-var (gensym))) + (cht-var (gensym)) + (pkg-list-var (gensym))) `(let ((,cht-var (make-hash-table)) - (,pkg-list-var ,package-list-expr) - (fail-count 0)) - (with-package-iterator (,name ,pkg-list-var - ,@(copy-list symbol-types)) - ;; For each symbol, check that name is returning appropriate - ;; things - (loop - (block fail - (multiple-value-bind (more sym access pkg) - (,name) - (unless more (return nil)) - (setf (gethash sym ,cht-var) t) ;; note presence of symbol - ;; Check that its access status is in the list, - ;; that pkg is a package, - ;; that the symbol is in the package, - ;; and that (in the package) it has the correct access type - (unless (member access (quote ,(copy-list symbol-types))) - (unless (> fail-count +fail-count-limit+) - (format t "Bad access type: ~S ==> ~A~%" sym access)) - (when (= fail-count +fail-count-limit+) - (format t "Further messages suppressed~%")) - (incf fail-count) - (return-from fail nil)) - - (unless (packagep pkg) - (unless (> fail-count +fail-count-limit+) - (format t "Not a package: ~S ==> ~S~%" sym pkg)) - (when (= fail-count +fail-count-limit+) - (format t "Further messages suppressed~%")) - (incf fail-count) - (return-from fail nil)) - (multiple-value-bind (sym2 access2) - (find-symbol (symbol-name sym) pkg) - (unless (or (eqt sym sym2) - (member sym2 (package-shadowing-symbols pkg))) - (unless (> fail-count +fail-count-limit+) - (format t "Not same symbol: ~S ~S~%" sym sym2)) - (when (= fail-count +fail-count-limit+) - (format t "Further messages suppressed~%")) - (incf fail-count) - (return-from fail nil)) - (unless (eqt access access2) - (unless (> fail-count +fail-count-limit+) - (format t "Not same access type: ~S ~S ~S~%" - sym access access2)) - (when (= fail-count +fail-count-limit+) - (format t "Further messages suppressed~%")) - (incf fail-count) - (return-from fail nil))))))) - ;; now, check that each symbol in each package has - ;; been properly found - (loop - for p in ,pkg-list-var do - (block fail - (do-symbols (sym p) - (multiple-value-bind (sym2 access) - (find-symbol (symbol-name sym) p) - (unless (eqt sym sym2) - (unless (> fail-count +fail-count-limit+) - (format t "Not same symbol (2): ~S ~S~%" - sym sym2)) - (when (= fail-count +fail-count-limit+) - (format t "Further messages suppressed~%")) - (incf fail-count) - (return-from fail nil)) - (unless (or (not (member access - (quote ,(copy-list symbol-types)))) - (gethash sym ,cht-var)) - (format t "Symbol not found: ~S~%" sym) - (incf fail-count) - (return-from fail nil)))))) - (or (zerop fail-count) fail-count)))) + (,pkg-list-var ,package-list-expr) + (fail-count 0)) + (with-package-iterator (,name ,pkg-list-var + ,@(copy-list symbol-types)) + ;; For each symbol, check that name is returning appropriate + ;; things + (loop + (block fail + (multiple-value-bind (more sym access pkg) + (,name) + (unless more (return nil)) + (setf (gethash sym ,cht-var) t) ;; note presence of symbol + ;; Check that its access status is in the list, + ;; that pkg is a package, + ;; that the symbol is in the package, + ;; and that (in the package) it has the correct access type + (unless (member access (quote ,(copy-list symbol-types))) + (unless (> fail-count +fail-count-limit+) + (format t "Bad access type: ~S ==> ~A~%" sym access)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil)) + + (unless (packagep pkg) + (unless (> fail-count +fail-count-limit+) + (format t "Not a package: ~S ==> ~S~%" sym pkg)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil)) + (multiple-value-bind (sym2 access2) + (find-symbol (symbol-name sym) pkg) + (unless (or (eqt sym sym2) + (member sym2 (package-shadowing-symbols pkg))) + (unless (> fail-count +fail-count-limit+) + (format t "Not same symbol: ~S ~S~%" sym sym2)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil)) + (unless (eqt access access2) + (unless (> fail-count +fail-count-limit+) + (format t "Not same access type: ~S ~S ~S~%" + sym access access2)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil))))))) + ;; now, check that each symbol in each package has + ;; been properly found + (loop + for p in ,pkg-list-var do + (block fail + (do-symbols (sym p) + (multiple-value-bind (sym2 access) + (find-symbol (symbol-name sym) p) + (unless (eqt sym sym2) + (unless (> fail-count +fail-count-limit+) + (format t "Not same symbol (2): ~S ~S~%" + sym sym2)) + (when (= fail-count +fail-count-limit+) + (format t "Further messages suppressed~%")) + (incf fail-count) + (return-from fail nil)) + (unless (or (not (member access + (quote ,(copy-list symbol-types)))) + (gethash sym ,cht-var)) + (format t "Symbol not found: ~S~%" sym) + (incf fail-count) + (return-from fail nil)))))) + (or (zerop fail-count) fail-count)))) (defun with-package-iterator-internal (packages) (test-with-package-iterator packages :internal)) @@ -100,7 +100,7 @@ (let ((num 0)) (declare (fixnum num)) (do-external-symbols (s p num) - (declare (ignorable s)) + (declare (ignorable s)) (incf num)))) (defun external-symbols-in-package (p) @@ -108,27 +108,27 @@ (do-external-symbols (s p) (push s symbols)) (sort symbols #'(lambda (s1 s2) (string< (symbol-name s1) - (symbol-name s2)))))) + (symbol-name s2)))))) (defun num-symbols-in-package (p) (let ((num 0)) (declare (fixnum num)) (do-symbols (s p num) - (declare (ignorable s)) + (declare (ignorable s)) (incf num)))) (defun sort-symbols (sl) (sort (copy-list sl) - #'(lambda (x y) - (or - (string< (symbol-name x) - (symbol-name y)) - (and (string= (symbol-name x) - (symbol-name y)) - (string< (package-name (symbol-package x)) - (package-name (symbol-package y)))))))) + #'(lambda (x y) + (or + (string< (symbol-name x) + (symbol-name y)) + (and (string= (symbol-name x) + (symbol-name y)) + (string< (package-name (symbol-package x)) + (package-name (symbol-package y)))))))) (defun sort-package-list (x) (sort (copy-list x) - #'string< - :key #'package-name)) + #'string< + :key #'package-name)) diff --git a/ansi-tests/package-error-package.lsp b/ansi-tests/package-error-package.lsp index cde6dc6a..1ceb58d2 100644 --- a/ansi-tests/package-error-package.lsp +++ b/ansi-tests/package-error-package.lsp @@ -7,29 +7,29 @@ (deftest package-error-package.1 (eqt (find-package (package-error-package - (make-condition 'package-error - :package "CL"))) + (make-condition 'package-error + :package "CL"))) (find-package "CL")) t) (deftest package-error-package.2 (eqt (find-package (package-error-package - (make-condition 'package-error - :package (find-package "CL")))) + (make-condition 'package-error + :package (find-package "CL")))) (find-package "CL")) t) (deftest package-error-package.3 (eqt (find-package (package-error-package - (make-condition 'package-error - :package '#:|CL|))) + (make-condition 'package-error + :package '#:|CL|))) (find-package "CL")) t) (deftest package-error-package.4 (eqt (find-package (package-error-package - (make-condition 'package-error - :package #\A))) + (make-condition 'package-error + :package #\A))) (find-package "A")) t) diff --git a/ansi-tests/package-error.lsp b/ansi-tests/package-error.lsp index 3f896458..864c4773 100644 --- a/ansi-tests/package-error.lsp +++ b/ansi-tests/package-error.lsp @@ -8,14 +8,14 @@ (deftest package-error.1 (not (typep (make-condition 'package-error :package "CL") - 'package-error)) + 'package-error)) nil) (deftest package-error.2 (not (typep (make-condition 'package-error - :package (find-package "CL")) - 'package-error)) + :package (find-package "CL")) + 'package-error)) nil) (deftest package-error.3 @@ -25,7 +25,7 @@ (deftest package-error.4 (not (typep (make-condition 'package-error - :package (find-package '#:|CL|)) - 'package-error)) + :package (find-package '#:|CL|)) + 'package-error)) nil) diff --git a/ansi-tests/package-name.lsp b/ansi-tests/package-name.lsp index e3e45563..4bdde92a 100644 --- a/ansi-tests/package-name.lsp +++ b/ansi-tests/package-name.lsp @@ -36,8 +36,8 @@ (deftest package-name.5 (handler-case (locally (declare (optimize safety)) - (eval '(package-name "NOT-THERE")) - nil) + (eval '(package-name "NOT-THERE")) + nil) (type-error () t) (package-error () t)) t) @@ -45,8 +45,8 @@ (deftest package-name.6 (handler-case (locally (declare (optimize safety)) - (eval '(package-name #\*)) - nil) + (eval '(package-name #\*)) + nil) (type-error () t) (package-error () t)) t) @@ -54,8 +54,8 @@ (deftest package-name.6a (handler-case (locally (declare (optimize safety)) - (eval '(locally (package-name #\*) t)) - nil) + (eval '(locally (package-name #\*) t)) + nil) (type-error () t) (package-error () t)) t) @@ -86,7 +86,7 @@ (deftest package-name.13 (let* ((p (make-package "TEMP1")) - (pname1 (package-name p))) + (pname1 (package-name p))) (rename-package "TEMP1" "TEMP2") (let ((pname2 (package-name p))) (safely-delete-package p) @@ -100,7 +100,7 @@ (not (let ((name (package-name p))) (and (stringp name) - (eqt (find-package name) p))))) + (eqt (find-package name) p))))) 0) ;; package-name applied to a package's name @@ -109,7 +109,7 @@ (loop for p in (list-all-packages) count (not (equal (package-name p) - (package-name (package-name p))))) + (package-name (package-name p))))) 0) ;;; Specialized sequence tests @@ -117,11 +117,11 @@ (defmacro def-package-name-test (test-name name-form expected-name-form) `(deftest ,test-name (let ((name ,name-form) - (expected-name ,expected-name-form)) + (expected-name ,expected-name-form)) (assert (string= name expected-name)) (safely-delete-package name) (let ((p (make-package name :use nil))) - (equalt (package-name p) expected-name))) + (equalt (package-name p) expected-name))) t)) (def-package-name-test package-name.16 @@ -130,40 +130,40 @@ (def-package-name-test package-name.17 (make-array 10 :element-type 'base-char - :fill-pointer 5 - :initial-contents "TEST1?????") + :fill-pointer 5 + :initial-contents "TEST1?????") "TEST1") (def-package-name-test package-name.18 (make-array 10 :element-type 'character - :fill-pointer 5 - :initial-contents "TEST1?????") + :fill-pointer 5 + :initial-contents "TEST1?????") "TEST1") (def-package-name-test package-name.19 (make-array 5 :element-type 'base-char :adjustable t - :initial-contents "TEST1") + :initial-contents "TEST1") "TEST1") (def-package-name-test package-name.20 (make-array 5 :element-type 'character :adjustable t - :initial-contents "TEST1") + :initial-contents "TEST1") "TEST1") (def-package-name-test package-name.21 (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2)) + :displaced-index-offset 2)) "TEST1") (def-package-name-test package-name.22 (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2)) + :displaced-index-offset 2)) "TEST1") diff --git a/ansi-tests/package-nicknames.lsp b/ansi-tests/package-nicknames.lsp index bf9a6ac9..992d5a76 100644 --- a/ansi-tests/package-nicknames.lsp +++ b/ansi-tests/package-nicknames.lsp @@ -47,15 +47,15 @@ (deftest package-nicknames.7 (subsetp '(#.(string '#:cl)) - (package-nicknames "COMMON-LISP") - :test #'string=) + (package-nicknames "COMMON-LISP") + :test #'string=) t) (deftest package-nicknames.8 (notnot (subsetp '(#.(string '#:cl-user)) - (package-nicknames "COMMON-LISP-USER") - :test #'string=)) + (package-nicknames "COMMON-LISP-USER") + :test #'string=)) t) (deftest package-nicknames.9 @@ -75,8 +75,8 @@ (deftest package-nicknames.11 (handler-case (locally (declare (optimize safety)) - (eval '(package-nicknames "NOT-A-PACKAGE-NAME")) - nil) + (eval '(package-nicknames "NOT-A-PACKAGE-NAME")) + nil) (type-error () t) (package-error () t)) t) @@ -88,9 +88,9 @@ for p in (list-all-packages) sum (loop for nk in (package-nicknames p) count - (not - (and (stringp nk) - (eqt p (find-package nk)))))) + (not + (and (stringp nk) + (eqt p (find-package nk)))))) 0) ;;; Specialized sequence names tests @@ -100,7 +100,7 @@ (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) - (package-nicknames p))) + (package-nicknames p))) nil)) (def-package-nicknames-test package-nicknames.16 @@ -108,35 +108,35 @@ (def-package-nicknames-test package-nicknames.17 (make-array 10 :element-type 'base-char - :fill-pointer 5 - :initial-contents "TEST1?????")) + :fill-pointer 5 + :initial-contents "TEST1?????")) (def-package-nicknames-test package-nicknames.18 (make-array 10 :element-type 'character - :fill-pointer 5 - :initial-contents "TEST1?????")) + :fill-pointer 5 + :initial-contents "TEST1?????")) (def-package-nicknames-test package-nicknames.19 (make-array 5 :element-type 'base-char :adjustable t - :initial-contents "TEST1")) + :initial-contents "TEST1")) (def-package-nicknames-test package-nicknames.20 (make-array 5 :element-type 'character :adjustable t - :initial-contents "TEST1")) + :initial-contents "TEST1")) (def-package-nicknames-test package-nicknames.21 (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) + :displaced-index-offset 2))) (def-package-nicknames-test package-nicknames.22 (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) + :displaced-index-offset 2))) ;;; Error tests diff --git a/ansi-tests/package-shadowing-symbols.lsp b/ansi-tests/package-shadowing-symbols.lsp index fecd25b6..2445b89b 100644 --- a/ansi-tests/package-shadowing-symbols.lsp +++ b/ansi-tests/package-shadowing-symbols.lsp @@ -14,7 +14,7 @@ (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) - (package-shadowing-symbols p))) + (package-shadowing-symbols p))) nil)) (def-package-shadowing-symbols-test package-shadowing-symbols.1 @@ -22,35 +22,35 @@ (def-package-shadowing-symbols-test package-shadowing-symbols.2 (make-array 10 :element-type 'base-char - :fill-pointer 5 - :initial-contents "TEST1?????")) + :fill-pointer 5 + :initial-contents "TEST1?????")) (def-package-shadowing-symbols-test package-shadowing-symbols.3 (make-array 10 :element-type 'character - :fill-pointer 5 - :initial-contents "TEST1?????")) + :fill-pointer 5 + :initial-contents "TEST1?????")) (def-package-shadowing-symbols-test package-shadowing-symbols.4 (make-array 5 :element-type 'base-char :adjustable t - :initial-contents "TEST1")) + :initial-contents "TEST1")) (def-package-shadowing-symbols-test package-shadowing-symbols.5 (make-array 5 :element-type 'character :adjustable t - :initial-contents "TEST1")) + :initial-contents "TEST1")) (def-package-shadowing-symbols-test package-shadowing-symbols.6 (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) + :displaced-index-offset 2))) (def-package-shadowing-symbols-test package-shadowing-symbols.7 (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) + :displaced-index-offset 2))) ;;; Error tests diff --git a/ansi-tests/package-use-list.lsp b/ansi-tests/package-use-list.lsp index 3926adb2..5a6ec89c 100644 --- a/ansi-tests/package-use-list.lsp +++ b/ansi-tests/package-use-list.lsp @@ -14,7 +14,7 @@ (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) - (package-use-list p))) + (package-use-list p))) nil)) (def-package-use-list-test package-use-list.1 @@ -22,35 +22,35 @@ (def-package-use-list-test package-use-list.2 (make-array 10 :element-type 'base-char - :fill-pointer 5 - :initial-contents "TEST1?????")) + :fill-pointer 5 + :initial-contents "TEST1?????")) (def-package-use-list-test package-use-list.3 (make-array 10 :element-type 'character - :fill-pointer 5 - :initial-contents "TEST1?????")) + :fill-pointer 5 + :initial-contents "TEST1?????")) (def-package-use-list-test package-use-list.4 (make-array 5 :element-type 'base-char :adjustable t - :initial-contents "TEST1")) + :initial-contents "TEST1")) (def-package-use-list-test package-use-list.5 (make-array 5 :element-type 'character :adjustable t - :initial-contents "TEST1")) + :initial-contents "TEST1")) (def-package-use-list-test package-use-list.6 (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) + :displaced-index-offset 2))) (def-package-use-list-test package-use-list.7 (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) + :displaced-index-offset 2))) ;;; Error tests diff --git a/ansi-tests/package-used-by-list.lsp b/ansi-tests/package-used-by-list.lsp index dded936e..4bd5ba7a 100644 --- a/ansi-tests/package-used-by-list.lsp +++ b/ansi-tests/package-used-by-list.lsp @@ -14,7 +14,7 @@ (let ((name ,name-form)) (safely-delete-package name) (let ((p (make-package name :use nil))) - (package-used-by-list p))) + (package-used-by-list p))) nil)) (def-package-used-by-list-test package-used-by-list.1 @@ -22,35 +22,35 @@ (def-package-used-by-list-test package-used-by-list.2 (make-array 10 :element-type 'base-char - :fill-pointer 5 - :initial-contents "TEST1?????")) + :fill-pointer 5 + :initial-contents "TEST1?????")) (def-package-used-by-list-test package-used-by-list.3 (make-array 10 :element-type 'character - :fill-pointer 5 - :initial-contents "TEST1?????")) + :fill-pointer 5 + :initial-contents "TEST1?????")) (def-package-used-by-list-test package-used-by-list.4 (make-array 5 :element-type 'base-char :adjustable t - :initial-contents "TEST1")) + :initial-contents "TEST1")) (def-package-used-by-list-test package-used-by-list.5 (make-array 5 :element-type 'character :adjustable t - :initial-contents "TEST1")) + :initial-contents "TEST1")) (def-package-used-by-list-test package-used-by-list.6 (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) + :displaced-index-offset 2))) (def-package-used-by-list-test package-used-by-list.7 (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "XXTEST1XXX"))) + (name0 (make-array 10 :element-type etype + :initial-contents "XXTEST1XXX"))) (make-array 5 :element-type etype :displaced-to name0 - :displaced-index-offset 2))) + :displaced-index-offset 2))) ;;; Error tests diff --git a/ansi-tests/pairlis.lsp b/ansi-tests/pairlis.lsp index 658e18e7..d9625e57 100644 --- a/ansi-tests/pairlis.lsp +++ b/ansi-tests/pairlis.lsp @@ -16,7 +16,7 @@ (if (null x) alist (acons (car x) (car y) - (my-pairlis (cdr x) (cdr y) alist)))) + (my-pairlis (cdr x) (cdr y) alist)))) (deftest pairlis.1 (pairlis nil nil nil) @@ -28,38 +28,38 @@ (deftest pairlis.3 (let* ((x (copy-list '(a b c d e))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(1 2 3 4 5))) - (ycopy (make-scaffold-copy y)) - (result (pairlis x y)) - (expected (my-pairlis x y))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(1 2 3 4 5))) + (ycopy (make-scaffold-copy y)) + (result (pairlis x y)) + (expected (my-pairlis x y))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (or - (equal result expected) - (equal result (reverse expected))) + (equal result expected) + (equal result (reverse expected))) t)) t) (deftest pairlis.4 (let* ((x (copy-list '(a b c d e))) - (xcopy (make-scaffold-copy x)) - (y (copy-list '(1 2 3 4 5))) - (ycopy (make-scaffold-copy y)) - (z '((x . 10) (y . 20))) - (zcopy (make-scaffold-copy z)) - (result (pairlis x y z)) - (expected (my-pairlis x y z))) + (xcopy (make-scaffold-copy x)) + (y (copy-list '(1 2 3 4 5))) + (ycopy (make-scaffold-copy y)) + (z '((x . 10) (y . 20))) + (zcopy (make-scaffold-copy z)) + (result (pairlis x y z)) + (expected (my-pairlis x y z))) (and (check-scaffold-copy x xcopy) (check-scaffold-copy y ycopy) (check-scaffold-copy z zcopy) (eqt (cdr (cddr (cddr result))) z) (or - (equal result expected) - (equal result (append (reverse (subseq expected 0 5)) - (subseq expected 5)))) + (equal result expected) + (equal result (append (reverse (subseq expected 0 5)) + (subseq expected 5)))) t)) t) diff --git a/ansi-tests/parse-integer.lsp b/ansi-tests/parse-integer.lsp index 13a9ec6f..35063b5c 100644 --- a/ansi-tests/parse-integer.lsp +++ b/ansi-tests/parse-integer.lsp @@ -23,10 +23,10 @@ (deftest parse-integer.error.5 (loop for x across +standard-chars+ - unless (or (digit-char-p x) - (eval `(signals-error (parse-integer ,(string x)) - parse-error))) - collect x) + unless (or (digit-char-p x) + (eval `(signals-error (parse-integer ,(string x)) + parse-error))) + collect x) nil) (deftest parse-integer.error.5a @@ -89,34 +89,34 @@ (deftest parse-integer.4 (parse-integer (concatenate 'string (string #\Newline) "17" - (string #\Newline))) + (string #\Newline))) 17 4) (deftest parse-integer.5 (let ((c (name-char "Tab"))) (if c - (parse-integer (concatenate 'string (string c) "6381" (string c))) + (parse-integer (concatenate 'string (string c) "6381" (string c))) (values 6381 6))) 6381 6) (deftest parse-integer.6 (let ((c (name-char "Linefeed"))) (if c - (parse-integer (concatenate 'string (string c) "-123712" (string c))) + (parse-integer (concatenate 'string (string c) "-123712" (string c))) (values -123712 9))) -123712 9) (deftest parse-integer.7 (let ((c (name-char "Page"))) (if c - (parse-integer (concatenate 'string (string c) "0" (string c))) + (parse-integer (concatenate 'string (string c) "0" (string c))) (values 0 3))) 0 3) (deftest parse-integer.8 (let ((c (name-char "Return"))) (if c - (parse-integer (concatenate 'string (string c) "999" (string c))) + (parse-integer (concatenate 'string (string c) "999" (string c))) (values 999 5))) 999 5) @@ -150,13 +150,13 @@ (deftest parse-integer.16 (loop for radix from 2 to 36 - for c across "123456789abcdefghijklmnopqrstuvwxyz" - for s = (concatenate 'string (string c) "0") - for vals = (multiple-value-list (parse-integer s :radix radix)) - for (val pos) = vals - always (and (= (length vals) 2) - (= pos 2) - (= val (* radix (1- radix))))) + for c across "123456789abcdefghijklmnopqrstuvwxyz" + for s = (concatenate 'string (string c) "0") + for vals = (multiple-value-list (parse-integer s :radix radix)) + for (val pos) = vals + always (and (= (length vals) 2) + (= pos 2) + (= val (* radix (1- radix))))) t) (deftest parse-integer.17 @@ -203,13 +203,13 @@ (deftest parse-integer.27 (parse-integer "a1234b" :start 2 :end 4 :allow-other-keys t - :allow-other-keys nil :foo nil) + :allow-other-keys nil :foo nil) 23 4) (deftest parse-integer.28 (let* ((s (make-array 5 :initial-contents "a123b" :element-type 'base-char)) - (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 - :element-type 'base-char))) + (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 + :element-type 'base-char))) (values s2 (length s2) @@ -219,8 +219,8 @@ (deftest parse-integer.28a (let* ((s (make-array 5 :initial-contents "a123b" :element-type 'character)) - (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 - :element-type 'character))) + (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 + :element-type 'character))) (values s2 (length s2) @@ -230,8 +230,8 @@ (deftest parse-integer.29 (let ((s (make-array 10 :initial-contents "1234567890" - :fill-pointer 3 - :element-type 'base-char))) + :fill-pointer 3 + :element-type 'base-char))) (values (length s) (multiple-value-list (parse-integer s)))) @@ -239,8 +239,8 @@ (deftest parse-integer.29a (let ((s (make-array 10 :initial-contents "1234567890" - :fill-pointer 3 - :element-type 'character))) + :fill-pointer 3 + :element-type 'character))) (values (length s) (multiple-value-list (parse-integer s)))) @@ -248,8 +248,8 @@ (deftest parse-integer.30 (let ((s (make-array 10 :initial-contents "1234567890" - :adjustable t - :element-type 'base-char))) + :adjustable t + :element-type 'base-char))) (values (length s) (multiple-value-list (parse-integer s)) @@ -262,8 +262,8 @@ (deftest parse-integer.30a (let ((s (make-array 10 :initial-contents "1234567890" - :adjustable t - :element-type 'character))) + :adjustable t + :element-type 'character))) (values (length s) (multiple-value-list (parse-integer s)) @@ -284,10 +284,10 @@ (deftest parse-integer.33 (let* ((s (make-array 5 :initial-contents "a123b" :element-type 'base-char)) - (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 - :element-type 'base-char)) - (s3 (make-array 2 :displaced-to s2 :displaced-index-offset 1 - :element-type 'base-char))) + (s2 (make-array 3 :displaced-to s :displaced-index-offset 1 + :element-type 'base-char)) + (s3 (make-array 2 :displaced-to s2 :displaced-index-offset 1 + :element-type 'base-char))) (values s3 (length s3) @@ -314,9 +314,9 @@ (values (multiple-value-list (parse-integer (progn (setf a (incf i)) "10001") - :radix (progn (setf b (incf i)) 2) - :start (progn (setf c (incf i)) 0) - :end (progn (setf d (incf i)) 5) - :junk-allowed (progn (setf e (incf i)) nil))) + :radix (progn (setf b (incf i)) 2) + :start (progn (setf c (incf i)) 0) + :end (progn (setf d (incf i)) 5) + :junk-allowed (progn (setf e (incf i)) nil))) i a b c d e)) (17 5) 5 1 2 3 4 5) diff --git a/ansi-tests/parse-namestring.lsp b/ansi-tests/parse-namestring.lsp index 0d83e89b..efbf6fc4 100644 --- a/ansi-tests/parse-namestring.lsp +++ b/ansi-tests/parse-namestring.lsp @@ -12,7 +12,7 @@ (let ((vals (multiple-value-list (parse-namestring "")))) (assert (= (length vals) 2)) (let ((pn (first vals)) - (pos (second vals))) + (pos (second vals))) (values (pathname-directory pn) (pathname-device pn) @@ -26,7 +26,7 @@ (let ((vals (multiple-value-list (parse-namestring (make-array 0 :element-type 'base-char))))) (assert (= (length vals) 2)) (let ((pn (first vals)) - (pos (second vals))) + (pos (second vals))) (values (pathname-directory pn) (pathname-device pn) @@ -38,11 +38,11 @@ (deftest parse-namestring.3 (let ((vals (multiple-value-list (parse-namestring (make-array 4 :element-type 'base-char - :initial-element #\X - :fill-pointer 0))))) + :initial-element #\X + :fill-pointer 0))))) (assert (= (length vals) 2)) (let ((pn (first vals)) - (pos (second vals))) + (pos (second vals))) (values (pathname-directory pn) (pathname-device pn) @@ -54,22 +54,22 @@ (deftest parse-namestring.4 (loop for etype in '(standard-char base-char character) - for s0 = (make-array 4 :element-type etype :initial-element #\X) - for s = (make-array 0 :element-type etype :displaced-to s0 - :displaced-index-offset 1) - for vals = (multiple-value-list (parse-namestring s)) - for pn = (first vals) - for pos = (second vals) - do (assert (= (length vals) 2)) - nconc - (let ((result (list (pathname-directory pn) - (pathname-device pn) - (pathname-name pn) - (pathname-type pn) - (pathname-version pn) - pos))) - (unless (equal result '(nil nil nil nil nil 0)) - (list (list etype result))))) + for s0 = (make-array 4 :element-type etype :initial-element #\X) + for s = (make-array 0 :element-type etype :displaced-to s0 + :displaced-index-offset 1) + for vals = (multiple-value-list (parse-namestring s)) + for pn = (first vals) + for pos = (second vals) + do (assert (= (length vals) 2)) + nconc + (let ((result (list (pathname-directory pn) + (pathname-device pn) + (pathname-name pn) + (pathname-type pn) + (pathname-version pn) + pos))) + (unless (equal result '(nil nil nil nil nil 0)) + (list (list etype result))))) nil) ;;; Error tests diff --git a/ansi-tests/pathname-device.lsp b/ansi-tests/pathname-device.lsp index 228682cb..cd87f9c4 100644 --- a/ansi-tests/pathname-device.lsp +++ b/ansi-tests/pathname-device.lsp @@ -9,56 +9,56 @@ (deftest pathname-device.1 (loop for p in *pathnames* - for device = (pathname-device p) - unless (or (stringp device) - (member device '(nil :wild :unspecific))) - collect (list p device)) + for device = (pathname-device p) + unless (or (stringp device) + (member device '(nil :wild :unspecific))) + collect (list p device)) nil) (deftest pathname-device.2 (loop for p in *pathnames* - for device = (pathname-device p :case :local) - unless (or (stringp device) - (member device '(nil :wild :unspecific))) - collect (list p device)) + for device = (pathname-device p :case :local) + unless (or (stringp device) + (member device '(nil :wild :unspecific))) + collect (list p device)) nil) (deftest pathname-device.3 (loop for p in *pathnames* - for device = (pathname-device p :case :common) - unless (or (stringp device) - (member device '(nil :wild :unspecific))) - collect (list p device)) + for device = (pathname-device p :case :common) + unless (or (stringp device) + (member device '(nil :wild :unspecific))) + collect (list p device)) nil) (deftest pathname-device.4 (loop for p in *pathnames* - for device = (pathname-device p :allow-other-keys nil) - unless (or (stringp device) - (member device '(nil :wild :unspecific))) - collect (list p device)) + for device = (pathname-device p :allow-other-keys nil) + unless (or (stringp device) + (member device '(nil :wild :unspecific))) + collect (list p device)) nil) (deftest pathname-device.5 (loop for p in *pathnames* - for device = (pathname-device p :foo 'bar :allow-other-keys t) - unless (or (stringp device) - (member device '(nil :wild :unspecific))) - collect (list p device)) + for device = (pathname-device p :foo 'bar :allow-other-keys t) + unless (or (stringp device) + (member device '(nil :wild :unspecific))) + collect (list p device)) nil) (deftest pathname-device.6 (loop for p in *pathnames* - for device = (pathname-device p :allow-other-keys t :allow-other-keys nil :foo 'bar) - unless (or (stringp device) - (member device '(nil :wild :unspecific))) - collect (list p device)) + for device = (pathname-device p :allow-other-keys t :allow-other-keys nil :foo 'bar) + unless (or (stringp device) + (member device '(nil :wild :unspecific))) + collect (list p device)) nil) ;;; section 19.3.2.1 (deftest pathname-device.7 (loop for p in *logical-pathnames* - always (eq (pathname-device p) :unspecific)) + always (eq (pathname-device p) :unspecific)) t) (deftest pathname-device.8 @@ -71,4 +71,4 @@ (deftest pathname-device.error.2 (check-type-error #'pathname-device #'could-be-pathname-designator) - nil) \ No newline at end of file + nil) diff --git a/ansi-tests/pathname-directory.lsp b/ansi-tests/pathname-directory.lsp index 01d86cd3..0871e892 100644 --- a/ansi-tests/pathname-directory.lsp +++ b/ansi-tests/pathname-directory.lsp @@ -9,71 +9,71 @@ (deftest pathname-directory.1 (loop for p in *pathnames* - for directory = (pathname-directory p) - unless (or (stringp directory) - (member directory '(nil :wild :unspecific)) - (and (consp directory) - (member (car directory) '(:absolute :relative)))) - collect (list p directory)) + for directory = (pathname-directory p) + unless (or (stringp directory) + (member directory '(nil :wild :unspecific)) + (and (consp directory) + (member (car directory) '(:absolute :relative)))) + collect (list p directory)) nil) (deftest pathname-directory.2 (loop for p in *pathnames* - for directory = (pathname-directory p :case :local) - unless (or (stringp directory) - (member directory '(nil :wild :unspecific)) - (and (consp directory) - (member (car directory) '(:absolute :relative)))) - collect (list p directory)) + for directory = (pathname-directory p :case :local) + unless (or (stringp directory) + (member directory '(nil :wild :unspecific)) + (and (consp directory) + (member (car directory) '(:absolute :relative)))) + collect (list p directory)) nil) (deftest pathname-directory.3 (loop for p in *pathnames* - for directory = (pathname-directory p :case :common) - unless (or (stringp directory) - (member directory '(nil :wild :unspecific)) - (and (consp directory) - (member (car directory) '(:absolute :relative)))) - collect (list p directory)) + for directory = (pathname-directory p :case :common) + unless (or (stringp directory) + (member directory '(nil :wild :unspecific)) + (and (consp directory) + (member (car directory) '(:absolute :relative)))) + collect (list p directory)) nil) (deftest pathname-directory.4 (loop for p in *pathnames* - for directory = (pathname-directory p :allow-other-keys nil) - unless (or (stringp directory) - (member directory '(nil :wild :unspecific)) - (and (consp directory) - (member (car directory) '(:absolute :relative)))) - collect (list p directory)) + for directory = (pathname-directory p :allow-other-keys nil) + unless (or (stringp directory) + (member directory '(nil :wild :unspecific)) + (and (consp directory) + (member (car directory) '(:absolute :relative)))) + collect (list p directory)) nil) (deftest pathname-directory.5 (loop for p in *pathnames* - for directory = (pathname-directory p :foo 'bar :allow-other-keys t) - unless (or (stringp directory) - (member directory '(nil :wild :unspecific)) - (and (consp directory) - (member (car directory) '(:absolute :relative)))) - collect (list p directory)) + for directory = (pathname-directory p :foo 'bar :allow-other-keys t) + unless (or (stringp directory) + (member directory '(nil :wild :unspecific)) + (and (consp directory) + (member (car directory) '(:absolute :relative)))) + collect (list p directory)) nil) (deftest pathname-directory.6 (loop for p in *pathnames* - for directory = (pathname-directory p :allow-other-keys t - :allow-other-keys nil - 'foo 'bar) - unless (or (stringp directory) - (member directory '(nil :wild :unspecific)) - (and (consp directory) - (member (car directory) '(:absolute :relative)))) - collect (list p directory)) + for directory = (pathname-directory p :allow-other-keys t + :allow-other-keys nil + 'foo 'bar) + unless (or (stringp directory) + (member directory '(nil :wild :unspecific)) + (and (consp directory) + (member (car directory) '(:absolute :relative)))) + collect (list p directory)) nil) ;;; section 19.3.2.1 (deftest pathname-directory.7 (loop for p in *logical-pathnames* - when (eq (pathname-directory p) :unspecific) - collect p) + when (eq (pathname-directory p) :unspecific) + collect p) nil) (deftest pathname-directory.8 diff --git a/ansi-tests/pathname-host.lsp b/ansi-tests/pathname-host.lsp index 7c29c27f..2ed90306 100644 --- a/ansi-tests/pathname-host.lsp +++ b/ansi-tests/pathname-host.lsp @@ -9,43 +9,43 @@ (deftest pathname-host.1 (loop for p in *pathnames* - always (eql (length (multiple-value-list (pathname-host p))) 1)) + always (eql (length (multiple-value-list (pathname-host p))) 1)) t) (deftest pathname-host.2 (loop for p in *pathnames* - always (eql (length (multiple-value-list (pathname-host p :case :local))) 1)) + always (eql (length (multiple-value-list (pathname-host p :case :local))) 1)) t) (deftest pathname-host.3 (loop for p in *pathnames* - always (eql (length (multiple-value-list (pathname-host p :case :common))) 1)) + always (eql (length (multiple-value-list (pathname-host p :case :common))) 1)) t) (deftest pathname-host.4 (loop for p in *pathnames* - always (eql (length (multiple-value-list (pathname-host p :allow-other-keys nil))) 1)) + always (eql (length (multiple-value-list (pathname-host p :allow-other-keys nil))) 1)) t) (deftest pathname-host.5 (loop for p in *pathnames* - always (eql (length (multiple-value-list - (pathname-host p :foo t :allow-other-keys t))) 1)) + always (eql (length (multiple-value-list + (pathname-host p :foo t :allow-other-keys t))) 1)) t) (deftest pathname-host.6 (loop for p in *pathnames* - always (eql (length (multiple-value-list - (pathname-host p :allow-other-keys t - :allow-other-keys nil - 'foo t))) 1)) + always (eql (length (multiple-value-list + (pathname-host p :allow-other-keys t + :allow-other-keys nil + 'foo t))) 1)) t) ;;; section 19.3.2.1 (deftest pathname-host.7 (loop for p in *logical-pathnames* - when (eq (pathname-host p) :unspecific) - collect p) + when (eq (pathname-host p) :unspecific) + collect p) nil) (deftest pathname-host.8 @@ -55,11 +55,11 @@ #| (deftest pathname-host.9 (loop for p in *pathnames* - for host = (pathname-host p) - unless (or (stringp host) - (and (listp host) (every #'stringp host)) - (eql host :unspecific)) - collect (list p host)) + for host = (pathname-host p) + unless (or (stringp host) + (and (listp host) (every #'stringp host)) + (eql host :unspecific)) + collect (list p host)) nil) |# @@ -75,5 +75,5 @@ (deftest pathname-host.error.3 (signals-error (pathname-host *default-pathname-defaults* '#:bogus t) - program-error) + program-error) t) diff --git a/ansi-tests/pathname-match-p.lsp b/ansi-tests/pathname-match-p.lsp index 09bbd276..8e0ff8eb 100644 --- a/ansi-tests/pathname-match-p.lsp +++ b/ansi-tests/pathname-match-p.lsp @@ -11,42 +11,42 @@ (deftest pathname-match-p.1 (let ((pn1 (make-pathname :name :wild)) - (pn2 (make-pathname :name "foo"))) + (pn2 (make-pathname :name "foo"))) (pathname-match-p pn1 pn2)) nil) (deftest pathname-match-p.2 (let ((pn1 (make-pathname :type :wild)) - (pn2 (make-pathname :type "txt"))) + (pn2 (make-pathname :type "txt"))) (pathname-match-p pn1 pn2)) nil) (deftest pathname-match-p.3 (let ((pn1 (make-pathname :directory '(:absolute :wild))) - (pn2 (make-pathname :directory '(:absolute)))) + (pn2 (make-pathname :directory '(:absolute)))) (pathname-match-p pn1 pn2)) nil) (deftest pathname-match-p.4 (let ((pn1 (make-pathname :directory '(:relative :wild))) - (pn2 (make-pathname :directory '(:relative)))) + (pn2 (make-pathname :directory '(:relative)))) (pathname-match-p pn1 pn2)) nil) (deftest pathname-match-p.5 (let ((pn1 (make-pathname :directory '(:relative :wild))) - (pn2 (make-pathname :directory nil))) + (pn2 (make-pathname :directory nil))) (and (wild-pathname-p pn1) - (not (pathname-directory pn2)) - (not (pathname-match-p pn1 pn2)))) + (not (pathname-directory pn2)) + (not (pathname-match-p pn1 pn2)))) nil) (deftest pathname-match-p.6 (let ((pn1 (make-pathname :version :wild)) - (pn2 (make-pathname))) + (pn2 (make-pathname))) (and (wild-pathname-p pn1) - (not (pathname-version pn2)) - (not (pathname-match-p pn1 pn2)))) + (not (pathname-version pn2)) + (not (pathname-match-p pn1 pn2)))) nil) ;;; Specialized string tests @@ -64,7 +64,7 @@ (s "CLTEST:*.LSP" nil) (assert (pathname-match-p "CLTEST:FOO.LSP" s))) nil) - + ;;; Add more tests here @@ -84,20 +84,20 @@ (deftest pathname-match-p.error.4 (check-type-error #'(lambda (x) (pathname-match-p x #p"")) - #'could-be-pathname-designator) + #'could-be-pathname-designator) nil) (deftest pathname-match-p.error.5 (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pathname-match-p x #p"")) - #'could-be-pathname-designator) + #'could-be-pathname-designator) nil) (deftest pathname-match-p.error.6 (check-type-error #'(lambda (x) (pathname-match-p #p"" x)) - #'could-be-pathname-designator) + #'could-be-pathname-designator) nil) (deftest pathname-match-p.error.7 (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pathname-match-p #p"" x)) - #'could-be-pathname-designator) + #'could-be-pathname-designator) nil) diff --git a/ansi-tests/pathname-name.lsp b/ansi-tests/pathname-name.lsp index df030d60..027ffbae 100644 --- a/ansi-tests/pathname-name.lsp +++ b/ansi-tests/pathname-name.lsp @@ -9,57 +9,57 @@ (deftest pathname-name.1 (loop for p in *pathnames* - for name = (pathname-name p) - unless (or (stringp name) - (member name '(nil :wild :unspecific))) - collect (list p name)) + for name = (pathname-name p) + unless (or (stringp name) + (member name '(nil :wild :unspecific))) + collect (list p name)) nil) (deftest pathname-name.2 (loop for p in *pathnames* - for name = (pathname-name p :case :local) - unless (or (stringp name) - (member name '(nil :wild :unspecific))) - collect (list p name)) + for name = (pathname-name p :case :local) + unless (or (stringp name) + (member name '(nil :wild :unspecific))) + collect (list p name)) nil) (deftest pathname-name.3 (loop for p in *pathnames* - for name = (pathname-name p :case :common) - unless (or (stringp name) - (member name '(nil :wild :unspecific))) - collect (list p name)) + for name = (pathname-name p :case :common) + unless (or (stringp name) + (member name '(nil :wild :unspecific))) + collect (list p name)) nil) (deftest pathname-name.4 (loop for p in *pathnames* - for name = (pathname-name p :allow-other-keys nil) - unless (or (stringp name) - (member name '(nil :wild :unspecific))) - collect (list p name)) + for name = (pathname-name p :allow-other-keys nil) + unless (or (stringp name) + (member name '(nil :wild :unspecific))) + collect (list p name)) nil) (deftest pathname-name.5 (loop for p in *pathnames* - for name = (pathname-name p :foo 'bar :allow-other-keys t) - unless (or (stringp name) - (member name '(nil :wild :unspecific))) - collect (list p name)) + for name = (pathname-name p :foo 'bar :allow-other-keys t) + unless (or (stringp name) + (member name '(nil :wild :unspecific))) + collect (list p name)) nil) (deftest pathname-name.6 (loop for p in *pathnames* - for name = (pathname-name p :allow-other-keys t :allow-other-keys nil :foo 'bar) - unless (or (stringp name) - (member name '(nil :wild :unspecific))) - collect (list p name)) + for name = (pathname-name p :allow-other-keys t :allow-other-keys nil :foo 'bar) + unless (or (stringp name) + (member name '(nil :wild :unspecific))) + collect (list p name)) nil) ;;; section 19.3.2.1 (deftest pathname-name.7 (loop for p in *logical-pathnames* - when (eq (pathname-name p) :unspecific) - collect p) + when (eq (pathname-name p) :unspecific) + collect p) nil) (deftest pathname-name.8 diff --git a/ansi-tests/pathname-type.lsp b/ansi-tests/pathname-type.lsp index 136977be..e8c5083b 100644 --- a/ansi-tests/pathname-type.lsp +++ b/ansi-tests/pathname-type.lsp @@ -9,57 +9,57 @@ (deftest pathname-type.1 (loop for p in *pathnames* - for type = (pathname-type p) - unless (or (stringp type) - (member type '(nil :wild :unspecific))) - collect (list p type)) + for type = (pathname-type p) + unless (or (stringp type) + (member type '(nil :wild :unspecific))) + collect (list p type)) nil) (deftest pathname-type.2 (loop for p in *pathnames* - for type = (pathname-type p :case :local) - unless (or (stringp type) - (member type '(nil :wild :unspecific))) - collect (list p type)) + for type = (pathname-type p :case :local) + unless (or (stringp type) + (member type '(nil :wild :unspecific))) + collect (list p type)) nil) (deftest pathname-type.3 (loop for p in *pathnames* - for type = (pathname-type p :case :common) - unless (or (stringp type) - (member type '(nil :wild :unspecific))) - collect (list p type)) + for type = (pathname-type p :case :common) + unless (or (stringp type) + (member type '(nil :wild :unspecific))) + collect (list p type)) nil) (deftest pathname-type.4 (loop for p in *pathnames* - for type = (pathname-type p :allow-other-keys nil) - unless (or (stringp type) - (member type '(nil :wild :unspecific))) - collect (list p type)) + for type = (pathname-type p :allow-other-keys nil) + unless (or (stringp type) + (member type '(nil :wild :unspecific))) + collect (list p type)) nil) (deftest pathname-type.5 (loop for p in *pathnames* - for type = (pathname-type p :foo 'bar :allow-other-keys t) - unless (or (stringp type) - (member type '(nil :wild :unspecific))) - collect (list p type)) + for type = (pathname-type p :foo 'bar :allow-other-keys t) + unless (or (stringp type) + (member type '(nil :wild :unspecific))) + collect (list p type)) nil) (deftest pathname-type.6 (loop for p in *pathnames* - for type = (pathname-type p :allow-other-keys t :allow-other-keys nil :foo 'bar) - unless (or (stringp type) - (member type '(nil :wild :unspecific))) - collect (list p type)) + for type = (pathname-type p :allow-other-keys t :allow-other-keys nil :foo 'bar) + unless (or (stringp type) + (member type '(nil :wild :unspecific))) + collect (list p type)) nil) ;;; section 19.3.2.1 (deftest pathname-type.7 (loop for p in *logical-pathnames* - when (eq (pathname-type p) :unspecific) - collect p) + when (eq (pathname-type p) :unspecific) + collect p) nil) (deftest pathname-type.8 diff --git a/ansi-tests/pathname-version.lsp b/ansi-tests/pathname-version.lsp index e97ac4a7..5cc77db5 100644 --- a/ansi-tests/pathname-version.lsp +++ b/ansi-tests/pathname-version.lsp @@ -9,16 +9,16 @@ (deftest pathname-version.1 (loop for p in *pathnames* - for version = (pathname-version p) - unless (or (integerp version) (symbolp version)) - collect (list p version)) + for version = (pathname-version p) + unless (or (integerp version) (symbolp version)) + collect (list p version)) nil) ;;; section 19.3.2.1 (deftest pathname-version.2 (loop for p in *logical-pathnames* - when (eq (pathname-version p) :unspecific) - collect p) + when (eq (pathname-version p) :unspecific) + collect p) nil) (deftest pathname-version.3 @@ -31,7 +31,7 @@ (deftest pathname-version.error.2 (signals-error (pathname-version *default-pathname-defaults* nil) - program-error) + program-error) t) (deftest pathname-version.error.3 diff --git a/ansi-tests/pathname.lsp b/ansi-tests/pathname.lsp index 08ac1280..51ecc014 100644 --- a/ansi-tests/pathname.lsp +++ b/ansi-tests/pathname.lsp @@ -7,7 +7,7 @@ (deftest pathname.1 (loop for x in *pathnames* - always (eq x (pathname x))) + always (eq x (pathname x))) t) (deftest pathname.2 @@ -28,53 +28,53 @@ (deftest pathname.5 (loop for x in *logical-pathnames* - always (eq x (pathname x))) + always (eq x (pathname x))) t) (deftest pathname.6 (equalt #p"ansi-aux.lsp" - (pathname (make-array 12 :initial-contents "ansi-aux.lsp" - :element-type 'base-char))) + (pathname (make-array 12 :initial-contents "ansi-aux.lsp" + :element-type 'base-char))) t) (deftest pathname.7 (equalt #p"ansi-aux.lsp" - (pathname (make-array 15 :initial-contents "ansi-aux.lspXXX" - :element-type 'base-char - :fill-pointer 12))) + (pathname (make-array 15 :initial-contents "ansi-aux.lspXXX" + :element-type 'base-char + :fill-pointer 12))) t) (deftest pathname.8 (equalt #p"ansi-aux.lsp" - (pathname (make-array 12 :initial-contents "ansi-aux.lsp" - :element-type 'base-char - :adjustable t))) + (pathname (make-array 12 :initial-contents "ansi-aux.lsp" + :element-type 'base-char + :adjustable t))) t) (deftest pathname.9 (equalt #p"ansi-aux.lsp" - (pathname (make-array 15 :initial-contents "ansi-aux.lspXXX" - :element-type 'character - :fill-pointer 12))) + (pathname (make-array 15 :initial-contents "ansi-aux.lspXXX" + :element-type 'character + :fill-pointer 12))) t) (deftest pathname.10 (equalt #p"ansi-aux.lsp" - (pathname (make-array 12 :initial-contents "ansi-aux.lsp" - :element-type 'character - :adjustable t))) + (pathname (make-array 12 :initial-contents "ansi-aux.lsp" + :element-type 'character + :adjustable t))) t) (deftest pathname.11 (loop for etype in '(standard-char base-char character) - collect - (equalt #p"ansi-aux.lsp" - (pathname - (let* ((s (make-array 15 :initial-contents "XXansi-aux.lspX" - :element-type etype))) - (make-array 12 :element-type etype - :displaced-to s - :displaced-index-offset 2))))) + collect + (equalt #p"ansi-aux.lsp" + (pathname + (let* ((s (make-array 15 :initial-contents "XXansi-aux.lspX" + :element-type etype))) + (make-array 12 :element-type etype + :displaced-to s + :displaced-index-offset 2))))) (t t t)) ;;; Error tests diff --git a/ansi-tests/pathnamep.lsp b/ansi-tests/pathnamep.lsp index e796847a..15d8a2fb 100644 --- a/ansi-tests/pathnamep.lsp +++ b/ansi-tests/pathnamep.lsp @@ -27,5 +27,5 @@ (deftest pathnamep.error.3 (signals-error (pathnamep *default-pathname-defaults* nil) - program-error) + program-error) t) diff --git a/ansi-tests/pathnames-aux.lsp b/ansi-tests/pathnames-aux.lsp index 659ea241..e17de671 100644 --- a/ansi-tests/pathnames-aux.lsp +++ b/ansi-tests/pathnames-aux.lsp @@ -10,9 +10,9 @@ (pathnamep x) (typep x 'file-stream) (and (typep x 'synonym-stream) - (could-be-pathname-designator - (symbol-value - (synonym-stream-symbol x)))))) + (could-be-pathname-designator + (symbol-value + (synonym-stream-symbol x)))))) (defun explode-pathname (pn) (list diff --git a/ansi-tests/pathnames.lsp b/ansi-tests/pathnames.lsp index d9164613..98c671a8 100644 --- a/ansi-tests/pathnames.lsp +++ b/ansi-tests/pathnames.lsp @@ -10,7 +10,7 @@ (loop for p1 in *pathnames* for s = (handler-case (write-to-string p1 :readably t) - (print-not-readable () :unreadable-error)) + (print-not-readable () :unreadable-error)) unless (eql s :unreadable-error) append (let ((p2 (read-from-string s))) diff --git a/ansi-tests/pattern-match.lsp b/ansi-tests/pattern-match.lsp index f2e711ae..6660716d 100644 --- a/ansi-tests/pattern-match.lsp +++ b/ansi-tests/pattern-match.lsp @@ -9,22 +9,22 @@ (cond ((consp pattern) (let ((pcar (car pattern)) - (pcdr (cdr pattern)) - (v (gensym))) + (pcdr (cdr pattern)) + (v (gensym))) (case pcar - ((:or) - `(let ((,v ,form)) (or ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) - pcdr)))) - ((:and) - `(let ((,v ,form)) (and ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) - pcdr)))) - ((:not) - (assert (eql (length pcdr) 1)) - `(not (pmatch ,(car pcdr) ,form))) - (t - `(let ((,v ,form)) - (and (pmatch ,pcar (car ,v)) - (pmatch ,pcdr (cdr ,v)))))))) + ((:or) + `(let ((,v ,form)) (or ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) + pcdr)))) + ((:and) + `(let ((,v ,form)) (and ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) + pcdr)))) + ((:not) + (assert (eql (length pcdr) 1)) + `(not (pmatch ,(car pcdr) ,form))) + (t + `(let ((,v ,form)) + (and (pmatch ,pcar (car ,v)) + (pmatch ,pcdr (cdr ,v)))))))) ((eql pattern '_) t) ((null pattern) `(null ,form)) @@ -35,34 +35,34 @@ (defmacro matchcase (form &body cases) (let* ((v (gensym)) - (cond-cases - (mapcar - #'(lambda (case) - (assert (consp case)) - (let ((pattern (car case)) - (body (cdr case))) - `((pmatch ,pattern ,v) ,@body))) - cases))) + (cond-cases + (mapcar + #'(lambda (case) + (assert (consp case)) + (let ((pattern (car case)) + (body (cdr case))) + `((pmatch ,pattern ,v) ,@body))) + cases))) `(let ((,v ,form)) (cond ,@cond-cases)))) (defmacro matchcase* (form &body cases) (let* ((block-name (gensym "DONE")) - (v (gensym))) + (v (gensym))) `(block ,block-name (let ((,v ,form)) - (cond - ,@(mapcar - #'(lambda (case) - (assert (consp case)) - (let ((pat (car case)) - (forms (cdr case)) - (fail-name (gensym "FAIL"))) - `((block ,fail-name - (and (pmatch ,pat ,v) - (macrolet ((fail () '(return-from ,fail-name nil))) - (return-from ,block-name - (progn ,@forms)))))))) - cases)))))) + (cond + ,@(mapcar + #'(lambda (case) + (assert (consp case)) + (let ((pat (car case)) + (forms (cdr case)) + (fail-name (gensym "FAIL"))) + `((block ,fail-name + (and (pmatch ,pat ,v) + (macrolet ((fail () '(return-from ,fail-name nil))) + (return-from ,block-name + (progn ,@forms)))))))) + cases)))))) + - diff --git a/ansi-tests/peek-char.lsp b/ansi-tests/peek-char.lsp index 36b02121..f6f5c757 100644 --- a/ansi-tests/peek-char.lsp +++ b/ansi-tests/peek-char.lsp @@ -31,11 +31,11 @@ (deftest peek-char.3 (with-input-from-string (*standard-input* (concatenate 'string - (string #\Newline) - (string #\Newline) - " " - (string #\Newline) - "ab")) + (string #\Newline) + (string #\Newline) + " " + (string #\Newline) + "ab")) (values (peek-char) (read-char) @@ -49,9 +49,9 @@ (deftest peek-char.4 (with-input-from-string (*standard-input* (concatenate 'string - (string (name-char "Linefeed")) - (string (name-char "Linefeed")) - "abc")) + (string (name-char "Linefeed")) + (string (name-char "Linefeed")) + "abc")) (values (peek-char) (read-char) @@ -65,9 +65,9 @@ (deftest peek-char.5 (with-input-from-string (*standard-input* (concatenate 'string - (string (name-char "Page")) - (string (name-char "Page")) - "abc")) + (string (name-char "Page")) + (string (name-char "Page")) + "abc")) (values (peek-char) (read-char) @@ -81,9 +81,9 @@ (deftest peek-char.6 (with-input-from-string (*standard-input* (concatenate 'string - (string (name-char "Tab")) - (string (name-char "Tab")) - "abc")) + (string (name-char "Tab")) + (string (name-char "Tab")) + "abc")) (values (peek-char) (read-char) @@ -97,9 +97,9 @@ (deftest peek-char.7 (with-input-from-string (*standard-input* (concatenate 'string - (string (name-char "Return")) - (string (name-char "Return")) - "abc")) + (string (name-char "Return")) + (string (name-char "Return")) + "abc")) (values (peek-char) (read-char) @@ -183,14 +183,14 @@ (with-output-to-string (os) (let ((es (make-echo-stream is os))) - (let ((pos1 (file-position os))) - (unless (zerop pos1) (return-from done :good)) - (peek-char nil es nil) - (let ((pos2 (file-position os))) - (return-from done - (if (eql pos1 pos2) - :good - (list pos1 pos2))))))))) + (let ((pos1 (file-position os))) + (unless (zerop pos1) (return-from done :good)) + (peek-char nil es nil) + (let ((pos2 (file-position os))) + (return-from done + (if (eql pos1 pos2) + :good + (list pos1 pos2))))))))) :good) (deftest peek-char.18 @@ -200,14 +200,14 @@ (with-output-to-string (os) (let ((es (make-echo-stream is os))) - (let ((pos1 (file-position os))) - (unless (zerop pos1) (return-from done :good)) - (peek-char t es nil) - (let ((pos2 (file-position os))) - (return-from done - (if (eql pos1 pos2) - pos1 - :good)))))))) + (let ((pos1 (file-position os))) + (unless (zerop pos1) (return-from done :good)) + (peek-char t es nil) + (let ((pos2 (file-position os))) + (return-from done + (if (eql pos1 pos2) + pos1 + :good)))))))) :good) (deftest peek-char.19 @@ -217,14 +217,14 @@ (with-output-to-string (os) (let ((es (make-echo-stream is os))) - (let ((pos1 (file-position os))) - (unless (zerop pos1) (return-from done :good)) - (peek-char #\c es nil) - (let ((pos2 (file-position os))) - (return-from done - (if (eql pos1 pos2) - pos1 - :good)))))))) + (let ((pos1 (file-position os))) + (unless (zerop pos1) (return-from done :good)) + (peek-char #\c es nil) + (let ((pos2 (file-position os))) + (return-from done + (if (eql pos1 pos2) + pos1 + :good)))))))) :good) ;;; Interactions with the readtable diff --git a/ansi-tests/phase.lsp b/ansi-tests/phase.lsp index 6ea2b996..b447f66e 100644 --- a/ansi-tests/phase.lsp +++ b/ansi-tests/phase.lsp @@ -55,9 +55,9 @@ (deftest phase.10 (let ((p1 (phase #c(0 1))) - (p2 (phase #c(0.0f0 1.0f0)))) + (p2 (phase #c(0.0f0 1.0f0)))) (and (eql p1 p2) - (approx= p1 (coerce (/ pi 2) 'single-float)))) + (approx= p1 (coerce (/ pi 2) 'single-float)))) t) (deftest phase.11 @@ -77,22 +77,22 @@ (deftest phase.14 (let ((p1 (phase #c(1 1))) - (p2 (phase #c(1.0f0 1.0f0)))) + (p2 (phase #c(1.0f0 1.0f0)))) (and (eql p1 p2) - (approx= p1 (coerce (/ pi 4) 'single-float) - (* 2 single-float-epsilon)))) + (approx= p1 (coerce (/ pi 4) 'single-float) + (* 2 single-float-epsilon)))) t) (deftest phase.15 (let ((p (phase #c(1.0d0 1.0d0)))) (approx= p (coerce (/ pi 4) 'double-float) - (* 2 double-float-epsilon))) + (* 2 double-float-epsilon))) t) (deftest phase.16 (let ((p (phase #c(1.0s0 1.0s0)))) (approx= p (coerce (/ pi 4) 'single-float) - (* 2 short-float-epsilon))) + (* 2 short-float-epsilon))) t) (deftest phase.17 diff --git a/ansi-tests/places.lsp b/ansi-tests/places.lsp index c9f5e14e..c5efd609 100644 --- a/ansi-tests/places.lsp +++ b/ansi-tests/places.lsp @@ -9,22 +9,22 @@ (deftest setf.order.1 (let ((x (vector nil nil nil nil)) - (i 0)) + (i 0)) (setf (aref x (incf i)) (incf i)) (values x i)) #(nil 2 nil nil) 2) (deftest setf.order.2 (let ((x (vector nil nil nil nil)) - (i 0)) + (i 0)) (setf (aref x (incf i)) (incf i) - (aref x (incf i)) (incf i 10)) + (aref x (incf i)) (incf i 10)) (values x i)) #(nil 2 nil 13) 13) (deftest incf.order.1 (let ((x (copy-seq #(0 0 0 0 0))) - (i 1)) + (i 1)) (values (incf (aref x (incf i)) (incf i)) x i)) @@ -32,13 +32,13 @@ (deftest decf.order.1 (let ((x (copy-seq #(0 0 0 0 0))) - (i 1)) + (i 1)) (values (decf (aref x (incf i)) (incf i)) x i)) -3 #(0 0 -3 0 0) 3) - + ;;; Section 5.1.2.1 (deftest setf-var (let ((x nil)) @@ -79,13 +79,13 @@ (deftest setf-values.5 (let ((a (vector nil nil)) - (i 0) - x y z) + (i 0) + x y z) (setf (values (aref a (progn (setf x (incf i)) 0)) - (aref a (progn (setf y (incf i)) 1))) - (progn - (setf z (incf i)) - (values 'foo 'bar))) + (aref a (progn (setf y (incf i)) 1))) + (progn + (setf z (incf i)) + (values 'foo 'bar))) (values a i x y z)) #(foo bar) 3 1 2 3) @@ -141,7 +141,7 @@ (deftest setf-expander.1 (let ((x (list 1))) (values (setf (accessor-5-1-2-6 x) 2) - (1+ (car x)))) + (1+ (car x)))) 2 3) ;;; Section 5.1.2.7 @@ -150,7 +150,7 @@ (deftest setf-macro.1 (let ((x (list 1))) (values (setf (accessor-5-1-2-7 x) 2) - (1+ (car x)))) + (1+ (car x)))) 2 3) (defun accessor-5-1-2-7a-update-fn (x y) @@ -164,11 +164,11 @@ ;; Test that the defsetf override the macro expansion (deftest setf-macro.2 (let ((x (list 1)) - (*x* nil)) + (*x* nil)) (declare (special *x*)) (values (setf (accessor-5-1-2-7a x) 2) - *x* - (1+ (car x)))) + *x* + (1+ (car x)))) 2 boo 3) (defmacro accessor-5-1-2-7b (x) `(accessor-5-1-2-7 ,x)) @@ -176,7 +176,7 @@ (deftest setf-macro.3 (let ((x (list 1))) (values (setf (accessor-5-1-2-7b x) 2) - (1+ (car x)))) + (1+ (car x)))) 2 3) ;; Macroexpansion from a macrolet @@ -184,7 +184,7 @@ (macrolet ((%m (y) `(car ,y))) (let ((x (list 1))) (values (setf (%m x) 2) - (1+ (car x))))) + (1+ (car x))))) 2 3) ;;; section 5.1.2.8 -- symbol macros @@ -247,10 +247,10 @@ ((%m (z) z)) (let ((x nil)) (values (setq x (expand-in-current-env (%m :good))) - x))) + x))) :good :good) -;;; Tests of SETF +;;; Tests of SETF (deftest setf.1 (setf) diff --git a/ansi-tests/plus.lsp b/ansi-tests/plus.lsp index 1319414d..869c76d1 100644 --- a/ansi-tests/plus.lsp +++ b/ansi-tests/plus.lsp @@ -14,105 +14,105 @@ (deftest plus.2 (loop for x in *numbers* - unless (eql x (+ x)) - collect x) + unless (eql x (+ x)) + collect x) nil) (deftest plus.3 (loop for x in *numbers* - for x1 = (+ x 0) - for x2 = (+ 0 x) - unless (and (eql x x1) (eql x x2) (eql x1 x2)) - collect (list x x1 x2)) + for x1 = (+ x 0) + for x2 = (+ 0 x) + unless (and (eql x x1) (eql x x2) (eql x1 x2)) + collect (list x x1 x2)) nil) (deftest plus.4 (loop for x in *numbers* - for x1 = (- x x) - unless (= x1 0) - collect (list x x1)) + for x1 = (- x x) + unless (= x1 0) + collect (list x x1)) nil) (deftest plus.5 (let* ((upper-bound most-positive-fixnum) - (lower-bound most-negative-fixnum) - (spread (- upper-bound lower-bound))) + (lower-bound most-negative-fixnum) + (spread (- upper-bound lower-bound))) (flet ((%r () (+ (random spread) lower-bound))) (loop for x = (%r) - for y = (%r) - for z = (%r) - for s1 = (+ x y z) - for s2 = (+ z y x) - for s3 = (+ y x z) - for s4 = (+ x z y) - for s5 = (+ z x y) - for s6 = (+ y z x) - repeat 1000 - unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) - (eql s1 s5) (eql s1 s6)) - collect (list x y z s1 s2 s3 s4 s5 s6)))) + for y = (%r) + for z = (%r) + for s1 = (+ x y z) + for s2 = (+ z y x) + for s3 = (+ y x z) + for s4 = (+ x z y) + for s5 = (+ z x y) + for s6 = (+ y z x) + repeat 1000 + unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) + (eql s1 s5) (eql s1 s6)) + collect (list x y z s1 s2 s3 s4 s5 s6)))) nil) (deftest plus.6 (let* ((upper-bound 1000000000000000) - (lower-bound -1000000000000000) - (spread (- upper-bound lower-bound))) + (lower-bound -1000000000000000) + (spread (- upper-bound lower-bound))) (flet ((%r () (+ (random spread) lower-bound))) (loop for x = (%r) - for y = (%r) - for z = (%r) - for s1 = (+ x y z) - for s2 = (+ z y x) - for s3 = (+ y x z) - for s4 = (+ x z y) - for s5 = (+ z x y) - for s6 = (+ y z x) - repeat 1000 - unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) - (eql s1 s5) (eql s1 s6)) - collect (list x y z s1 s2 s3 s4 s5 s6)))) + for y = (%r) + for z = (%r) + for s1 = (+ x y z) + for s2 = (+ z y x) + for s3 = (+ y x z) + for s4 = (+ x z y) + for s5 = (+ z x y) + for s6 = (+ y z x) + repeat 1000 + unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) + (eql s1 s5) (eql s1 s6)) + collect (list x y z s1 s2 s3 s4 s5 s6)))) nil) (deftest plus.7 (let* ((upper-bound most-positive-fixnum) - (lower-bound most-negative-fixnum) - (spread (- upper-bound lower-bound))) + (lower-bound most-negative-fixnum) + (spread (- upper-bound lower-bound))) (flet ((%r () (+ (random spread) lower-bound))) (loop for x = (/ (%r) (max 1 (%r))) - for y = (/ (%r) (max 1 (%r))) - for z = (/ (%r) (max 1 (%r))) - for s1 = (+ x y z) - for s2 = (+ z y x) - for s3 = (+ y x z) - for s4 = (+ x z y) - for s5 = (+ z x y) - for s6 = (+ y z x) - repeat 1000 - unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) - (eql s1 s5) (eql s1 s6)) - collect (list x y z s1 s2 s3 s4 s5 s6) - unless (= (+ x y) - (let ((xn (numerator x)) - (xd (denominator x)) - (yn (numerator y)) - (yd (denominator y))) - (/ (+ (* xn yd) (* xd yn)) - (* xd yd)))) - collect (list x y)))) + for y = (/ (%r) (max 1 (%r))) + for z = (/ (%r) (max 1 (%r))) + for s1 = (+ x y z) + for s2 = (+ z y x) + for s3 = (+ y x z) + for s4 = (+ x z y) + for s5 = (+ z x y) + for s6 = (+ y z x) + repeat 1000 + unless (and (eql s1 s2) (eql s1 s3) (eql s1 s4) + (eql s1 s5) (eql s1 s6)) + collect (list x y z s1 s2 s3 s4 s5 s6) + unless (= (+ x y) + (let ((xn (numerator x)) + (xd (denominator x)) + (yn (numerator y)) + (yd (denominator y))) + (/ (+ (* xn yd) (* xd yn)) + (* xd yd)))) + collect (list x y)))) nil) (deftest plus.8 (let (args) (loop for i from 0 to (min 256 (1- call-arguments-limit)) - unless (eql (apply #'+ args) (/ (* i (1+ i)) 2)) - collect i - do (push (1+ i) args))) + unless (eql (apply #'+ args) (/ (* i (1+ i)) 2)) + collect i + do (push (1+ i) args))) nil) (deftest plus.9 (let* ((upper-bound most-positive-fixnum) - (lower-bound most-negative-fixnum) - (spread (- upper-bound lower-bound))) + (lower-bound most-negative-fixnum) + (spread (- upper-bound lower-bound))) (flet ((%r () (+ (random spread) lower-bound))) (loop for xr = (%r) @@ -134,130 +134,130 @@ for (k eps-r eps-f) = (multiple-value-list (find-epsilon x)) nconc (loop for i from 1 to k - for e1 = (expt radix (- i)) - for y = (+ x e1) - nconc - (loop for j from 1 to (- k i) - for e2 = (expt radix (- j)) - for z = (+ x e2) - unless (eql (+ y z) (+ x e1 e2)) - collect (list x i j)))) + for e1 = (expt radix (- i)) + for y = (+ x e1) + nconc + (loop for j from 1 to (- k i) + for e2 = (expt radix (- j)) + for z = (+ x e2) + unless (eql (+ y z) (+ x e1 e2)) + collect (list x i j)))) nil) (deftest plus.11 (flet ((%r () (- (random most-positive-short-float) (/ most-positive-short-float 2)))) (loop for x = (%r) - for y = (%r) - for s = (+ x y) - repeat 1000 - unless (and (eql s (+ y x)) - (typep s 'short-float)) - collect (list x y s))) + for y = (%r) + for s = (+ x y) + repeat 1000 + unless (and (eql s (+ y x)) + (typep s 'short-float)) + collect (list x y s))) nil) (deftest plus.12 (flet ((%r () (- (random most-positive-single-float) (/ most-positive-single-float 2)))) (loop for x = (%r) - for y = (%r) - for s = (+ x y) - repeat 1000 - unless (and (eql s (+ y x)) - (typep s 'single-float)) - collect (list x y s))) + for y = (%r) + for s = (+ x y) + repeat 1000 + unless (and (eql s (+ y x)) + (typep s 'single-float)) + collect (list x y s))) nil) (deftest plus.13 (flet ((%r () (- (random most-positive-double-float) (/ most-positive-double-float 2)))) (loop for x = (%r) - for y = (%r) - for s = (+ x y) - repeat 1000 - unless (and (eql s (+ y x)) - (typep s 'double-float)) - collect (list x y s))) + for y = (%r) + for s = (+ x y) + repeat 1000 + unless (and (eql s (+ y x)) + (typep s 'double-float)) + collect (list x y s))) nil) (deftest plus.14 (flet ((%r () (- (random most-positive-long-float) (/ most-positive-long-float 2)))) (loop for x = (%r) - for y = (%r) - for s = (+ x y) - repeat 1000 - unless (and (eql s (+ y x)) - (typep s 'long-float)) - collect (list x y s))) + for y = (%r) + for s = (+ x y) + repeat 1000 + unless (and (eql s (+ y x)) + (typep s 'long-float)) + collect (list x y s))) nil) (deftest plus.15 (let ((bound most-positive-short-float) - (bound2 most-positive-single-float)) + (bound2 most-positive-single-float)) (loop for x = (- (random bound) (/ bound 2)) - for y = (- (random bound2)(/ bound2 2)) - for p = (+ x y) - repeat 1000 - unless (and (eql p (+ y x)) - (typep p 'single-float)) - collect (list x y p))) + for y = (- (random bound2)(/ bound2 2)) + for p = (+ x y) + repeat 1000 + unless (and (eql p (+ y x)) + (typep p 'single-float)) + collect (list x y p))) nil) (deftest plus.16 (let ((bound most-positive-short-float) - (bound2 most-positive-double-float)) + (bound2 most-positive-double-float)) (loop for x = (- (random bound) (/ bound 2)) - for y = (- (random bound2)(/ bound2 2)) - for p = (+ x y) - repeat 1000 - unless (and (eql p (+ y x)) - (typep p 'double-float)) - collect (list x y p))) + for y = (- (random bound2)(/ bound2 2)) + for p = (+ x y) + repeat 1000 + unless (and (eql p (+ y x)) + (typep p 'double-float)) + collect (list x y p))) nil) (deftest plus.17 (let ((bound most-positive-short-float) - (bound2 most-positive-long-float)) + (bound2 most-positive-long-float)) (loop for x = (- (random bound) (/ bound 2)) - for y = (- (random bound2)(/ bound2 2)) - for p = (+ x y) - repeat 1000 - unless (and (eql p (+ y x)) - (typep p 'long-float)) - collect (list x y p))) + for y = (- (random bound2)(/ bound2 2)) + for p = (+ x y) + repeat 1000 + unless (and (eql p (+ y x)) + (typep p 'long-float)) + collect (list x y p))) nil) (deftest plus.18 (let ((bound most-positive-single-float) - (bound2 most-positive-double-float)) + (bound2 most-positive-double-float)) (loop for x = (- (random bound) (/ bound 2)) - for y = (- (random bound2)(/ bound2 2)) - for p = (+ x y) - repeat 1000 - unless (and (eql p (+ y x)) - (typep p 'double-float)) - collect (list x y p))) + for y = (- (random bound2)(/ bound2 2)) + for p = (+ x y) + repeat 1000 + unless (and (eql p (+ y x)) + (typep p 'double-float)) + collect (list x y p))) nil) (deftest plus.19 (let ((bound most-positive-single-float) - (bound2 most-positive-long-float)) + (bound2 most-positive-long-float)) (loop for x = (- (random bound) (/ bound 2)) - for y = (- (random bound2)(/ bound2 2)) - for p = (+ x y) - repeat 1000 - unless (and (eql p (+ y x)) - (typep p 'long-float)) - collect (list x y p))) + for y = (- (random bound2)(/ bound2 2)) + for p = (+ x y) + repeat 1000 + unless (and (eql p (+ y x)) + (typep p 'long-float)) + collect (list x y p))) nil) (deftest plus.20 (let ((bound most-positive-double-float) - (bound2 most-positive-long-float)) + (bound2 most-positive-long-float)) (loop for x = (- (random bound) (/ bound 2)) - for y = (- (random bound2)(/ bound2 2)) - for p = (+ x y) - repeat 1000 - unless (and (eql p (+ y x)) - (typep p 'long-float)) - collect (list x y p))) + for y = (- (random bound2)(/ bound2 2)) + for p = (+ x y) + repeat 1000 + unless (and (eql p (+ y x)) + (typep p 'long-float)) + collect (list x y p))) nil) (deftest plus.21 @@ -267,14 +267,14 @@ for bound = (ash 1 (1- bits)) nconc (loop for i = (random bound) - for x = (coerce i type) - for j = (random bound) - for y = (coerce j type) - for sum = (+ x y) - repeat 1000 - unless (and (eql sum (coerce (+ i j) type)) - (eql sum (+ y x))) - collect (list i j x y sum (coerce (+ i j) type)))) + for x = (coerce i type) + for j = (random bound) + for y = (coerce j type) + for sum = (+ x y) + repeat 1000 + unless (and (eql sum (coerce (+ i j) type)) + (eql sum (+ y x))) + collect (list i j x y sum (coerce (+ i j) type)))) nil) (deftest plus.22 @@ -292,8 +292,8 @@ for sum = (+ x y) repeat 1000 unless (and (eql sum (complex (coerce (+ i j) type) - (coerce 2 type))) - (eql sum (+ y x))) + (coerce 2 type))) + (eql sum (+ y x))) collect (list i j x y sum))) nil) @@ -312,8 +312,8 @@ for sum = (+ x y) repeat 1000 unless (and (eql sum (complex (coerce 2 type) - (coerce (+ i j) type))) - (eql sum (+ y x))) + (coerce (+ i j) type))) + (eql sum (+ y x))) collect (list i j x y sum))) nil) @@ -322,28 +322,28 @@ (deftest plus.24 (funcall (compile nil '(lambda (x) (declare (type short-float x) (optimize (speed 3) (safety 0) (debug 0))) - (+ 0.0s0 x))) + (+ 0.0s0 x))) -0.0s0) 0.0s0) (deftest plus.25 (funcall (compile nil '(lambda (x) (declare (type single-float x) (optimize (speed 3) (safety 0) (debug 0))) - (+ 0.0f0 x))) + (+ 0.0f0 x))) -0.0f0) 0.0f0) (deftest plus.26 (funcall (compile nil '(lambda (x) (declare (type double-float x) (optimize (speed 3) (safety 0) (debug 0))) - (+ 0.0d0 x))) + (+ 0.0d0 x))) -0.0d0) 0.0d0) (deftest plus.27 (funcall (compile nil '(lambda (x) (declare (type long-float x) (optimize (speed 3) (safety 0) (debug 0))) - (+ 0.0l0 x))) + (+ 0.0l0 x))) -0.0l0) 0.0l0) @@ -352,11 +352,11 @@ (deftest plus.28 (macrolet ((%m (z) z)) - (values - (+ (expand-in-current-env (%m 1))) - (+ (expand-in-current-env (%m 2)) 3) - (+ 4 (expand-in-current-env (%m 5))) - (+ 1/2 (expand-in-current-env (%m 6)) 2/3))) + (values + (+ (expand-in-current-env (%m 1))) + (+ (expand-in-current-env (%m 2)) 3) + (+ 4 (expand-in-current-env (%m 5))) + (+ 1/2 (expand-in-current-env (%m 6)) 2/3))) 1 5 9 43/6) ;;; Must test combinations of reals and complex arguments. @@ -367,7 +367,7 @@ (let ((i 0) x y) (values (+ (progn (setf x (incf i)) '8) - (progn (setf y (incf i)) '11)) + (progn (setf y (incf i)) '11)) i x y)) 19 2 1 2) @@ -375,8 +375,8 @@ (let ((i 0) x y z) (values (+ (progn (setf x (incf i)) '8) - (progn (setf y (incf i)) '11) - (progn (setf z (incf i)) '100)) + (progn (setf y (incf i)) '11) + (progn (setf z (incf i)) '100)) i x y z)) 119 3 1 2 3) @@ -386,11 +386,11 @@ (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) + double-float-epsilon long-float-epsilon) for eps2 = (* eps 9/10) when (eql - (funcall (compile nil `(lambda () (+ ,x (+ ,eps2 ,eps2))))) - x) + (funcall (compile nil `(lambda () (+ ,x (+ ,eps2 ,eps2))))) + x) collect (list x eps eps2)) nil) @@ -398,12 +398,12 @@ (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) + double-float-epsilon long-float-epsilon) for eps2 = (* eps 9/10) unless (equal - (funcall (compile nil `(lambda () (list (+ (+ ,x ,eps2) ,eps2) - (+ ,eps2 (+ ,eps2 ,x)))))) - (list x x)) + (funcall (compile nil `(lambda () (list (+ (+ ,x ,eps2) ,eps2) + (+ ,eps2 (+ ,eps2 ,x)))))) + (list x x)) collect (list x eps eps2)) nil) @@ -411,11 +411,11 @@ (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) + double-float-epsilon long-float-epsilon) for eps2 = (* eps 9/10) when (eql - (funcall (compile nil `(lambda (y e) (+ y (+ e e)))) x eps2) - x) + (funcall (compile nil `(lambda (y e) (+ y (+ e e)))) x eps2) + x) collect (list x eps eps2)) nil) @@ -423,12 +423,12 @@ (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) for eps in (list short-float-epsilon single-float-epsilon - double-float-epsilon long-float-epsilon) + double-float-epsilon long-float-epsilon) for eps2 = (* eps 9/10) unless (equal - (funcall (compile nil `(lambda (y e) (list (+ (+ y e) e) - (+ e (+ e y))))) - x eps2) - (list x x)) + (funcall (compile nil `(lambda (y e) (list (+ (+ y e) e) + (+ e (+ e y))))) + x eps2) + (list x x)) collect (list x eps eps2)) nil) diff --git a/ansi-tests/plusp.lsp b/ansi-tests/plusp.lsp index 88c2166a..8d0e5a20 100644 --- a/ansi-tests/plusp.lsp +++ b/ansi-tests/plusp.lsp @@ -39,8 +39,8 @@ (deftest plusp.4 (loop for x in *reals* - when (if (plusp x) (<= x 0) (> x 0)) - collect x) + when (if (plusp x) (<= x 0) (> x 0)) + collect x) nil) (deftest plusp.5 @@ -53,17 +53,17 @@ (deftest plusp.7 (remove-if #'plusp - (list least-positive-short-float - least-positive-normalized-short-float - least-positive-single-float - least-positive-normalized-single-float - least-positive-double-float - least-positive-normalized-double-float - least-positive-long-float - least-positive-normalized-long-float - most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float)) + (list least-positive-short-float + least-positive-normalized-short-float + least-positive-single-float + least-positive-normalized-single-float + least-positive-double-float + least-positive-normalized-double-float + least-positive-long-float + least-positive-normalized-long-float + most-positive-short-float + most-positive-single-float + most-positive-double-float + most-positive-long-float)) nil) diff --git a/ansi-tests/pop.lsp b/ansi-tests/pop.lsp index 5f1cf71a..3d225b0d 100644 --- a/ansi-tests/pop.lsp +++ b/ansi-tests/pop.lsp @@ -34,14 +34,14 @@ ;;; Confirm argument is executed just once. (deftest pop.order.1 (let ((i 0) - (a (vector (list 'a 'b 'c)))) + (a (vector (list 'a 'b 'c)))) (pop (aref a (progn (incf i) 0))) (values a i)) #((b c)) 1) (deftest push-and-pop (let* ((x (copy-tree '(a b))) - (y x)) + (y x)) (push 'c x) (and (eqt (cdr x) y) diff --git a/ansi-tests/position-if-not.lsp b/ansi-tests/position-if-not.lsp index d39ea2c8..fea34fb7 100644 --- a/ansi-tests/position-if-not.lsp +++ b/ansi-tests/position-if-not.lsp @@ -27,7 +27,7 @@ (deftest position-if-not-list.6 (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start 4 - :from-end t) + :from-end t) 7) (deftest position-if-not-list.7 @@ -40,10 +40,10 @@ (deftest position-if-not-list.9 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -56,11 +56,11 @@ (deftest position-if-not-list.10 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j - :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j + :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -73,11 +73,11 @@ (deftest position-if-not-list.11 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j - :key '1+))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j + :key '1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -90,11 +90,11 @@ (deftest position-if-not-list.12 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j - :key #'1+ :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j + :key #'1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -129,7 +129,7 @@ (deftest position-if-not-vector.6 (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start 4 - :from-end t) + :from-end t) 7) (deftest position-if-not-vector.7 @@ -142,10 +142,10 @@ (deftest position-if-not-vector.9 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -158,11 +158,11 @@ (deftest position-if-not-vector.10 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j - :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j + :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -175,11 +175,11 @@ (deftest position-if-not-vector.11 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j - :key '1+))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j + :key '1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -192,11 +192,11 @@ (deftest position-if-not-vector.12 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j - :key #'1+ :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j + :key #'1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -209,7 +209,7 @@ (deftest position-if-not-vector.13 (let ((a (make-array '(10) :initial-contents '(1 2 3 4 5 a b c d e) - :fill-pointer 5))) + :fill-pointer 5))) (values (position-if-not #'numberp a) (position-if-not #'symbolp a) @@ -219,10 +219,10 @@ (deftest position-if-not-vector.14 (let* ((v1 #(x x x a b 1 d a b 2 d y y y y y)) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (position-if-not #'symbolp v2) - (position-if-not #'symbolp v2 :from-end t))) + (position-if-not #'symbolp v2 :from-end t))) 2 6) ;;; Bit vector tests @@ -249,7 +249,7 @@ (deftest position-if-not-bit-vector.6 (position-if-not #'oddp #*111010101 :start 4 - :from-end t) + :from-end t) 7) (deftest position-if-not-bit-vector.7 @@ -262,10 +262,10 @@ (deftest position-if-not-bit-vector.9 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'oddp #*111010101 :start i :end j))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp #*111010101 :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -278,11 +278,11 @@ (deftest position-if-not-bit-vector.10 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'oddp #*111010101 :start i :end j - :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'oddp #*111010101 :start i :end j + :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -295,11 +295,11 @@ (deftest position-if-not-bit-vector.11 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evenp #*111010101 :start i :end j - :key #'1+))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp #*111010101 :start i :end j + :key #'1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -312,11 +312,11 @@ (deftest position-if-not-bit-vector.12 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evenp #*111010101 :start i :end j - :key '1+ :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evenp #*111010101 :start i :end j + :key '1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -329,14 +329,14 @@ (deftest position-if-not-bit-vector.13 (let ((a (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) - :fill-pointer 5 - :element-type 'bit))) + :fill-pointer 5 + :element-type 'bit))) (values (position-if-not #'zerop a) (position-if-not (complement #'zerop) a) (position-if-not #'zerop a :from-end t) (position-if-not (complement #'zerop) a :from-end t))) - 0 nil 4 nil) + 0 nil 4 nil) ;;; string tests @@ -362,7 +362,7 @@ (deftest position-if-not-string.6 (position-if-not #'odddigitp "131432189" :start 4 - :from-end t) + :from-end t) 7) (deftest position-if-not-string.7 @@ -375,10 +375,10 @@ (deftest position-if-not-string.9 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'odddigitp "131432189" :start i :end j))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'odddigitp "131432189" :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -391,11 +391,11 @@ (deftest position-if-not-string.10 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'odddigitp "131432189" :start i :end j - :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'odddigitp "131432189" :start i :end j + :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -408,11 +408,11 @@ (deftest position-if-not-string.11 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evendigitp "131432183" :start i :end j - :key #'nextdigit))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evendigitp "131432183" :start i :end j + :key #'nextdigit))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -425,11 +425,11 @@ (deftest position-if-not-string.12 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if-not #'evendigitp "131432183" :start i :end j - :key 'nextdigit :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if-not #'evendigitp "131432183" :start i :end j + :key 'nextdigit :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -442,14 +442,14 @@ (deftest position-if-not-string.13 (let ((a (make-array '(10) :initial-contents "55555aaaaa" - :fill-pointer 5 - :element-type 'character))) + :fill-pointer 5 + :element-type 'character))) (and (stringp a) - (values - (position-if-not #'digit-char-p a) - (position-if-not (complement #'digit-char-p) a) - (position-if-not #'digit-char-p a :from-end t) - (position-if-not (complement #'digit-char-p) a :from-end t)))) + (values + (position-if-not #'digit-char-p a) + (position-if-not (complement #'digit-char-p) a) + (position-if-not #'digit-char-p a :from-end t) + (position-if-not (complement #'digit-char-p) a :from-end t)))) nil 0 nil 4) (deftest position-if-not-string.14 @@ -520,17 +520,17 @@ (deftest position-if-not.allow-other-keys.7 (position-if-not #'zerop '(0 0 1 2 3 0) :bad t :allow-other-keys t - :allow-other-keys nil) + :allow-other-keys nil) 2) (deftest position-if-not.allow-other-keys.8 (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t :bad t - :allow-other-keys nil) + :allow-other-keys nil) 2) (deftest position-if-not.allow-other-keys.9 (position-if-not #'zerop '(0 0 1 2 3 0) :allow-other-keys t - :allow-other-keys nil :bad t) + :allow-other-keys nil :bad t) 2) diff --git a/ansi-tests/position-if.lsp b/ansi-tests/position-if.lsp index 3e244fc7..98e9cd34 100644 --- a/ansi-tests/position-if.lsp +++ b/ansi-tests/position-if.lsp @@ -27,7 +27,7 @@ (deftest position-if-list.6 (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start 4 - :from-end t) + :from-end t) 7) (deftest position-if-list.7 @@ -40,10 +40,10 @@ (deftest position-if-list.9 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -56,11 +56,11 @@ (deftest position-if-list.10 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j - :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp '(1 3 1 4 3 2 1 8 9) :start i :end j + :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -73,11 +73,11 @@ (deftest position-if-list.11 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j - :key '1+))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j + :key '1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -90,11 +90,11 @@ (deftest position-if-list.12 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j - :key #'1+ :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp '(1 3 1 4 3 2 1 8 9) :start i :end j + :key #'1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -129,7 +129,7 @@ (deftest position-if-vector.6 (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start 4 - :from-end t) + :from-end t) 7) (deftest position-if-vector.7 @@ -142,10 +142,10 @@ (deftest position-if-vector.9 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -158,11 +158,11 @@ (deftest position-if-vector.10 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j - :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp #(1 3 1 4 3 2 1 8 9) :start i :end j + :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -175,11 +175,11 @@ (deftest position-if-vector.11 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j - :key '1+))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j + :key '1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -192,11 +192,11 @@ (deftest position-if-vector.12 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j - :key #'1+ :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp #(1 3 1 4 3 2 1 8 9) :start i :end j + :key #'1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -209,18 +209,18 @@ (deftest position-if-vector.13 (let ((a (make-array '(10) :initial-contents '(1 3 1 4 3 1 2 1 8 9) - :fill-pointer 5))) + :fill-pointer 5))) (flet ((%f (x) (eql x 1))) (values (position-if #'%f a) - (position-if #'%f a :from-end t)))) + (position-if #'%f a :from-end t)))) 0 2) (deftest position-if-vector.14 (let* ((v1 #(x x x a b 1 d a b 2 d y y y y y)) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (position-if #'integerp v2) - (position-if #'integerp v2 :from-end t))) + (position-if #'integerp v2 :from-end t))) 2 6) ;;; Bit vector tests @@ -247,7 +247,7 @@ (deftest position-if-bit-vector.6 (position-if #'evenp #*111010101 :start 4 - :from-end t) + :from-end t) 7) (deftest position-if-bit-vector.7 @@ -260,10 +260,10 @@ (deftest position-if-bit-vector.9 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evenp #*111010101 :start i :end j))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp #*111010101 :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -276,11 +276,11 @@ (deftest position-if-bit-vector.10 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evenp #*111010101 :start i :end j - :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evenp #*111010101 :start i :end j + :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -293,11 +293,11 @@ (deftest position-if-bit-vector.11 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'oddp #*111010101 :start i :end j - :key #'1+))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp #*111010101 :start i :end j + :key #'1+))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -310,11 +310,11 @@ (deftest position-if-bit-vector.12 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'oddp #*111010101 :start i :end j - :key '1+ :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'oddp #*111010101 :start i :end j + :key '1+ :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -327,12 +327,12 @@ (deftest position-if-bit-vector.13 (let ((a (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) - :fill-pointer 5 - :element-type 'bit))) + :fill-pointer 5 + :element-type 'bit))) (values (position-if #'evenp a) - (position-if #'evenp a :from-end 'foo) - (position-if #'oddp a) - (position-if #'oddp a :from-end 'foo))) + (position-if #'evenp a :from-end 'foo) + (position-if #'oddp a) + (position-if #'oddp a :from-end 'foo))) nil nil 0 4) ;;; string tests @@ -359,7 +359,7 @@ (deftest position-if-string.6 (position-if #'evendigitp "131432189" :start 4 - :from-end t) + :from-end t) 7) (deftest position-if-string.7 @@ -372,10 +372,10 @@ (deftest position-if-string.9 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evendigitp "131432189" :start i :end j))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evendigitp "131432189" :start i :end j))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -388,11 +388,11 @@ (deftest position-if-string.10 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'evendigitp "131432189" :start i :end j - :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'evendigitp "131432189" :start i :end j + :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -405,11 +405,11 @@ (deftest position-if-string.11 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'odddigitp "131432189" :start i :end j - :key #'nextdigit))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'odddigitp "131432189" :start i :end j + :key #'nextdigit))) ((nil nil nil 3 3 3 3 3 3) (nil nil 3 3 3 3 3 3) (nil 3 3 3 3 3 3) @@ -422,11 +422,11 @@ (deftest position-if-string.12 (loop for i from 0 to 8 - collect - (loop for j from (1+ i) to 9 - collect - (position-if #'odddigitp "131432189" :start i :end j - :key 'nextdigit :from-end t))) + collect + (loop for j from (1+ i) to 9 + collect + (position-if #'odddigitp "131432189" :start i :end j + :key 'nextdigit :from-end t))) ((nil nil nil 3 3 5 5 7 7) (nil nil 3 3 5 5 7 7) (nil 3 3 5 5 7 7) @@ -439,14 +439,14 @@ (deftest position-if-string.13 (flet ((%f (c) (eql c #\0)) - (%g (c) (eql c #\1))) + (%g (c) (eql c #\1))) (let ((a (make-array '(10) :initial-contents "1111100000" - :fill-pointer 5 - :element-type 'character))) + :fill-pointer 5 + :element-type 'character))) (values (position-if #'%f a) - (position-if #'%f a :from-end 'foo) - (position-if #'%g a) - (position-if #'%g a :from-end 'foo)))) + (position-if #'%f a :from-end 'foo) + (position-if #'%g a) + (position-if #'%g a :from-end 'foo)))) nil nil 0 4) (deftest position-if-string.14 @@ -518,17 +518,17 @@ (deftest position-if.allow-other-keys.7 (position-if #'zerop '(1 2 0 3 2 1) :bad t :allow-other-keys t - :allow-other-keys nil) + :allow-other-keys nil) 2) (deftest position-if.allow-other-keys.8 (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t :bad t - :allow-other-keys nil) + :allow-other-keys nil) 2) (deftest position-if.allow-other-keys.9 (position-if #'zerop '(1 2 0 3 2 1) :allow-other-keys t - :allow-other-keys nil :bad t) + :allow-other-keys nil :bad t) 2) diff --git a/ansi-tests/position.lsp b/ansi-tests/position.lsp index 6c61d903..615822f6 100644 --- a/ansi-tests/position.lsp +++ b/ansi-tests/position.lsp @@ -15,39 +15,39 @@ (deftest position-list.3 (loop for i from 0 to 7 collect - (position 'c '(a b c d e c a) :start i)) + (position 'c '(a b c d e c a) :start i)) (2 2 2 5 5 5 nil nil)) (deftest position-list.4 (loop for i from 0 to 7 collect - (position 'c '(a b c d e c a) :start i :end nil)) + (position 'c '(a b c d e c a) :start i :end nil)) (2 2 2 5 5 5 nil nil)) (deftest position-list.5 (loop for i from 7 downto 0 collect - (position 'c '(a b c d e c a) :end i)) + (position 'c '(a b c d e c a) :end i)) (2 2 2 2 2 nil nil nil)) (deftest position-list.6 (loop for i from 0 to 7 collect - (position 'c '(a b c d e c a) :start i :from-end t)) + (position 'c '(a b c d e c a) :start i :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-list.7 (loop for i from 0 to 7 collect - (position 'c '(a b c d e c a) :start i :end nil :from-end t)) + (position 'c '(a b c d e c a) :start i :end nil :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-list.8 (loop for i from 7 downto 0 collect - (position 'c '(a b c d e c a) :end i :from-end t)) + (position 'c '(a b c d e c a) :end i :from-end t)) (5 5 2 2 2 nil nil nil)) (deftest position-list.9 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position 'c '(a b c d e c a) :start i :end j))) + (loop for j from (1+ i) to 7 + collect + (position 'c '(a b c d e c a) :start i :end j))) ((nil nil 2 2 2 2 2) (nil 2 2 2 2 2) (2 2 2 2 2) @@ -58,9 +58,9 @@ (deftest position-list.10 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position 'c '(a b c d e c a) :start i :end j :from-end t))) + (loop for j from (1+ i) to 7 + collect + (position 'c '(a b c d e c a) :start i :end j :from-end t))) ((nil nil 2 2 2 5 5) (nil 2 2 2 5 5) (2 2 2 5 5) @@ -87,7 +87,7 @@ (deftest position-list.15 (position 'a '(a a b a c e d a f a) :test (complement #'eql) - :from-end t) + :from-end t) 8) (deftest position-list.16 @@ -96,7 +96,7 @@ (deftest position-list.17 (position 'a '(a a b a c e d a f a) :test-not 'eql - :from-end t) + :from-end t) 8) (deftest position-list.18 @@ -105,7 +105,7 @@ (deftest position-list.19 (position 'a '(a a b a c e d a f a) :test-not #'eql - :from-end t) + :from-end t) 8) (deftest position-list.20 @@ -114,22 +114,22 @@ (deftest position-list.21 (position 'a '(a a b a c e d a f a) :test #'eql - :start 2) + :start 2) 3) (deftest position-list.22 (position 'a '(a a b a c e d a f a) :test #'eql - :start 2 :end nil) + :start 2 :end nil) 3) (deftest position-list.23 (position 'a '(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5) + :start 0 :end 5) 2) (deftest position-list.24 (position 'a '(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5 :from-end t) + :start 0 :end 5 :from-end t) 4) (deftest position-list.25 @@ -142,12 +142,12 @@ (deftest position-list.27 (position 'a '((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car - :start 3) + :start 3) 4) (deftest position-list.28 (position 'a '((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car - :start 2 :from-end t) + :start 2 :from-end t) 4) (deftest position-list.29 @@ -170,39 +170,39 @@ (deftest position-vector.3 (loop for i from 0 to 7 collect - (position 'c #(a b c d e c a) :start i)) + (position 'c #(a b c d e c a) :start i)) (2 2 2 5 5 5 nil nil)) (deftest position-vector.4 (loop for i from 0 to 7 collect - (position 'c #(a b c d e c a) :start i :end nil)) + (position 'c #(a b c d e c a) :start i :end nil)) (2 2 2 5 5 5 nil nil)) (deftest position-vector.5 (loop for i from 7 downto 0 collect - (position 'c #(a b c d e c a) :end i)) + (position 'c #(a b c d e c a) :end i)) (2 2 2 2 2 nil nil nil)) (deftest position-vector.6 (loop for i from 0 to 7 collect - (position 'c #(a b c d e c a) :start i :from-end t)) + (position 'c #(a b c d e c a) :start i :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-vector.7 (loop for i from 0 to 7 collect - (position 'c #(a b c d e c a) :start i :end nil :from-end t)) + (position 'c #(a b c d e c a) :start i :end nil :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-vector.8 (loop for i from 7 downto 0 collect - (position 'c #(a b c d e c a) :end i :from-end t)) + (position 'c #(a b c d e c a) :end i :from-end t)) (5 5 2 2 2 nil nil nil)) (deftest position-vector.9 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position 'c #(a b c d e c a) :start i :end j))) + (loop for j from (1+ i) to 7 + collect + (position 'c #(a b c d e c a) :start i :end j))) ((nil nil 2 2 2 2 2) (nil 2 2 2 2 2) (2 2 2 2 2) @@ -213,9 +213,9 @@ (deftest position-vector.10 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position 'c #(a b c d e c a) :start i :end j :from-end t))) + (loop for j from (1+ i) to 7 + collect + (position 'c #(a b c d e c a) :start i :end j :from-end t))) ((nil nil 2 2 2 5 5) (nil 2 2 2 5 5) (2 2 2 5 5) @@ -242,7 +242,7 @@ (deftest position-vector.15 (position 'a #(a a b a c e d a f a) :test (complement #'eql) - :from-end t) + :from-end t) 8) (deftest position-vector.16 @@ -251,7 +251,7 @@ (deftest position-vector.17 (position 'a #(a a b a c e d a f a) :test-not 'eql - :from-end t) + :from-end t) 8) (deftest position-vector.18 @@ -260,7 +260,7 @@ (deftest position-vector.19 (position 'a #(a a b a c e d a f a) :test-not #'eql - :from-end t) + :from-end t) 8) (deftest position-vector.20 @@ -269,22 +269,22 @@ (deftest position-vector.21 (position 'a #(a a b a c e d a f a) :test #'eql - :start 2) + :start 2) 3) (deftest position-vector.22 (position 'a #(a a b a c e d a f a) :test #'eql - :start 2 :end nil) + :start 2 :end nil) 3) (deftest position-vector.23 (position 'a #(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5) + :start 0 :end 5) 2) (deftest position-vector.24 (position 'a #(a a b a c e d a f a) :test-not #'eql - :start 0 :end 5 :from-end t) + :start 0 :end 5 :from-end t) 4) (deftest position-vector.25 @@ -297,28 +297,28 @@ (deftest position-vector.27 (position 'a #((c) (b a) (a b c) (z) (a b) (d e) f) :key #'car - :start 3) + :start 3) 4) (deftest position-vector.28 (position 'a #((c) (b a) (a b c) (z) (a b) (d e) (f)) :key #'car - :start 2 :from-end t) + :start 2 :from-end t) 4) (deftest position-vector.29 (position 'a (make-array '(10) :initial-contents '(b b b b b a a a a a) - :fill-pointer 5)) + :fill-pointer 5)) nil) (deftest position-vector.30 (position 'a (make-array '(10) :initial-contents '(b b b b a a a a a a) - :fill-pointer 5)) + :fill-pointer 5)) 4) (deftest position-vector.31 (position 'a (make-array '(10) :initial-contents '(b a b b a a a a a a) - :fill-pointer 5) - :from-end t) + :fill-pointer 5) + :from-end t) 4) (deftest position-vector.32 @@ -331,11 +331,11 @@ (deftest position-vector.34 (let* ((v1 #(x x x a b c d a b c d y y y y y)) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (position 'c v2) - (position 'c v2 :from-end t))) - 2 6) + (position 'c v2 :from-end t))) + 2 6) ;;; tests on bit vectors @@ -349,39 +349,39 @@ (deftest position-bit-vector.3 (loop for i from 0 to 7 collect - (position 1 #*0010010 :start i)) + (position 1 #*0010010 :start i)) (2 2 2 5 5 5 nil nil)) (deftest position-bit-vector.4 (loop for i from 0 to 7 collect - (position 1 #*0010010 :start i :end nil)) + (position 1 #*0010010 :start i :end nil)) (2 2 2 5 5 5 nil nil)) (deftest position-bit-vector.5 (loop for i from 7 downto 0 collect - (position 1 #*0010010 :end i)) + (position 1 #*0010010 :end i)) (2 2 2 2 2 nil nil nil)) (deftest position-bit-vector.6 (loop for i from 0 to 7 collect - (position 1 #*0010010 :start i :from-end t)) + (position 1 #*0010010 :start i :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-bit-vector.7 (loop for i from 0 to 7 collect - (position 0 #*1101101 :start i :end nil :from-end t)) + (position 0 #*1101101 :start i :end nil :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-bit-vector.8 (loop for i from 7 downto 0 collect - (position 0 #*1101101 :end i :from-end t)) + (position 0 #*1101101 :end i :from-end t)) (5 5 2 2 2 nil nil nil)) (deftest position-bit-vector.9 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position 1 #*0010010 :start i :end j))) + (loop for j from (1+ i) to 7 + collect + (position 1 #*0010010 :start i :end j))) ((nil nil 2 2 2 2 2) (nil 2 2 2 2 2) (2 2 2 2 2) @@ -392,9 +392,9 @@ (deftest position-bit-vector.10 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position 1 #*0010010 :start i :end j :from-end t))) + (loop for j from (1+ i) to 7 + collect + (position 1 #*0010010 :start i :end j :from-end t))) ((nil nil 2 2 2 5 5) (nil 2 2 2 5 5) (2 2 2 5 5) @@ -421,7 +421,7 @@ (deftest position-bit-vector.15 (position 0 #*0010111010 :test (complement #'eql) - :from-end t) + :from-end t) 8) (deftest position-bit-vector.16 @@ -430,7 +430,7 @@ (deftest position-bit-vector.17 (position 0 #*001011101 :test-not 'eql - :from-end t) + :from-end t) 8) (deftest position-bit-vector.18 @@ -439,7 +439,7 @@ (deftest position-bit-vector.19 (position 0 #*00101110 :test-not #'eql - :from-end t) + :from-end t) 6) (deftest position-bit-vector.20 @@ -448,64 +448,64 @@ (deftest position-bit-vector.21 (position 0 #*00101110 :test #'eql - :start 2) + :start 2) 3) (deftest position-bit-vector.22 (position 0 #*00101110 :test #'eql - :start 2 :end nil) + :start 2 :end nil) 3) (deftest position-bit-vector.23 (position 0 #*00101110 :test-not #'eql - :start 0 :end 5) + :start 0 :end 5) 2) (deftest position-bit-vector.24 (position 0 #*00101110 :test-not #'eql - :start 0 :end 5 :from-end t) + :start 0 :end 5 :from-end t) 4) (deftest position-bit-vector.25 (position 2 #*1100001010 :key #'1+ - :start 3) + :start 3) 6) (deftest position-bit-vector.27 (position 2 #*1100001010 :key #'1+ - :start 2 :from-end t) + :start 2 :from-end t) 8) (deftest position-bit-vector.28 (position 0 (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5)) + :element-type 'bit + :fill-pointer 5)) nil) (deftest position-bit-vector.29 (position 0 (make-array '(10) :initial-contents '(1 1 1 1 1 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5) - :from-end t) + :element-type 'bit + :fill-pointer 5) + :from-end t) nil) (deftest position-bit-vector.30 (position 0 (make-array '(10) :initial-contents '(1 1 1 1 0 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5)) + :element-type 'bit + :fill-pointer 5)) 4) (deftest position-bit-vector.31 (position 0 (make-array '(10) :initial-contents '(0 1 0 1 0 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5) - :from-end t) + :element-type 'bit + :fill-pointer 5) + :from-end t) 4) (deftest position-bit-vector.32 (position 0 (make-array '(10) :initial-contents '(1 0 1 1 0 0 0 0 0 0) - :element-type 'bit - :fill-pointer 5)) + :element-type 'bit + :fill-pointer 5)) 1) (deftest position-bit-vector.33 @@ -528,39 +528,39 @@ (deftest position-string.3 (loop for i from 0 to 7 collect - (position #\c "abcdeca" :start i)) + (position #\c "abcdeca" :start i)) (2 2 2 5 5 5 nil nil)) (deftest position-string.4 (loop for i from 0 to 7 collect - (position #\c "abcdeca" :start i :end nil)) + (position #\c "abcdeca" :start i :end nil)) (2 2 2 5 5 5 nil nil)) (deftest position-string.5 (loop for i from 7 downto 0 collect - (position #\c "abcdeca" :end i)) + (position #\c "abcdeca" :end i)) (2 2 2 2 2 nil nil nil)) (deftest position-string.6 (loop for i from 0 to 7 collect - (position #\c "abcdeca" :start i :from-end t)) + (position #\c "abcdeca" :start i :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-string.7 (loop for i from 0 to 7 collect - (position #\c "abcdeca" :start i :end nil :from-end t)) + (position #\c "abcdeca" :start i :end nil :from-end t)) (5 5 5 5 5 5 nil nil)) (deftest position-string.8 (loop for i from 7 downto 0 collect - (position #\c "abcdeca" :end i :from-end t)) + (position #\c "abcdeca" :end i :from-end t)) (5 5 2 2 2 nil nil nil)) (deftest position-string.9 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position #\c "abcdeca" :start i :end j))) + (loop for j from (1+ i) to 7 + collect + (position #\c "abcdeca" :start i :end j))) ((nil nil 2 2 2 2 2) (nil 2 2 2 2 2) (2 2 2 2 2) @@ -571,9 +571,9 @@ (deftest position-string.10 (loop for i from 0 to 6 collect - (loop for j from (1+ i) to 7 - collect - (position #\c "abcdeca" :start i :end j :from-end t))) + (loop for j from (1+ i) to 7 + collect + (position #\c "abcdeca" :start i :end j :from-end t))) ((nil nil 2 2 2 5 5) (nil 2 2 2 5 5) (2 2 2 5 5) @@ -584,13 +584,13 @@ (deftest position-string.11 (position 5 "12345648" :key #'(lambda (c) - (1+ (read-from-string (string c))))) + (1+ (read-from-string (string c))))) 3) (deftest position-string.13 (position 5 "12345648" :key #'(lambda (c) - (1+ (read-from-string (string c)))) - :from-end t) + (1+ (read-from-string (string c)))) + :from-end t) 6) (deftest position-string.14 @@ -599,7 +599,7 @@ (deftest position-string.15 (position #\a "aabacedafa" :test (complement #'eql) - :from-end t) + :from-end t) 8) (deftest position-string.16 @@ -608,7 +608,7 @@ (deftest position-string.17 (position #\a "aabacedafa" :test-not 'eql - :from-end t) + :from-end t) 8) (deftest position-string.18 @@ -617,7 +617,7 @@ (deftest position-string.19 (position #\a "aabacedafa" :test-not #'eql - :from-end t) + :from-end t) 8) (deftest position-string.20 @@ -626,48 +626,48 @@ (deftest position-string.21 (position #\a "aabacedafa" :test #'eql - :start 2) + :start 2) 3) (deftest position-string.22 (position #\a "aabacedafa" :test #'eql - :start 2 :end nil) + :start 2 :end nil) 3) (deftest position-string.23 (position #\a "aabacedafa" :test-not #'eql - :start 0 :end 5) + :start 0 :end 5) 2) (deftest position-string.24 (position #\a "aabacedafa" :test-not #'eql - :start 0 :end 5 :from-end t) + :start 0 :end 5 :from-end t) 4) (deftest position-string.25 (position #\a (make-array '(10) :initial-contents "bbbbbaaaaa" - :element-type 'character - :fill-pointer 5)) + :element-type 'character + :fill-pointer 5)) nil) (deftest position-string.26 (position #\a (make-array '(10) :initial-contents "bbbbbaaaaa" - :element-type 'character - :fill-pointer 5) - :from-end t) + :element-type 'character + :fill-pointer 5) + :from-end t) nil) (deftest position-string.27 (position #\a (make-array '(10) :initial-contents "bbbbaaaaaa" - :element-type 'character - :fill-pointer 5)) + :element-type 'character + :fill-pointer 5)) 4) (deftest position-string.28 (position #\a (make-array '(10) :initial-contents "babbaaaaaa" - :element-type 'character - :fill-pointer 5) - :from-end t) + :element-type 'character + :fill-pointer 5) + :from-end t) 4) (deftest position-string.29 @@ -680,17 +680,17 @@ (deftest position-string.31 (let* ((s1 (copy-seq "xxxabcdyyyyy")) - (s2 (make-array '(4) :displaced-to s1 - :displaced-index-offset 3 - :element-type (array-element-type s1)))) + (s2 (make-array '(4) :displaced-to s1 + :displaced-index-offset 3 + :element-type (array-element-type s1)))) (position #\c s2)) 2) (deftest position-string.32 (let* ((s1 (copy-seq "xxxabcdabcdyyyyyyyy")) - (s2 (make-array '(8) :displaced-to s1 - :displaced-index-offset 3 - :element-type (array-element-type s1)))) + (s2 (make-array '(8) :displaced-to s1 + :displaced-index-offset 3 + :element-type (array-element-type s1)))) (position #\c s2 :from-end t)) 6) @@ -698,7 +698,7 @@ (do-special-strings (s "abcdabcdabcd" nil) (let* ((c #\c) - (pos (position c s))) + (pos (position c s))) (assert (eql pos 2) () "First position of ~A in ~A is ~A" c s pos))) nil) @@ -706,7 +706,7 @@ (do-special-strings (s "abcdabcdabcd" nil) (let* ((c #\c) - (pos (position c s :from-end t))) + (pos (position c s :from-end t))) (assert (eql pos 10) () "Last position of ~A in ~A is ~A" c s pos))) nil) @@ -792,17 +792,17 @@ (deftest position.allow-other-keys.7 (position 0 '(1 2 0 3 2 1) :bad t :allow-other-keys t - :allow-other-keys nil) + :allow-other-keys nil) 2) (deftest position.allow-other-keys.8 (position 0 '(1 2 0 3 2 1) :allow-other-keys t :bad t - :allow-other-keys nil) + :allow-other-keys nil) 2) (deftest position.allow-other-keys.9 (position 0 '(1 2 0 3 2 1) :allow-other-keys t - :allow-other-keys nil :bad t) + :allow-other-keys nil :bad t) 2) ;;; Error tests diff --git a/ansi-tests/pprint-dispatch.lsp b/ansi-tests/pprint-dispatch.lsp index 3bbde684..14762614 100644 --- a/ansi-tests/pprint-dispatch.lsp +++ b/ansi-tests/pprint-dispatch.lsp @@ -7,49 +7,49 @@ (deftest pprint-dispatch.1 (loop for x in (append *universe* *cl-symbols*) - for vals = (multiple-value-list (pprint-dispatch x)) - for vals2 = (multiple-value-list (pprint-dispatch - x - *print-pprint-dispatch*)) - unless - (and (= (length vals) 2) - (= (length vals2) 2) - (destructuring-bind (fun foundp) - vals - (if foundp - (and (or (typep fun 'function) - (and (symbolp fun) - (symbol-function fun))) - (destructuring-bind (fun2 foundp2) - vals2 - (and (equal fun fun2) - foundp2))) - (not (cadr vals2))))) - collect (list x vals vals2)) + for vals = (multiple-value-list (pprint-dispatch x)) + for vals2 = (multiple-value-list (pprint-dispatch + x + *print-pprint-dispatch*)) + unless + (and (= (length vals) 2) + (= (length vals2) 2) + (destructuring-bind (fun foundp) + vals + (if foundp + (and (or (typep fun 'function) + (and (symbolp fun) + (symbol-function fun))) + (destructuring-bind (fun2 foundp2) + vals2 + (and (equal fun fun2) + foundp2))) + (not (cadr vals2))))) + collect (list x vals vals2)) nil) #| (deftest pprint-dispatch.2 (loop for sym in *cl-symbols* - for x = (list sym nil nil) - for vals = (multiple-value-list (pprint-dispatch x)) - for vals2 = (multiple-value-list (pprint-dispatch - x - *print-pprint-dispatch*)) - unless - (and (= (length vals) 2) - (= (length vals2) 2) - (destructuring-bind (fun foundp) - vals - (if foundp - (and (or (typep fun 'function) - (and (symbolp fun) - (symbol-function fun))) - (destructuring-bind (fun2 foundp2) - vals2 - (and (equal fun fun2) - foundp2))) - (not (cadr vals2))))) - collect (list x vals vals2)) + for x = (list sym nil nil) + for vals = (multiple-value-list (pprint-dispatch x)) + for vals2 = (multiple-value-list (pprint-dispatch + x + *print-pprint-dispatch*)) + unless + (and (= (length vals) 2) + (= (length vals2) 2) + (destructuring-bind (fun foundp) + vals + (if foundp + (and (or (typep fun 'function) + (and (symbolp fun) + (symbol-function fun))) + (destructuring-bind (fun2 foundp2) + vals2 + (and (equal fun fun2) + foundp2))) + (not (cadr vals2))))) + collect (list x vals vals2)) nil) |# @@ -58,66 +58,66 @@ (deftest pprint-dispatch.3 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) + (*print-readably* nil) + (*print-escape* nil) + (*print-pretty* t)) (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream)))) + (declare (ignore obj)) + (write "ABC" :stream stream)))) (values - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) f) - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) nil) - (write-to-string '|X|))))) + (write-to-string '|X|) + (set-pprint-dispatch '(eql |X|) f) + (write-to-string '|X|) + (set-pprint-dispatch '(eql |X|) nil) + (write-to-string '|X|))))) "X" nil "ABC" nil "X") - + ;;; Test that setting the pprint dispatch of a symbol causes ;;; the printing to change for any real weight, and that it can be unset. (deftest pprint-dispatch.4 (my-with-standard-io-syntax (loop for v1 in (remove-if-not #'realp *universe*) - unless - (equal - (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) - (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream)))) - (list - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) f v1) - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) nil) - (write-to-string '|X|)))) - '("X" nil "ABC" nil "X")) - collect v1)) + unless + (equal + (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) + (*print-readably* nil) + (*print-escape* nil) + (*print-pretty* t)) + (let ((f #'(lambda (stream obj) + (declare (ignore obj)) + (write "ABC" :stream stream)))) + (list + (write-to-string '|X|) + (set-pprint-dispatch '(eql |X|) f v1) + (write-to-string '|X|) + (set-pprint-dispatch '(eql |X|) nil) + (write-to-string '|X|)))) + '("X" nil "ABC" nil "X")) + collect v1)) nil) - + ;;; Test that setting the pprint dispatch of a symbol causes ;;; the printing to change, and that it can be unset with any real weight (deftest pprint-dispatch.5 (my-with-standard-io-syntax (loop for v1 in (remove-if-not #'realp *universe*) - unless - (equal - (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) - (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream)))) - (list - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) f) - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) nil v1) - (write-to-string '|X|)))) - '("X" nil "ABC" nil "X")) - collect v1)) + unless + (equal + (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) + (*print-readably* nil) + (*print-escape* nil) + (*print-pretty* t)) + (let ((f #'(lambda (stream obj) + (declare (ignore obj)) + (write "ABC" :stream stream)))) + (list + (write-to-string '|X|) + (set-pprint-dispatch '(eql |X|) f) + (write-to-string '|X|) + (set-pprint-dispatch '(eql |X|) nil v1) + (write-to-string '|X|)))) + '("X" nil "ABC" nil "X")) + collect v1)) nil) ;;; Check that specifying the pprint-dispatch table argument to set-pprint-dispatch @@ -125,23 +125,23 @@ (deftest pprint-dispatch.6 (my-with-standard-io-syntax (let ((other-ppd-table (copy-pprint-dispatch nil)) - (*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) + (*print-pprint-dispatch* (copy-pprint-dispatch nil)) + (*print-readably* nil) + (*print-escape* nil) + (*print-pretty* t)) (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream)))) + (declare (ignore obj)) + (write "ABC" :stream stream)))) (values - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) f 0 other-ppd-table) - (write-to-string '|X|) - (let ((*print-pprint-dispatch* other-ppd-table)) - (write-to-string '|X|)) - (set-pprint-dispatch '(eql |X|) f) - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) nil) - (write-to-string '|X|))))) + (write-to-string '|X|) + (set-pprint-dispatch '(eql |X|) f 0 other-ppd-table) + (write-to-string '|X|) + (let ((*print-pprint-dispatch* other-ppd-table)) + (write-to-string '|X|)) + (set-pprint-dispatch '(eql |X|) f) + (write-to-string '|X|) + (set-pprint-dispatch '(eql |X|) nil) + (write-to-string '|X|))))) "X" nil "X" "ABC" nil "ABC" nil "X") ;;; Test that the default weight of set-pprint-dispatch is 0 @@ -149,43 +149,43 @@ (deftest pprint-dispatch.7 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) + (*print-readably* nil) + (*print-escape* nil) + (*print-pretty* t)) (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream))) - (g #'(lambda (stream obj) - (declare (ignore obj)) - (write "DEF" :stream stream)))) + (declare (ignore obj)) + (write "ABC" :stream stream))) + (g #'(lambda (stream obj) + (declare (ignore obj)) + (write "DEF" :stream stream)))) (values - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) f) - (write-to-string '|X|) - (set-pprint-dispatch '(member |X| |Y|) g .0001) - (write-to-string '|X|) - (write-to-string '|Y|))))) + (write-to-string '|X|) + (set-pprint-dispatch '(eql |X|) f) + (write-to-string '|X|) + (set-pprint-dispatch '(member |X| |Y|) g .0001) + (write-to-string '|X|) + (write-to-string '|Y|))))) "X" nil "ABC" nil "DEF" "DEF") (deftest pprint-dispatch.8 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) + (*print-readably* nil) + (*print-escape* nil) + (*print-pretty* t)) (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream))) - (g #'(lambda (stream obj) - (declare (ignore obj)) - (write "DEF" :stream stream)))) + (declare (ignore obj)) + (write "ABC" :stream stream))) + (g #'(lambda (stream obj) + (declare (ignore obj)) + (write "DEF" :stream stream)))) (values - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) f) - (write-to-string '|X|) - (set-pprint-dispatch '(member |X| |Y|) g -.0001) - (write-to-string '|X|) - (write-to-string '|Y|))))) + (write-to-string '|X|) + (set-pprint-dispatch '(eql |X|) f) + (write-to-string '|X|) + (set-pprint-dispatch '(member |X| |Y|) g -.0001) + (write-to-string '|X|) + (write-to-string '|Y|))))) "X" nil "ABC" nil "ABC" "DEF") ;;; Funtion designators in pprint-dispatch @@ -196,9 +196,9 @@ (deftest pprint-dispatch.9 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) + (*print-readably* nil) + (*print-escape* nil) + (*print-pretty* t)) (values (write-to-string '|X|) (multiple-value-list (set-pprint-dispatch '(eql |X|) 'pprint-dispatch-test-fn.1)) @@ -211,24 +211,24 @@ (deftest pprint-dispatch.10 (my-with-standard-io-syntax (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil)) - (*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t)) + (*print-readably* nil) + (*print-escape* nil) + (*print-pretty* t)) (let ((f #'(lambda (stream obj) - (declare (ignore obj)) - (write "ABC" :stream stream))) - (g #'(lambda (stream obj) - (declare (ignore obj)) - (write "DEF" :stream stream))) - (sym (gensym))) + (declare (ignore obj)) + (write "ABC" :stream stream))) + (g #'(lambda (stream obj) + (declare (ignore obj)) + (write "DEF" :stream stream))) + (sym (gensym))) (setf (symbol-function sym) f) (values - (write-to-string '|X|) - (set-pprint-dispatch '(eql |X|) sym) - (write-to-string '|X|) - (progn - (setf (symbol-function sym) g) - (write-to-string '|X|)))))) + (write-to-string '|X|) + (set-pprint-dispatch '(eql |X|) sym) + (write-to-string '|X|) + (progn + (setf (symbol-function sym) g) + (write-to-string '|X|)))))) "X" nil "ABC" "DEF") |# @@ -236,51 +236,51 @@ (deftest pprint-dispatch.error.1 (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) - (pprint-dispatch)) - program-error) + (pprint-dispatch)) + program-error) t) (deftest pprint-dispatch.error.2 (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) - (pprint-dispatch nil nil nil)) - program-error) + (pprint-dispatch nil nil nil)) + program-error) t) (deftest set-pprint-dispatch.error.1 (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) - (set-pprint-dispatch)) - program-error) + (set-pprint-dispatch)) + program-error) t) (deftest set-pprint-dispatch.error.2 (signals-error (let ((*print-pprint-dispatch* (copy-pprint-dispatch nil))) - (set-pprint-dispatch t)) - program-error) + (set-pprint-dispatch t)) + program-error) t) (deftest set-pprint-dispatch.error.3 (signals-error (let ((table (copy-pprint-dispatch nil))) - (set-pprint-dispatch t 'identity 0 table nil)) - program-error) + (set-pprint-dispatch t 'identity 0 table nil)) + program-error) t) (deftest set-pprint-dispatch.error.4 (loop for x in *mini-universe* - unless (or (typep x 'real) - (eval `(signals-error (let ((table (copy-pprint-dispatch nil))) - (set-pprint-dispatch t 'identity ',x)) - error))) - collect x) + unless (or (typep x 'real) + (eval `(signals-error (let ((table (copy-pprint-dispatch nil))) + (set-pprint-dispatch t 'identity ',x)) + error))) + collect x) nil) (deftest set-pprint-dispatch.error.4-unsafe (loop for x in *mini-universe* - unless (or (typep x 'real) - (eval `(signals-error (let ((table (copy-pprint-dispatch nil))) - (declare (optimize (safety 0))) - (set-pprint-dispatch t 'identity ',x)) - error))) - collect x) + unless (or (typep x 'real) + (eval `(signals-error (let ((table (copy-pprint-dispatch nil))) + (declare (optimize (safety 0))) + (set-pprint-dispatch t 'identity ',x)) + error))) + collect x) nil) diff --git a/ansi-tests/pprint-exit-if-list-exhausted.lsp b/ansi-tests/pprint-exit-if-list-exhausted.lsp index 5a54947c..3894a1e7 100644 --- a/ansi-tests/pprint-exit-if-list-exhausted.lsp +++ b/ansi-tests/pprint-exit-if-list-exhausted.lsp @@ -8,95 +8,95 @@ (deftest pprint-exit-if-list-exhausted.1 (with-standard-io-syntax (let ((*print-pretty* nil) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - ) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + ) (with-output-to-string (os) (pprint-logical-block - (os '(1 2)) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (write (pprint-pop) :stream os) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (write #\Space :stream os) - (write (pprint-pop) :stream os) - (pprint-exit-if-list-exhausted) - (assert nil))))) + (os '(1 2)) + (assert (equal (multiple-value-list + (pprint-exit-if-list-exhausted)) + '(nil))) + (write (pprint-pop) :stream os) + (assert (equal (multiple-value-list + (pprint-exit-if-list-exhausted)) + '(nil))) + (write #\Space :stream os) + (write (pprint-pop) :stream os) + (pprint-exit-if-list-exhausted) + (assert nil))))) "1 2") (deftest pprint-exit-if-list-exhausted.2 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - ) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + ) (with-output-to-string (os) (pprint-logical-block - (os '(1 2)) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (write (pprint-pop) :stream os) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (write #\Space :stream os) - (write (pprint-pop) :stream os) - (pprint-exit-if-list-exhausted) - (assert nil))))) + (os '(1 2)) + (assert (equal (multiple-value-list + (pprint-exit-if-list-exhausted)) + '(nil))) + (write (pprint-pop) :stream os) + (assert (equal (multiple-value-list + (pprint-exit-if-list-exhausted)) + '(nil))) + (write #\Space :stream os) + (write (pprint-pop) :stream os) + (pprint-exit-if-list-exhausted) + (assert nil))))) "1 2") (deftest pprint-exit-if-list-exhausted.3 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - ) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + ) (with-output-to-string (os) (pprint-logical-block - (os '(1 . 2)) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (write (pprint-pop) :stream os) - (write #\Space :stream os) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (pprint-pop) - (assert nil))))) + (os '(1 . 2)) + (assert (equal (multiple-value-list + (pprint-exit-if-list-exhausted)) + '(nil))) + (write (pprint-pop) :stream os) + (write #\Space :stream os) + (assert (equal (multiple-value-list + (pprint-exit-if-list-exhausted)) + '(nil))) + (pprint-pop) + (assert nil))))) "1 . 2") (deftest pprint-exit-if-list-exhausted.4 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - ) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + ) (with-output-to-string (os) (pprint-logical-block - (os '(1 . 2) :prefix "[" :suffix "]") - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (write (pprint-pop) :stream os) - (write #\Space :stream os) - (assert (equal (multiple-value-list - (pprint-exit-if-list-exhausted)) - '(nil))) - (pprint-pop) - (assert nil))))) + (os '(1 . 2) :prefix "[" :suffix "]") + (assert (equal (multiple-value-list + (pprint-exit-if-list-exhausted)) + '(nil))) + (write (pprint-pop) :stream os) + (write #\Space :stream os) + (assert (equal (multiple-value-list + (pprint-exit-if-list-exhausted)) + '(nil))) + (pprint-pop) + (assert nil))))) "[1 . 2]") ;;; Tests focusing on pprint-pop @@ -104,78 +104,78 @@ (deftest pprint-pop.1 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* 0)) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-length* 0)) (with-output-to-string (os) (pprint-logical-block - (os nil) - (pprint-pop) - (assert nil))))) + (os nil) + (pprint-pop) + (assert nil))))) "...") (deftest pprint-pop.2 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* 0)) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-length* 0)) (with-output-to-string (os) (pprint-logical-block - (os 1) - (pprint-pop))))) + (os 1) + (pprint-pop))))) "1") (deftest pprint-pop.3 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* 1)) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-length* 1)) (with-output-to-string (os) (pprint-logical-block - (os '(1)) - (assert (equal '(1) (multiple-value-list (pprint-pop)))))))) + (os '(1)) + (assert (equal '(1) (multiple-value-list (pprint-pop)))))))) "") (deftest pprint-pop.4 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* 0)) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-length* 0)) (with-output-to-string (os) (pprint-logical-block - (os '(1 2 3) :prefix "{" :suffix "}") - (pprint-pop) - (assert nil))))) + (os '(1 2 3) :prefix "{" :suffix "}") + (pprint-pop) + (assert nil))))) "{...}") (deftest pprint-pop.5 (flet ((%f (len) - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* len)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(1 2 3 4 5) :prefix "{" :suffix "}") - (pprint-exit-if-list-exhausted) - (write (pprint-pop) :stream os) - (loop (pprint-exit-if-list-exhausted) - (write #\Space :stream os) - (write (pprint-pop) :stream os)))))))) + (with-standard-io-syntax + (let ((*print-pretty* t) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-length* len)) + (with-output-to-string + (os) + (pprint-logical-block + (os '(1 2 3 4 5) :prefix "{" :suffix "}") + (pprint-exit-if-list-exhausted) + (write (pprint-pop) :stream os) + (loop (pprint-exit-if-list-exhausted) + (write #\Space :stream os) + (write (pprint-pop) :stream os)))))))) (values (%f 0) (%f 1) (%f 2) (%f 3) (%f 4) (%f 5) (%f 6))) "{...}" "{1 ...}" @@ -187,21 +187,21 @@ (deftest pprint-pop.6 (flet ((%f (len) - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* len)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(1 2 . 3) :prefix "{" :suffix "}") - (pprint-exit-if-list-exhausted) - (write (pprint-pop) :stream os) - (loop (pprint-exit-if-list-exhausted) - (write #\Space :stream os) - (write (pprint-pop) :stream os)))))))) + (with-standard-io-syntax + (let ((*print-pretty* t) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-length* len)) + (with-output-to-string + (os) + (pprint-logical-block + (os '(1 2 . 3) :prefix "{" :suffix "}") + (pprint-exit-if-list-exhausted) + (write (pprint-pop) :stream os) + (loop (pprint-exit-if-list-exhausted) + (write #\Space :stream os) + (write (pprint-pop) :stream os)))))))) (values (%f 0) (%f 1) (%f 2) (%f 3) (%f 4))) "{...}" "{1 ...}" @@ -213,24 +213,24 @@ (deftest pprint-pop.7 (flet ((%f (len) - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* len) - (*print-circle* t)) - (with-output-to-string - (os) - (let* ((tail (list 1)) - (x (list* tail 2 tail))) - (pprint-logical-block - (os x :prefix "<" :suffix ">") - (pprint-exit-if-list-exhausted) - (write (pprint-pop) :stream os) - (loop (pprint-exit-if-list-exhausted) - (write #\Space :stream os) - (write (pprint-pop) :stream os))))))))) + (with-standard-io-syntax + (let ((*print-pretty* t) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-length* len) + (*print-circle* t)) + (with-output-to-string + (os) + (let* ((tail (list 1)) + (x (list* tail 2 tail))) + (pprint-logical-block + (os x :prefix "<" :suffix ">") + (pprint-exit-if-list-exhausted) + (write (pprint-pop) :stream os) + (loop (pprint-exit-if-list-exhausted) + (write #\Space :stream os) + (write (pprint-pop) :stream os))))))))) (values (%f nil) (%f 0) (%f 1) (%f 2) (%f 3) (%f 4))) "<#1=(1) 2 . #1#>" "<...>" @@ -241,25 +241,25 @@ (deftest pprint-pop.8 (flet ((%f (len) - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* len) - (*print-circle* t)) - (with-output-to-string - (os) - (let* ((tail (list 2)) - (x (list* 1 tail))) - (setf (cdr tail) tail) - (pprint-logical-block - (os x :prefix "[[" :suffix "]]") - (pprint-exit-if-list-exhausted) - (write (pprint-pop) :stream os) - (loop (pprint-exit-if-list-exhausted) - (write #\Space :stream os) - (write (pprint-pop) :stream os))))))))) + (with-standard-io-syntax + (let ((*print-pretty* t) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-length* len) + (*print-circle* t)) + (with-output-to-string + (os) + (let* ((tail (list 2)) + (x (list* 1 tail))) + (setf (cdr tail) tail) + (pprint-logical-block + (os x :prefix "[[" :suffix "]]") + (pprint-exit-if-list-exhausted) + (write (pprint-pop) :stream os) + (loop (pprint-exit-if-list-exhausted) + (write #\Space :stream os) + (write (pprint-pop) :stream os))))))))) (values (%f 0) (%f 1) (%f 2) (%f 3) (%f 10) (%f 20))) "[[...]]" "[[1 ...]]" @@ -272,28 +272,28 @@ (deftest pprint-pop.9 (flet ((%f (len) - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-escape* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-length* len)) - (with-output-to-string - (os) - (pprint-logical-block - (os nil :prefix "{" :suffix "}") - (let ((vals (multiple-value-list (pprint-pop)))) - (assert (equal vals '(nil)) () "First call returned ~A" vals)) - (write 1 :stream os) - (write #\Space :stream os) - (let ((vals (multiple-value-list (pprint-pop)))) - (assert (equal vals '(nil)) () "Second call returned ~A" vals)) - (write 2 :stream os) - (write #\Space :stream os) - (let ((vals (multiple-value-list (pprint-pop)))) - (assert (equal vals '(nil)) () "Third call returned ~A" vals)) - (write 3 :stream os) - )))))) + (with-standard-io-syntax + (let ((*print-pretty* t) + (*print-escape* nil) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-length* len)) + (with-output-to-string + (os) + (pprint-logical-block + (os nil :prefix "{" :suffix "}") + (let ((vals (multiple-value-list (pprint-pop)))) + (assert (equal vals '(nil)) () "First call returned ~A" vals)) + (write 1 :stream os) + (write #\Space :stream os) + (let ((vals (multiple-value-list (pprint-pop)))) + (assert (equal vals '(nil)) () "Second call returned ~A" vals)) + (write 2 :stream os) + (write #\Space :stream os) + (let ((vals (multiple-value-list (pprint-pop)))) + (assert (equal vals '(nil)) () "Third call returned ~A" vals)) + (write 3 :stream os) + )))))) (values (%f nil) (%f 0) (%f 1) (%f 2) (%f 3) (%f 4))) "{1 2 3}" "{...}" @@ -310,9 +310,9 @@ (deftest pprint-exit-if-list-exhausted.error.1-unsafe (locally (declare (optimize (safety 0))) - (signals-error (locally (declare (optimize (safety 0))) - (pprint-exit-if-list-exhausted)) - error)) + (signals-error (locally (declare (optimize (safety 0))) + (pprint-exit-if-list-exhausted)) + error)) t) (deftest pprint-pop.error.1 @@ -322,5 +322,5 @@ (deftest pprint-pop.error.1-unsafe (locally (declare (optimize (safety 0))) - (signals-error (locally (declare (optimize (safety 0))) (pprint-pop)) error)) + (signals-error (locally (declare (optimize (safety 0))) (pprint-pop)) error)) t) diff --git a/ansi-tests/pprint-fill.lsp b/ansi-tests/pprint-fill.lsp index 26e480c2..3716a468 100644 --- a/ansi-tests/pprint-fill.lsp +++ b/ansi-tests/pprint-fill.lsp @@ -9,39 +9,39 @@ (deftest pprint-fill.1 (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil)) + (*print-readably* nil)) (loop for obj in *mini-universe* - nconc - (and (not (listp obj)) - (let ((s1 (write-to-string obj)) - (s2 (with-output-to-string (s) (pprint-fill s obj)))) - (unless (equal s1 s2) - (list (list obj s1 s2)))))))) + nconc + (and (not (listp obj)) + (let ((s1 (write-to-string obj)) + (s2 (with-output-to-string (s) (pprint-fill s obj)))) + (unless (equal s1 s2) + (list (list obj s1 s2)))))))) nil) (deftest pprint-fill.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) - (*print-readably* nil)) + (*print-readably* nil)) (loop for obj in *mini-universe* - nconc - (and (not (listp obj)) - (let ((s1 (write-to-string obj)) - (s2 (with-output-to-string (s) (pprint-fill s obj)))) - (unless (equal s1 s2) - (list (list obj s1 s2)))))))) + nconc + (and (not (listp obj)) + (let ((s1 (write-to-string obj)) + (s2 (with-output-to-string (s) (pprint-fill s obj)))) + (unless (equal s1 s2) + (list (list obj s1 s2)))))))) nil) (defmacro def-pprint-fill-test (name args expected-value &key (margin 100) (circle nil) (len nil)) `(deftest ,name (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* ,margin) - (*package* (find-package "CL-TEST")) - (*print-length* ,len) - (*print-circle* ,circle)) - (with-output-to-string (s) (pprint-fill s ,@args)))) + (*print-readably* nil) + (*print-right-margin* ,margin) + (*package* (find-package "CL-TEST")) + (*print-length* ,len) + (*print-circle* ,circle)) + (with-output-to-string (s) (pprint-fill s ,@args)))) ,expected-value)) (def-pprint-fill-test pprint-fill.3 ('(|A|)) "(A)") @@ -59,21 +59,21 @@ (deftest pprint-fill.10 (my-with-standard-io-syntax (let ((*print-pretty* nil) - (*print-readably* nil) - (*print-right-margin* 100)) + (*print-readably* nil) + (*print-right-margin* 100)) (with-output-to-string (os) (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (pprint-fill t '(1 2 3))))))) + (is "") + (with-open-stream (*terminal-io* (make-two-way-stream is os)) + (pprint-fill t '(1 2 3))))))) "(1 2 3)") (deftest pprint-fill.11 (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100)) + (*print-readably* nil) + (*print-right-margin* 100)) (with-output-to-string (*standard-output*) (pprint-fill nil '(1 2 3))))) "(1 2 3)") @@ -85,54 +85,54 @@ (deftest pprint-fill.12 (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*package* (find-package :cl-test)) - (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) + (*print-readably* nil) + (*package* (find-package :cl-test)) + (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) (loop for i from 1 to 10 - for result = - (let* ((*print-right-margin* i) - (s (with-output-to-string (os) - (terpri os) - (pprint-fill os obj)))) - (cond - ((not (eql (elt s 0) #\Newline)) - (list :bad1 s)) - ((not (equal (read-from-string s) obj)) - (list :bad2 s)) - ((not (find #\Newline s :start 1)) - (list :bad3 s)) - (t t))) - unless (eql result t) - collect (list i result)))) + for result = + (let* ((*print-right-margin* i) + (s (with-output-to-string (os) + (terpri os) + (pprint-fill os obj)))) + (cond + ((not (eql (elt s 0) #\Newline)) + (list :bad1 s)) + ((not (equal (read-from-string s) obj)) + (list :bad2 s)) + ((not (find #\Newline s :start 1)) + (list :bad3 s)) + (t t))) + unless (eql result t) + collect (list i result)))) nil) (deftest pprint-fill.13 (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*package* (find-package :cl-test)) - (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) + (*print-readably* nil) + (*package* (find-package :cl-test)) + (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) (loop for i from 1 to 10 - for result = - (let* ((*print-right-margin* i) - (s (with-output-to-string (os) - (terpri os) - (pprint-fill os obj nil)))) - (cond - ((not (eql (elt s 0) #\Newline)) - (list :bad1 s)) - ((not (equal (read-from-string (concatenate 'string "(" s ")")) - obj)) - (list :bad2 s)) - ((not (find #\Newline s :start 1)) - (list :bad3 s)) - (t t))) - unless (eql result t) - collect (list i result)))) + for result = + (let* ((*print-right-margin* i) + (s (with-output-to-string (os) + (terpri os) + (pprint-fill os obj nil)))) + (cond + ((not (eql (elt s 0) #\Newline)) + (list :bad1 s)) + ((not (equal (read-from-string (concatenate 'string "(" s ")")) + obj)) + (list :bad2 s)) + ((not (find #\Newline s :start 1)) + (list :bad3 s)) + (t t))) + unless (eql result t) + collect (list i result)))) nil) -;;; +;;; (def-pprint-fill-test pprint-fill.14 ((let ((x (list '|A|))) (list x x))) "(#1=(A) #1#)" :circle t) @@ -145,17 +145,17 @@ (deftest pprint-fill.return-values.1 (my-with-standard-io-syntax (let ((*print-pretty* nil) - (*package* (find-package "CL-TEST"))) + (*package* (find-package "CL-TEST"))) (with-open-stream (s (make-broadcast-stream)) - (pprint-fill s '(a b))))) + (pprint-fill s '(a b))))) nil) (deftest pprint-fill.return-values.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) - (*package* (find-package :cl-test))) + (*package* (find-package :cl-test))) (with-open-stream (s (make-broadcast-stream)) - (pprint-fill s 10 nil t)))) + (pprint-fill s 10 nil t)))) nil) ;;; Error tests diff --git a/ansi-tests/pprint-indent.lsp b/ansi-tests/pprint-indent.lsp index 1c00b55a..1f7e21da 100644 --- a/ansi-tests/pprint-indent.lsp +++ b/ansi-tests/pprint-indent.lsp @@ -9,55 +9,55 @@ (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (*standard-output* (make-string-output-stream)) - (pprint-indent :block 0)))) + (pprint-indent :block 0)))) nil) (deftest pprint-indent.2 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (*standard-output* (make-broadcast-stream)) - (pprint-indent :current 0)))) + (pprint-indent :current 0)))) nil) (deftest pprint-indent.3 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (s (make-string-output-stream)) - (pprint-indent :current 10 s)))) + (pprint-indent :current 10 s)))) nil) (deftest pprint-indent.4 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (s (make-string-output-stream)) - (pprint-indent :block 1/2 s)))) + (pprint-indent :block 1/2 s)))) nil) (deftest pprint-indent.5 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (s (make-string-output-stream)) - (pprint-indent :block 0.1 s)))) + (pprint-indent :block 0.1 s)))) nil) (deftest pprint-indent.6 (with-standard-io-syntax (let ((*print-pretty* nil)) (loop for x in '(1.0s0 1.0f0 1.0d0 1.0l0) - unless - (equal - (multiple-value-list - (with-open-stream (s (make-string-output-stream)) - (pprint-indent :block x s))) - '(nil)) - collect x))) + unless + (equal + (multiple-value-list + (with-open-stream (s (make-string-output-stream)) + (pprint-indent :block x s))) + '(nil)) + collect x))) nil) (deftest pprint-indent.7 (with-standard-io-syntax (let ((*print-pretty* nil)) (with-open-stream (*standard-output* (make-broadcast-stream)) - (pprint-indent :current 0 nil)))) + (pprint-indent :current 0 nil)))) nil) (deftest pprint-indent.8 @@ -68,7 +68,7 @@ (with-open-stream (is (make-string-input-stream "")) (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (pprint-indent :current 0 t)))))) + (pprint-indent :current 0 t)))))) nil) ;;; Now test with pprint-logical-block @@ -78,68 +78,68 @@ (deftest pprint-indent.9 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M|)) - (write '|M| :stream os) - (pprint-indent :current 3 os) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) + (os '(|M| |M|)) + (write '|M| :stream os) + (pprint-indent :current 3 os) + (pprint-newline :mandatory os) + (write '|M| :stream os))))) "M M") (deftest pprint-indent.10 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M|) :prefix "(" :suffix ")") - (write '|M| :stream os) - (pprint-indent :current 1 os) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) + (os '(|M| |M|) :prefix "(" :suffix ")") + (write '|M| :stream os) + (pprint-indent :current 1 os) + (pprint-newline :mandatory os) + (write '|M| :stream os))))) "(M M)") (deftest pprint-indent.11 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M|) :prefix "(" :suffix ")") - (write '|M| :stream os) - (pprint-indent :current -1 os) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) + (os '(|M| |M|) :prefix "(" :suffix ")") + (write '|M| :stream os) + (pprint-indent :current -1 os) + (pprint-newline :mandatory os) + (write '|M| :stream os))))) "(M M)") (deftest pprint-indent.12 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M|) :prefix "(" :suffix ")") - (write '|M| :stream os) - (pprint-indent :current -2.0 os) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) + (os '(|M| |M|) :prefix "(" :suffix ")") + (write '|M| :stream os) + (pprint-indent :current -2.0 os) + (pprint-newline :mandatory os) + (write '|M| :stream os))))) "(M M)") @@ -148,90 +148,90 @@ M)") (deftest pprint-indent.13 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M|)) - (write '|MMM| :stream os) - (pprint-indent :block 0 os) - (pprint-newline :mandatory os) - (write '|MMMMM| :stream os))))) + (os '(|M| |M|)) + (write '|MMM| :stream os) + (pprint-indent :block 0 os) + (pprint-newline :mandatory os) + (write '|MMMMM| :stream os))))) "MMM MMMMM") (deftest pprint-indent.13a (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M|) :prefix "(" :suffix ")") - (write '|MMM| :stream os) - (pprint-indent :block 0 os) - (pprint-newline :mandatory os) - (write '|MMMMM| :stream os))))) + (os '(|M| |M|) :prefix "(" :suffix ")") + (write '|MMM| :stream os) + (pprint-indent :block 0 os) + (pprint-newline :mandatory os) + (write '|MMMMM| :stream os))))) "(MMM MMMMM)") (deftest pprint-indent.14 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M|)) - (write '|MMM| :stream os) - (pprint-indent :block 1 os) - (pprint-newline :mandatory os) - (write '|MMMMM| :stream os))))) + (os '(|M| |M|)) + (write '|MMM| :stream os) + (pprint-indent :block 1 os) + (pprint-newline :mandatory os) + (write '|MMMMM| :stream os))))) "MMM MMMMM") (deftest pprint-indent.15 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M|)) - (write '|MMM| :stream os) - (pprint-indent :block -1 os) - (pprint-newline :mandatory os) - (write '|MMMMM| :stream os))))) + (os '(|M| |M|)) + (write '|MMM| :stream os) + (pprint-indent :block -1 os) + (pprint-newline :mandatory os) + (write '|MMMMM| :stream os))))) "MMM MMMMM") (deftest pprint-indent.16 (loop for n in '(3.0s0 3.0f0 3.0d0 3.0l0) - unless (string= - (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) - (with-output-to-string - (os) - (pprint-logical-block - (os '(|M| |M|)) - (write '|MMM| :stream os) - (pprint-indent :block n os) - (pprint-newline :mandatory os) - (write '|MMMMM| :stream os))))) - "MMM + unless (string= + (with-standard-io-syntax + (let ((*print-pretty* t) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) + (with-output-to-string + (os) + (pprint-logical-block + (os '(|M| |M|)) + (write '|MMM| :stream os) + (pprint-indent :block n os) + (pprint-newline :mandatory os) + (write '|MMMMM| :stream os))))) + "MMM MMMMM") - collect n) + collect n) nil) ;;; *print-pretty* must be true for pprint-indent to have an effect @@ -239,34 +239,34 @@ MMMMM") (deftest pprint-indent.17 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M|)) - (write '|M| :stream os) - (let ((*print-pretty* nil)) (pprint-indent :current 3 os)) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) + (os '(|M| |M|)) + (write '|M| :stream os) + (let ((*print-pretty* nil)) (pprint-indent :current 3 os)) + (pprint-newline :mandatory os) + (write '|M| :stream os))))) "M M") (deftest pprint-indent.18 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M|)) - (write '|M| :stream os) - (let ((*print-pretty* nil)) (pprint-indent :block 3 os)) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) + (os '(|M| |M|)) + (write '|M| :stream os) + (let ((*print-pretty* nil)) (pprint-indent :block 3 os)) + (pprint-newline :mandatory os) + (write '|M| :stream os))))) "M M") @@ -275,61 +275,61 @@ M") (deftest pprint-indent.19 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M| |M|) :per-line-prefix ">>>>") - (write '|M| :stream os) - (pprint-indent :block 2 os) - (write #\Space :stream os) - (write '|M| :stream os) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) + (os '(|M| |M| |M|) :per-line-prefix ">>>>") + (write '|M| :stream os) + (pprint-indent :block 2 os) + (write #\Space :stream os) + (write '|M| :stream os) + (pprint-newline :mandatory os) + (write '|M| :stream os))))) ">>>>M M >>>> M") (deftest pprint-indent.20 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M|) :per-line-prefix ">>>>") - (write '|M| :stream os) - (pprint-indent :block -1 os) - (pprint-newline :mandatory os) - (write '|M| :stream os))))) + (os '(|M| |M|) :per-line-prefix ">>>>") + (write '|M| :stream os) + (pprint-indent :block -1 os) + (pprint-newline :mandatory os) + (write '|M| :stream os))))) ">>>>M >>>>M") (deftest pprint-indent.21 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(|M| |M| |M| |M|) :per-line-prefix ">>>>") - (write '|M| :stream os) - (pprint-indent :block 3 os) - (pprint-newline :mandatory os) - (write '|M| :stream os) - (pprint-indent :current -2 os) - (pprint-newline :mandatory os) - (write '|M| :stream os) - (pprint-indent :current -5 os) - (pprint-newline :mandatory os) - (write '|M| :stream os) - )))) - + (os '(|M| |M| |M| |M|) :per-line-prefix ">>>>") + (write '|M| :stream os) + (pprint-indent :block 3 os) + (pprint-newline :mandatory os) + (write '|M| :stream os) + (pprint-indent :current -2 os) + (pprint-newline :mandatory os) + (write '|M| :stream os) + (pprint-indent :current -5 os) + (pprint-newline :mandatory os) + (write '|M| :stream os) + )))) + ">>>>M >>>> M >>>> M @@ -340,21 +340,21 @@ M") (deftest pprint-indent.22 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-miser-width* 200) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-miser-width* 200) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(1 2 3) :prefix "(" :suffix ")") - (write 1 :stream os) - (pprint-indent :current 1 os) - (pprint-newline :mandatory os) - (write 2 :stream os) - (pprint-indent :block 3 os) - (pprint-newline :mandatory os) - (write 3 :stream os))))) + (os '(1 2 3) :prefix "(" :suffix ")") + (write 1 :stream os) + (pprint-indent :current 1 os) + (pprint-newline :mandatory os) + (write 2 :stream os) + (pprint-indent :block 3 os) + (pprint-newline :mandatory os) + (write 3 :stream os))))) "(1 2 3)") @@ -364,21 +364,21 @@ M") (deftest pprint-indent.23 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100) - (*print-escape* nil)) + (*print-readably* nil) + (*print-right-margin* 100) + (*print-escape* nil)) (with-output-to-string (os) (pprint-logical-block - (os '(1 2 3 4)) - (pprint-indent :block 2 os) - (write 1 :stream os) - (terpri os) - (write 2 :stream os) - (write #\Newline :stream os) - (write 3 :stream os) - (pprint-newline :mandatory os) - (write 4 :stream os))))) + (os '(1 2 3 4)) + (pprint-indent :block 2 os) + (write 1 :stream os) + (terpri os) + (write 2 :stream os) + (write #\Newline :stream os) + (write 3 :stream os) + (pprint-newline :mandatory os) + (write 4 :stream os))))) "1 2 3 @@ -400,16 +400,16 @@ M") (deftest pprint-indent.error.4 (loop for x in *mini-universe* - when (and (not (member x '(:block :current))) - (not (eval `(signals-error (pprint-indent ',x 0) error)))) - collect x) + when (and (not (member x '(:block :current))) + (not (eval `(signals-error (pprint-indent ',x 0) error)))) + collect x) nil) (deftest pprint-indent.error.4-unsafe (loop for x in *mini-universe* - when (and (not (member x '(:block :current))) - (not (eval `(signals-error (locally (declare (optimize (safety 0))) (pprint-indent ',x 0)) - error)))) - collect x) + when (and (not (member x '(:block :current))) + (not (eval `(signals-error (locally (declare (optimize (safety 0))) (pprint-indent ',x 0)) + error)))) + collect x) nil) diff --git a/ansi-tests/pprint-linear.lsp b/ansi-tests/pprint-linear.lsp index d10fc777..ab4c1358 100644 --- a/ansi-tests/pprint-linear.lsp +++ b/ansi-tests/pprint-linear.lsp @@ -9,44 +9,44 @@ (deftest pprint-linear.1 (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil)) + (*print-readably* nil)) (loop for obj in *mini-universe* - nconc - (and (not (listp obj)) - (let ((s1 (write-to-string obj)) - (s2 (with-output-to-string (s) (assert (equal (multiple-value-list - (pprint-linear s obj)) - '(nil)))))) - (unless (equal s1 s2) - (list (list obj s1 s2)))))))) + nconc + (and (not (listp obj)) + (let ((s1 (write-to-string obj)) + (s2 (with-output-to-string (s) (assert (equal (multiple-value-list + (pprint-linear s obj)) + '(nil)))))) + (unless (equal s1 s2) + (list (list obj s1 s2)))))))) nil) (deftest pprint-linear.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) - (*print-readably* nil)) + (*print-readably* nil)) (loop for obj in *mini-universe* - nconc - (and (not (listp obj)) - (let ((s1 (write-to-string obj)) - (s2 (with-output-to-string (s) (assert (equal (multiple-value-list - (pprint-linear s obj)) - '(nil)))))) - (unless (equal s1 s2) - (list (list obj s1 s2)))))))) + nconc + (and (not (listp obj)) + (let ((s1 (write-to-string obj)) + (s2 (with-output-to-string (s) (assert (equal (multiple-value-list + (pprint-linear s obj)) + '(nil)))))) + (unless (equal s1 s2) + (list (list obj s1 s2)))))))) nil) (defmacro def-pprint-linear-test (name args expected-value &key (margin 100) (circle nil)) `(deftest ,name (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* ,margin) - (*package* (find-package "CL-TEST")) - (*print-circle* ,circle)) - (with-output-to-string - (s) - (pprint-linear s ,@args)))) + (*print-readably* nil) + (*print-right-margin* ,margin) + (*package* (find-package "CL-TEST")) + (*print-circle* ,circle)) + (with-output-to-string + (s) + (pprint-linear s ,@args)))) ,expected-value)) (def-pprint-linear-test pprint-linear.3 ('(|A|)) "(A)") @@ -64,74 +64,74 @@ (deftest pprint-linear.10 (my-with-standard-io-syntax (let ((*print-pretty* nil) - (*print-readably* nil) - (*print-right-margin* 100)) + (*print-readably* nil) + (*print-right-margin* 100)) (with-output-to-string (os) (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (pprint-linear t '(1 2 3))))))) + (is "") + (with-open-stream (*terminal-io* (make-two-way-stream is os)) + (pprint-linear t '(1 2 3))))))) "(1 2 3)") (deftest pprint-linear.11 (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100)) + (*print-readably* nil) + (*print-right-margin* 100)) (with-output-to-string (*standard-output*) (pprint-linear nil '(1 2 3))))) "(1 2 3)") (deftest pprint-linear.12 (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*package* (find-package :cl-test)) - (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) + (*print-readably* nil) + (*package* (find-package :cl-test)) + (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) (loop for i from 1 to 10 - for result = - (let* ((*print-right-margin* i) - (s (with-output-to-string (os) - (terpri os) - (pprint-linear os obj)))) - (cond - ((not (eql (elt s 0) #\Newline)) - (list :bad1 s)) - ((not (equal (read-from-string s) obj)) - (list :bad2 s)) - ((< (count #\Newline s) (length obj)) - (list :bad3 s)) - (t t))) - unless (eql result t) - collect (list i result)))) + for result = + (let* ((*print-right-margin* i) + (s (with-output-to-string (os) + (terpri os) + (pprint-linear os obj)))) + (cond + ((not (eql (elt s 0) #\Newline)) + (list :bad1 s)) + ((not (equal (read-from-string s) obj)) + (list :bad2 s)) + ((< (count #\Newline s) (length obj)) + (list :bad3 s)) + (t t))) + unless (eql result t) + collect (list i result)))) nil) (deftest pprint-linear.13 (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*package* (find-package :cl-test)) - (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) + (*print-readably* nil) + (*package* (find-package :cl-test)) + (obj '(|M| |M| |M| |M| |M| |M| |M| |M| |M| |M| |M|))) (loop for i from 1 to 10 - for result = - (let* ((*print-right-margin* i) - (s (with-output-to-string (os) - (terpri os) - (pprint-linear os obj nil)))) - (cond - ((not (eql (elt s 0) #\Newline)) - (list :bad1 s)) - ((not (equal (read-from-string (concatenate 'string "(" s ")")) - obj)) - (list :bad2 s)) - ((< (count #\Newline s) (length obj)) - (list :bad3 s)) - (t t))) - unless (eql result t) - collect (list i result)))) + for result = + (let* ((*print-right-margin* i) + (s (with-output-to-string (os) + (terpri os) + (pprint-linear os obj nil)))) + (cond + ((not (eql (elt s 0) #\Newline)) + (list :bad1 s)) + ((not (equal (read-from-string (concatenate 'string "(" s ")")) + obj)) + (list :bad2 s)) + ((< (count #\Newline s) (length obj)) + (list :bad3 s)) + (t t))) + unless (eql result t) + collect (list i result)))) nil) -;;; +;;; (def-pprint-linear-test pprint-linear.14 ((let ((x (list '|A|))) (list x x))) "(#1=(A) #1#)" :circle t) diff --git a/ansi-tests/pprint-logical-block.lsp b/ansi-tests/pprint-logical-block.lsp index c049afc1..4b4963c1 100644 --- a/ansi-tests/pprint-logical-block.lsp +++ b/ansi-tests/pprint-logical-block.lsp @@ -8,8 +8,8 @@ (deftest pprint-logical-block.1 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil)) + (*print-right-margin* 100) + (*print-readably* nil)) (with-open-stream (os (make-string-output-stream)) (values @@ -20,18 +20,18 @@ (deftest pprint-logical-block.2 (with-standard-io-syntax (let ((*print-pretty* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(1 a (b) (c . d) 1.0s0 2.0f0 -3.0d0 4.0l0 1/2 #(x y z)))) + (*print-right-margin* 100) + (*print-readably* nil) + (val '(1 a (b) (c . d) 1.0s0 2.0f0 -3.0d0 4.0l0 1/2 #(x y z)))) (string=t (with-output-to-string (s) (write val :stream s)) - (with-output-to-string (s) (pprint-logical-block (s val) (write val :stream s)))))) + (with-output-to-string (s) (pprint-logical-block (s val) (write val :stream s)))))) t) (deftest pprint-logical-block.3 (with-standard-io-syntax (let ((*print-pretty* nil) - (*print-right-margin* 100) - (*print-readably* nil)) + (*print-right-margin* 100) + (*print-readably* nil)) (with-output-to-string (*standard-output*) (pprint-logical-block (nil 1))))) @@ -40,136 +40,136 @@ (deftest pprint-logical-block.4 (with-standard-io-syntax (let ((*print-pretty* nil) - (*print-right-margin* 100) - (*print-readably* nil)) + (*print-right-margin* 100) + (*print-readably* nil)) (with-output-to-string (os) (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (pprint-logical-block (t 1))))))) + (is "") + (with-open-stream (*terminal-io* (make-two-way-stream is os)) + (pprint-logical-block (t 1))))))) "1") (deftest pprint-logical-block.5 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(1))) + (*print-right-margin* 100) + (*print-readably* nil) + (val '(1))) (with-output-to-string (os) (pprint-logical-block - (os val) - (write (car val) :stream os))))) + (os val) + (write (car val) :stream os))))) "1") (deftest pprint-logical-block.6 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(2))) + (*print-right-margin* 100) + (*print-readably* nil) + (val '(2))) (with-output-to-string (os) (pprint-logical-block - (os val :prefix "[" :suffix "]") - (write (car val) :stream os))))) + (os val :prefix "[" :suffix "]") + (write (car val) :stream os))))) "[2]") (deftest pprint-logical-block.7 :notes (:nil-vectors-are-strings) (with-standard-io-syntax (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(3))) + (*print-right-margin* 100) + (*print-readably* nil) + (val '(3))) (with-output-to-string (os) (pprint-logical-block - (os val - :prefix (make-array '(0) :element-type nil) - :suffix (make-array '(0) :element-type nil)) - (write (car val) :stream os))))) + (os val + :prefix (make-array '(0) :element-type nil) + :suffix (make-array '(0) :element-type nil)) + (write (car val) :stream os))))) "3") (deftest pprint-logical-block.8 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(4))) + (*print-right-margin* 100) + (*print-readably* nil) + (val '(4))) (with-output-to-string (os) (pprint-logical-block - (os val - :prefix (make-array '(10) :element-type 'character - :initial-contents "abcdefghij" - :fill-pointer 3) - :suffix (make-array '(2) :element-type 'base-char - :initial-contents "!?" - :adjustable t)) - (write (car val) :stream os))))) + (os val + :prefix (make-array '(10) :element-type 'character + :initial-contents "abcdefghij" + :fill-pointer 3) + :suffix (make-array '(2) :element-type 'base-char + :initial-contents "!?" + :adjustable t)) + (write (car val) :stream os))))) "abc4!?") (deftest pprint-logical-block.9 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-level* 1) - (val '((4)))) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-level* 1) + (val '((4)))) (with-output-to-string (os) (pprint-logical-block - (os val :prefix "{" :suffix "}") - (pprint-logical-block - (os (car val) :prefix "[" :suffix "]") - (write (caar val) :stream os)))))) + (os val :prefix "{" :suffix "}") + (pprint-logical-block + (os (car val) :prefix "[" :suffix "]") + (write (caar val) :stream os)))))) "{#}") (deftest pprint-logical-block.10 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-level* 0) - (val '(5))) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-level* 0) + (val '(5))) (with-output-to-string (os) (pprint-logical-block - (os val :prefix "[" :suffix "]") - (write (car val) :stream os))))) + (os val :prefix "[" :suffix "]") + (write (car val) :stream os))))) "#") (deftest pprint-logical-block.11 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(6))) + (*print-right-margin* 100) + (*print-readably* nil) + (val '(6))) (with-output-to-string (os) (pprint-logical-block - (os val :per-line-prefix "abcd") - (write (car val) :stream os))))) + (os val :per-line-prefix "abcd") + (write (car val) :stream os))))) "abcd6") (deftest pprint-logical-block.12 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(a b c))) + (*print-right-margin* 100) + (*print-readably* nil) + (val '(a b c))) (with-output-to-string (os) (pprint-logical-block - (os val :per-line-prefix "abcd") - (write 1 :stream os) - (terpri os) - (terpri os) - (write 2 :stream os) - (terpri os) - (write 3 :stream os))))) + (os val :per-line-prefix "abcd") + (write 1 :stream os) + (terpri os) + (terpri os) + (write 2 :stream os) + (terpri os) + (write 3 :stream os))))) "abcd1 abcd @@ -180,28 +180,28 @@ abcd3") (deftest pprint-logical-block.13 (with-standard-io-syntax (let ((*print-pretty* nil) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-level* 0) - (val '(5))) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-level* 0) + (val '(5))) (with-output-to-string (os) (pprint-logical-block - (os val :prefix "[" :suffix "]") - (write (car val) :stream os))))) + (os val :prefix "[" :suffix "]") + (write (car val) :stream os))))) "#") ;;; Both :suffix and :per-line-prefix may be supplied (deftest pprint-logical-block.14 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(6))) + (*print-right-margin* 100) + (*print-readably* nil) + (val '(6))) (with-output-to-string (os) (pprint-logical-block (os val :per-line-prefix "[" :suffix "]") - (write (car val) :stream os))))) + (write (car val) :stream os))))) "[6]") ;;; Declarations are allowed @@ -209,7 +209,7 @@ abcd3") (deftest pprint-logical-block.15 (with-standard-io-syntax (let ((*print-pretty* t) - (x 0)) + (x 0)) (with-output-to-string (os) (declare (integer x)) @@ -221,94 +221,94 @@ abcd3") (deftest pprint-logical-block.16 (with-standard-io-syntax (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val 9)) + (*print-right-margin* 100) + (*print-readably* nil) + (val 9)) (with-output-to-string (os) (pprint-logical-block (os val :prefix "[" :suffix "]") - (write val :stream os))))) + (write val :stream os))))) "9") (deftest pprint-logical-block.17 (with-standard-io-syntax (let* ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (*print-circle* t) - (v1 '(8)) - (val (list v1 v1))) + (*print-right-margin* 100) + (*print-readably* nil) + (*print-circle* t) + (v1 '(8)) + (val (list v1 v1))) (with-output-to-string (os) (pprint-logical-block - (os val :prefix "(" :suffix ")") - (pprint-logical-block (os (car val) :prefix "(" :suffix ")") - (write (caar val) :stream os)) - (write-char #\Space os) - (pprint-logical-block (os (cadr val) :prefix "(" :suffix ")") - (write (caadr val) :stream os)))))) + (os val :prefix "(" :suffix ")") + (pprint-logical-block (os (car val) :prefix "(" :suffix ")") + (write (caar val) :stream os)) + (write-char #\Space os) + (pprint-logical-block (os (cadr val) :prefix "(" :suffix ")") + (write (caadr val) :stream os)))))) "(#1=(8) #1#)") ;;; Error cases (deftest pprint-logical-block.error.1 (check-type-error #'(lambda (x) - (pprint-logical-block (*standard-output* '(1) :prefix x))) - #'stringp) + (pprint-logical-block (*standard-output* '(1) :prefix x))) + #'stringp) nil) (deftest pprint-logical-block.error.1-unsafe (check-type-error #'(lambda (x) - (declare (optimize (safety 0))) - (pprint-logical-block (*standard-output* '(1) :prefix x))) - #'stringp) + (declare (optimize (safety 0))) + (pprint-logical-block (*standard-output* '(1) :prefix x))) + #'stringp) nil) (deftest pprint-logical-block.error.2 (check-type-error #'(lambda (x) - (pprint-logical-block (*standard-output* '(1) :suffix x))) - #'stringp) + (pprint-logical-block (*standard-output* '(1) :suffix x))) + #'stringp) nil) (deftest pprint-logical-block.error.2-unsafe (check-type-error #'(lambda (x) - (declare (optimize (safety 0))) - (pprint-logical-block (*standard-output* '(1) :suffix x))) - #'stringp) + (declare (optimize (safety 0))) + (pprint-logical-block (*standard-output* '(1) :suffix x))) + #'stringp) nil) (deftest pprint-logical-block.error.3 (check-type-error #'(lambda (x) - (pprint-logical-block (*standard-output* '(1) :per-line-prefix x))) - #'stringp) + (pprint-logical-block (*standard-output* '(1) :per-line-prefix x))) + #'stringp) nil) (deftest pprint-logical-block.error.3-unsafe (check-type-error #'(lambda (x) - (declare (optimize (safety 0))) - (pprint-logical-block (*standard-output* '(1) :per-line-prefix x))) - #'stringp) + (declare (optimize (safety 0))) + (pprint-logical-block (*standard-output* '(1) :per-line-prefix x))) + #'stringp) nil) (deftest pprint-logical-block.error.4 (signals-error (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(7))) - (pprint-logical-block (os val :prefix "" :per-line-prefix "") - (write (car val) :stream os)))) - error) + (let ((*print-pretty* t) + (*print-right-margin* 100) + (*print-readably* nil) + (val '(7))) + (pprint-logical-block (os val :prefix "" :per-line-prefix "") + (write (car val) :stream os)))) + error) t) (deftest pprint-logical-block.error.4-unsafe (signals-error (with-standard-io-syntax - (let ((*print-pretty* t) - (*print-right-margin* 100) - (*print-readably* nil) - (val '(7))) - (pprint-logical-block (os val :prefix "" :per-line-prefix "") - (write (car val) :stream os)))) - error - :safety 0) + (let ((*print-pretty* t) + (*print-right-margin* 100) + (*print-readably* nil) + (val '(7))) + (pprint-logical-block (os val :prefix "" :per-line-prefix "") + (write (car val) :stream os)))) + error + :safety 0) t) diff --git a/ansi-tests/pprint-newline.lsp b/ansi-tests/pprint-newline.lsp index f5ce5ac4..e7295537 100644 --- a/ansi-tests/pprint-newline.lsp +++ b/ansi-tests/pprint-newline.lsp @@ -41,8 +41,8 @@ A A A " (pprint-logical-block (*terminal-io* nil) (dotimes (i 8) - (write "A " :stream t) - (pprint-newline :fill t)))))) + (write "A " :stream t) + (pprint-newline :fill t)))))) "A A A A A A A A " :margin 10) @@ -131,18 +131,18 @@ A (def-ppblock-test pprint-newline.linear.8 (progn (pprint-logical-block (*standard-output* nil) - (dotimes (i 4) - (write "A ") - (pprint-newline :linear))) + (dotimes (i 4) + (write "A ") + (pprint-newline :linear))) (pprint-newline :linear) (pprint-logical-block (*standard-output* nil) - (dotimes (i 4) - (write "A ") - (pprint-newline :linear)))) + (dotimes (i 4) + (write "A ") + (pprint-newline :linear)))) "A A A A A A A A " :margin 10) - + (def-ppblock-test pprint-newline.linear.9 (dotimes (i 10) (write "A ") (let ((*print-pretty* nil)) (pprint-newline :linear))) "A A A A A A A A A A " @@ -151,10 +151,10 @@ A A A A " (deftest pprint-newline.linear.10 (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* nil)) + (*print-escape* nil) + (*print-pretty* t) + (*print-right-margin* 4) + (*print-miser-width* nil)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :linear))))) @@ -250,9 +250,9 @@ A A A A " (def-ppblock-test pprint-newline.miser.10 (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") - (write "A") - (pprint-newline :miser) - (pprint-newline :mandatory)) + (write "A") + (pprint-newline :miser) + (pprint-newline :mandatory)) "(A )" @@ -261,9 +261,9 @@ A A A A " (def-ppblock-test pprint-newline.miser.11 (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") - (write "A") - (pprint-newline :miser) - (pprint-newline :mandatory)) + (write "A") + (pprint-newline :miser) + (pprint-newline :mandatory)) "(A )" @@ -272,9 +272,9 @@ A A A A " (def-ppblock-test pprint-newline.miser.12 (pprint-logical-block (*standard-output* nil :prefix "(" :suffix ")") - (write "A") - (pprint-newline :miser) - (pprint-newline :mandatory)) + (write "A") + (pprint-newline :miser) + (pprint-newline :mandatory)) "(A )" :margin 20 @@ -283,10 +283,10 @@ A A A A " (deftest pprint-newline.miser.13 (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* 4)) + (*print-escape* nil) + (*print-pretty* t) + (*print-right-margin* 4) + (*print-miser-width* 4)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :miser))))) @@ -372,10 +372,10 @@ X (C D) (deftest pprint-newline.fill.9 (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-right-margin* 4) - (*print-pretty* t) - (*print-miser-width* nil)) + (*print-escape* nil) + (*print-right-margin* 4) + (*print-pretty* t) + (*print-miser-width* nil)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :fill))))) @@ -384,10 +384,10 @@ X (C D) (deftest pprint-newline.fill.10 (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-right-margin* 4) - (*print-pretty* t) - (*print-miser-width* 4)) + (*print-escape* nil) + (*print-right-margin* 4) + (*print-pretty* t) + (*print-miser-width* 4)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :fill))))) @@ -441,10 +441,10 @@ A " (deftest pprint-newline.mandatory.6 (with-standard-io-syntax (let ((*print-readably* nil) - (*print-escape* nil) - (*print-pretty* t) - (*print-right-margin* 4) - (*print-miser-width* nil)) + (*print-escape* nil) + (*print-pretty* t) + (*print-right-margin* 4) + (*print-miser-width* nil)) (with-output-to-string (*standard-output*) (dotimes (i 5) (write "A ") (pprint-newline :mandatory))))) @@ -454,12 +454,12 @@ A " (deftest pprint-newline.error.1 (check-type-error #'pprint-newline - (typef '(member :linear :miser :fill :mandatory))) + (typef '(member :linear :miser :fill :mandatory))) nil) (deftest pprint-newline.error.1-unsafe (check-type-error #'(lambda (x) (declare (optimize (safety 0))) (pprint-newline x)) - (typef '(member :linear :miser :fill :mandatory))) + (typef '(member :linear :miser :fill :mandatory))) nil) (deftest pprint-newline.error.2 diff --git a/ansi-tests/pprint-tab.lsp b/ansi-tests/pprint-tab.lsp index d13cd4c7..085e3c71 100644 --- a/ansi-tests/pprint-tab.lsp +++ b/ansi-tests/pprint-tab.lsp @@ -66,8 +66,8 @@ (def-ppblock-test pprint-tab.nil.1 (progn (write "A") - (pprint-tab :line 10 1 nil) - (write "B")) + (pprint-tab :line 10 1 nil) + (write "B")) "A B") ;;; t designates *terminal-io* @@ -99,25 +99,25 @@ for colnum = (random 100) for colinc = (min (random 50) (random 50)) for s = (with-output-to-string - (*standard-output*) - (pprint-logical-block - (*standard-output* nil) - (dotimes (i offset) (write #\Space)) - (pprint-tab :line colnum colinc) - (write #\A))) + (*standard-output*) + (pprint-logical-block + (*standard-output* nil) + (dotimes (i offset) (write #\Space)) + (pprint-tab :line colnum colinc) + (write #\A))) for expected-col = (cond ((< offset colnum) colnum) - ((= colinc 0) offset) - ((= offset colnum) (+ offset colinc)) - (t (let ((k (mod (- colnum offset) colinc))) - (if (= k 0) - (+ offset colinc) - (+ offset k))))) + ((= colinc 0) offset) + ((= offset colnum) (+ offset colinc)) + (t (let ((k (mod (- colnum offset) colinc))) + (if (= k 0) + (+ offset colinc) + (+ offset k))))) repeat 200 nconc (unless (string= s (concatenate - 'string - (make-string expected-col :initial-element #\Space) - "A")) + 'string + (make-string expected-col :initial-element #\Space) + "A")) (list (list offset colnum colinc expected-col (count #\Space s) s)))) nil :margin 1000) @@ -129,27 +129,27 @@ for colnum = (random 50) for colinc = (min (random 50) (random 50)) for s = (with-output-to-string - (*standard-output*) - (pprint-logical-block - (*standard-output* nil :prefix (make-string prefix-length - :initial-element #\Space)) - (dotimes (i offset) (write #\Space)) - (pprint-tab :section colnum colinc) - (write #\A))) + (*standard-output*) + (pprint-logical-block + (*standard-output* nil :prefix (make-string prefix-length + :initial-element #\Space)) + (dotimes (i offset) (write #\Space)) + (pprint-tab :section colnum colinc) + (write #\A))) for expected-col = (+ prefix-length - (cond ((< offset colnum) colnum) - ((= colinc 0) offset) - ((= offset colnum) (+ offset colinc)) - (t (let ((k (mod (- colnum offset) colinc))) - (if (= k 0) - (+ offset colinc) - (+ offset k)))))) + (cond ((< offset colnum) colnum) + ((= colinc 0) offset) + ((= offset colnum) (+ offset colinc)) + (t (let ((k (mod (- colnum offset) colinc))) + (if (= k 0) + (+ offset colinc) + (+ offset k)))))) repeat 200 nconc (unless (string= s (concatenate - 'string - (make-string expected-col :initial-element #\Space) - "A")) + 'string + (make-string expected-col :initial-element #\Space) + "A")) (list (list offset colnum colinc expected-col (count #\Space s) s)))) nil :margin 1000) @@ -161,19 +161,19 @@ for colinc = (1+ (min (random 50) (random 50))) for extra = (mod (- (+ offset colrel)) colinc) for s = (with-output-to-string - (*standard-output*) - (pprint-logical-block - (*standard-output* nil) - (dotimes (i offset) (write #\Space)) - (pprint-tab :line-relative colrel colinc) - (write #\A))) + (*standard-output*) + (pprint-logical-block + (*standard-output* nil) + (dotimes (i offset) (write #\Space)) + (pprint-tab :line-relative colrel colinc) + (write #\A))) for expected-col = (+ offset colrel extra) repeat 200 nconc (unless (string= s (concatenate - 'string - (make-string expected-col :initial-element #\Space) - "A")) + 'string + (make-string expected-col :initial-element #\Space) + "A")) (list (list offset colrel colinc expected-col (count #\Space s) s)))) nil :margin 1000) @@ -186,21 +186,21 @@ for colinc = (1+ (min (random 50) (random 50))) for extra = (mod (- (+ offset colrel)) colinc) for s = (with-output-to-string - (*standard-output*) - (pprint-logical-block - (*standard-output* nil :prefix (make-string prefix-length - :initial-element #\Space)) - (dotimes (i offset) (write #\Space)) - (pprint-tab :section-relative colrel colinc) - (write #\A))) + (*standard-output*) + (pprint-logical-block + (*standard-output* nil :prefix (make-string prefix-length + :initial-element #\Space)) + (dotimes (i offset) (write #\Space)) + (pprint-tab :section-relative colrel colinc) + (write #\A))) for expected-col = (+ prefix-length offset colrel extra) repeat 200 nconc (unless (string= s (concatenate - 'string - (make-string expected-col :initial-element #\Space) - "A")) + 'string + (make-string expected-col :initial-element #\Space) + "A")) (list (list prefix-length offset colrel colinc extra expected-col (count #\Space s) s)))) nil :margin 1000) @@ -225,14 +225,14 @@ (deftest pprint-tab.error.5 (loop for x in *mini-universe* - unless (or (member x '(:line :section :line-relative :section-relative)) - (eval `(signals-error (pprint-tab ',x 1 1) error))) - collect x) + unless (or (member x '(:line :section :line-relative :section-relative)) + (eval `(signals-error (pprint-tab ',x 1 1) error))) + collect x) nil) (deftest pprint-tab.error.5-unsafe (loop for x in *mini-universe* - unless (or (member x '(:line :section :line-relative :section-relative)) - (eval `(signals-error (locally (declare (optimize (safety 0))) (pprint-tab ',x 1 1)) error))) - collect x) + unless (or (member x '(:line :section :line-relative :section-relative)) + (eval `(signals-error (locally (declare (optimize (safety 0))) (pprint-tab ',x 1 1)) error))) + collect x) nil) diff --git a/ansi-tests/pprint-tabular.lsp b/ansi-tests/pprint-tabular.lsp index 9f76d5b8..603936a7 100644 --- a/ansi-tests/pprint-tabular.lsp +++ b/ansi-tests/pprint-tabular.lsp @@ -9,41 +9,41 @@ (deftest pprint-tabular.1 (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil)) + (*print-readably* nil)) (loop for obj in *mini-universe* - nconc - (and (not (listp obj)) - (let ((s1 (write-to-string obj)) - (s2 (with-output-to-string (s) (pprint-tabular s obj)))) - (unless (equal s1 s2) - (list (list obj s1 s2)))))))) + nconc + (and (not (listp obj)) + (let ((s1 (write-to-string obj)) + (s2 (with-output-to-string (s) (pprint-tabular s obj)))) + (unless (equal s1 s2) + (list (list obj s1 s2)))))))) nil) (deftest pprint-tabular.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) - (*print-readably* nil)) + (*print-readably* nil)) (loop for obj in *mini-universe* - nconc - (and (not (listp obj)) - (let ((s1 (write-to-string obj)) - (s2 (with-output-to-string (s) (pprint-tabular s obj)))) - (unless (equal s1 s2) - (list (list obj s1 s2)))))))) + nconc + (and (not (listp obj)) + (let ((s1 (write-to-string obj)) + (s2 (with-output-to-string (s) (pprint-tabular s obj)))) + (unless (equal s1 s2) + (list (list obj s1 s2)))))))) nil) (defmacro def-pprint-tabular-test (name args expected-value &key (margin 100) (circle nil) (pre nil)) `(deftest ,name (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* ,margin) - (*package* (find-package :cl-test)) - (*print-circle* ,circle)) - (with-output-to-string - (s) - ,@(when pre (list pre)) - (pprint-tabular s ,@args)))) + (*print-readably* nil) + (*print-right-margin* ,margin) + (*package* (find-package :cl-test)) + (*print-circle* ,circle)) + (with-output-to-string + (s) + ,@(when pre (list pre)) + (pprint-tabular s ,@args)))) ,expected-value)) ;;; @@ -96,21 +96,21 @@ (deftest pprint-tabular.23 (my-with-standard-io-syntax (let ((*print-pretty* nil) - (*print-readably* nil) - (*print-right-margin* 100)) + (*print-readably* nil) + (*print-right-margin* 100)) (with-output-to-string (os) (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (pprint-tabular t '(1 2 3) t nil 1)))))) + (is "") + (with-open-stream (*terminal-io* (make-two-way-stream is os)) + (pprint-tabular t '(1 2 3) t nil 1)))))) "(1 2 3)") (deftest pprint-tabular.24 (my-with-standard-io-syntax (let ((*print-pretty* t) - (*print-readably* nil) - (*print-right-margin* 100)) + (*print-readably* nil) + (*print-right-margin* 100)) (with-output-to-string (*standard-output*) (pprint-tabular nil '(1 2 3) t nil 1)))) "(1 2 3)") @@ -121,17 +121,17 @@ (deftest pprint-tabular.return-values.1 (my-with-standard-io-syntax (let ((*print-pretty* nil) - (*package* (find-package :cl-test))) + (*package* (find-package :cl-test))) (with-open-stream (s (make-broadcast-stream)) - (pprint-tabular s '(a b))))) + (pprint-tabular s '(a b))))) nil) (deftest pprint-tabular.return-values.2 (my-with-standard-io-syntax (let ((*print-pretty* nil) - (*package* (find-package :cl-test))) + (*package* (find-package :cl-test))) (with-open-stream (s (make-broadcast-stream)) - (pprint-tabular s 10 nil nil 100)))) + (pprint-tabular s 10 nil nil 100)))) nil) ;;; Error tests diff --git a/ansi-tests/pprint.lsp b/ansi-tests/pprint.lsp index de846262..15edabd3 100644 --- a/ansi-tests/pprint.lsp +++ b/ansi-tests/pprint.lsp @@ -20,7 +20,7 @@ (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (pprint 2 t))))) + (pprint 2 t))))) " 2") diff --git a/ansi-tests/prin1.lsp b/ansi-tests/prin1.lsp index 6811ec62..26d12c04 100644 --- a/ansi-tests/prin1.lsp +++ b/ansi-tests/prin1.lsp @@ -20,7 +20,7 @@ (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (prin1 2 t))))) + (prin1 2 t))))) "2") (deftest prin1.3 diff --git a/ansi-tests/princ.lsp b/ansi-tests/princ.lsp index 4446123b..84b1578f 100644 --- a/ansi-tests/princ.lsp +++ b/ansi-tests/princ.lsp @@ -20,7 +20,7 @@ (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (princ 2 t))))) + (princ 2 t))))) "2") (deftest princ.3 diff --git a/ansi-tests/print-array.lsp b/ansi-tests/print-array.lsp index f0597383..ab93657b 100644 --- a/ansi-tests/print-array.lsp +++ b/ansi-tests/print-array.lsp @@ -19,13 +19,13 @@ (deftest print.array.0.2 (with-standard-io-syntax (let ((a (make-array nil :initial-element '|A|)) - (*package* (find-package "CL-TEST"))) + (*package* (find-package "CL-TEST"))) (write-to-string a :readably nil :array t))) "#0AA") (deftest print.array.0.3 (let* ((a (make-array nil :initial-element 0)) - (result (write-to-string a :readably nil :array nil))) + (result (write-to-string a :readably nil :array nil))) (values (subseq result 0 2) (subseq result (1- (length result))))) @@ -39,68 +39,68 @@ (deftest print.array.0.5 (let* ((a (make-array nil :initial-element 0 :adjustable t)) - (b (make-array nil :displaced-to a :displaced-index-offset 0))) + (b (make-array nil :displaced-to a :displaced-index-offset 0))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#0A0") (deftest print.array.0.6 (let ((a (make-array nil :initial-element 0 - :element-type '(integer 0 2)))) + :element-type '(integer 0 2)))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#0A0") (deftest print.array.0.7 (loop for a = (make-array nil :initial-element (- (random 1000000) 500000)) - repeat 30 nconc (randomly-check-readability a :test #'is-similar)) + repeat 30 nconc (randomly-check-readability a :test #'is-similar)) nil) (deftest print.array.0.8 (loop for i from 1 to 64 - for type = `(unsigned-byte ,i) - nconc - (let ((a (make-array nil :initial-element 1 :element-type type))) - (loop repeat 5 nconc (randomly-check-readability a :test #'is-similar - :can-fail t)))) + for type = `(unsigned-byte ,i) + nconc + (let ((a (make-array nil :initial-element 1 :element-type type))) + (loop repeat 5 nconc (randomly-check-readability a :test #'is-similar + :can-fail t)))) nil) (deftest print.array.0.9 (loop for a = (make-array nil :initial-element (random 1000000) :adjustable t) - repeat 30 - nconc (randomly-check-readability a :test #'is-similar)) + repeat 30 + nconc (randomly-check-readability a :test #'is-similar)) nil) (deftest print.array.0.10 (loop for a = (make-array nil :initial-element (random 1000000000)) - for b = (make-array nil :displaced-to a :displaced-index-offset 0) - repeat 30 nconc (randomly-check-readability b :test #'is-similar)) + for b = (make-array nil :displaced-to a :displaced-index-offset 0) + repeat 30 nconc (randomly-check-readability b :test #'is-similar)) nil) (deftest print.array.0.11 (loop for type in '(short-float single-float double-float long-float float) - for zero = (coerce 0 type) - for a = (make-array nil :initial-element zero - :element-type type) - nconc - (loop repeat 30 nconc (randomly-check-readability a :test #'is-similar - :can-fail t))) + for zero = (coerce 0 type) + for a = (make-array nil :initial-element zero + :element-type type) + nconc + (loop repeat 30 nconc (randomly-check-readability a :test #'is-similar + :can-fail t))) nil) (deftest print.array.0.12 (loop for type0 in '(short-float single-float double-float long-float float) - for type = `(complex ,type0) - for zero = (complex (coerce 0.0s0 type0)) - for a = (make-array nil :initial-element zero - :element-type type) - nconc - (loop repeat 30 nconc (randomly-check-readability a :test #'is-similar - :can-fail t))) + for type = `(complex ,type0) + for zero = (complex (coerce 0.0s0 type0)) + for a = (make-array nil :initial-element zero + :element-type type) + nconc + (loop repeat 30 nconc (randomly-check-readability a :test #'is-similar + :can-fail t))) nil) (deftest print.array.0.13 (let ((result (write-to-string (make-array nil :initial-element 0) - :readably nil :array nil))) + :readably nil :array nil))) (values (subseq result 0 2) (subseq result (1- (length result))))) @@ -108,44 +108,44 @@ (deftest print.array.0.14 (loop for i from 1 to 64 - for type = `(unsigned-byte ,i) - for a = (make-array nil :element-type type :initial-element 1) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list i result)) + for type = `(unsigned-byte ,i) + for a = (make-array nil :element-type type :initial-element 1) + for result = (write-to-string a :readably nil :array nil) + unless (and (string= (subseq result 0 2) "#<") + (string= (subseq result (1- (length result))) ">")) + collect (list i result)) nil) (deftest print.array.0.15 (loop for i from 1 to 64 - for type = `(signed-byte ,i) - for a = (make-array nil :element-type type :initial-element -1) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list i result)) + for type = `(signed-byte ,i) + for a = (make-array nil :element-type type :initial-element -1) + for result = (write-to-string a :readably nil :array nil) + unless (and (string= (subseq result 0 2) "#<") + (string= (subseq result (1- (length result))) ">")) + collect (list i result)) nil) (deftest print.array.0.16 (loop for type in '(short-float single-float double-float long-float) - for a = (make-array nil :element-type type - :initial-element (coerce 17 type)) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list type result)) + for a = (make-array nil :element-type type + :initial-element (coerce 17 type)) + for result = (write-to-string a :readably nil :array nil) + unless (and (string= (subseq result 0 2) "#<") + (string= (subseq result (1- (length result))) ">")) + collect (list type result)) nil) (deftest print.array.0.17 (loop for type0 in '(short-float single-float double-float - long-float float real) - for type = `(complex ,type0) - for a = (make-array nil :element-type type - :initial-element (complex 0 (coerce 3 type0))) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list type result)) + long-float float real) + for type = `(complex ,type0) + for a = (make-array nil :element-type type + :initial-element (complex 0 (coerce 3 type0))) + for result = (write-to-string a :readably nil :array nil) + unless (and (string= (subseq result 0 2) "#<") + (string= (subseq result (1- (length result))) ">")) + collect (list type result)) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -188,41 +188,41 @@ (deftest print.array.2.7 (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) - (b (make-array '(3 3) :displaced-to a - :displaced-index-offset 0))) + (b (make-array '(3 3) :displaced-to a + :displaced-index-offset 0))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((1 3 8) (2 67 121) (65 432 6))") (deftest print.array.2.8 (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) - (b (make-array '(2 3) :displaced-to a - :displaced-index-offset 0))) + (b (make-array '(2 3) :displaced-to a + :displaced-index-offset 0))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((1 3 8) (2 67 121))") (deftest print.array.2.9 (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) - (b (make-array '(2 2) :displaced-to a - :displaced-index-offset 4))) + (b (make-array '(2 2) :displaced-to a + :displaced-index-offset 4))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((67 121) (65 432))") (deftest print.array.2.10 (let* ((a (make-array '(3 3) :initial-contents '((1 3 8) (2 67 121) (65 432 6)))) - (b (make-array '(2 2) :displaced-to a - :displaced-index-offset 4 - :adjustable t))) + (b (make-array '(2 2) :displaced-to a + :displaced-index-offset 4 + :adjustable t))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((67 121) (65 432))") (deftest print.array.2.11 (let* ((a (make-array '(3 4) - :initial-contents '((7 8 9 10) (65 12 42 -1) (:|W| :|X| :|Y| :|Z| )) - :adjustable t))) + :initial-contents '((7 8 9 10) (65 12 42 -1) (:|W| :|X| :|Y| :|Z| )) + :adjustable t))) (with-standard-io-syntax (write-to-string a :readably nil :array t))) "#2A((7 8 9 10) (65 12 42 -1) (:W :X :Y :Z))") @@ -230,83 +230,83 @@ (deftest print.array.2.12 (let ((desired-result "#2A((0 1 1) (1 1 0))")) (loop for i from 2 to 64 - for a = (make-array '(2 3) :element-type `(unsigned-byte ,i) - :initial-contents '((0 1 1) (1 1 0))) - for result = (with-standard-io-syntax - (write-to-string a :readably nil :array t)) - unless (string= desired-result result) - collect (list i a result))) + for a = (make-array '(2 3) :element-type `(unsigned-byte ,i) + :initial-contents '((0 1 1) (1 1 0))) + for result = (with-standard-io-syntax + (write-to-string a :readably nil :array t)) + unless (string= desired-result result) + collect (list i a result))) nil) (deftest print.array.2.13 (let ((desired-result "#2A((0 -1 -1) (-1 -1 0))")) (loop for i from 1 to 64 - for a = (make-array '(2 3) :element-type `(signed-byte ,i) - :initial-contents '((0 -1 -1) (-1 -1 0))) - for result = (with-standard-io-syntax - (write-to-string a :readably nil :array t)) - unless (string= desired-result result) - collect (list i a result))) + for a = (make-array '(2 3) :element-type `(signed-byte ,i) + :initial-contents '((0 -1 -1) (-1 -1 0))) + for result = (with-standard-io-syntax + (write-to-string a :readably nil :array t)) + unless (string= desired-result result) + collect (list i a result))) nil) (deftest print.array.2.14 (let ((desired-result "#2A((0 1 1) (1 1 0))")) (loop for i from 2 to 64 - for a = (make-array '(2 3) :element-type `(unsigned-byte ,i) - :adjustable t - :initial-contents '((0 1 1) (1 1 0))) - for result = (with-standard-io-syntax - (write-to-string a :readably nil :array t)) - unless (string= desired-result result) - collect (list i a result))) + for a = (make-array '(2 3) :element-type `(unsigned-byte ,i) + :adjustable t + :initial-contents '((0 1 1) (1 1 0))) + for result = (with-standard-io-syntax + (write-to-string a :readably nil :array t)) + unless (string= desired-result result) + collect (list i a result))) nil) (deftest print.array.2.15 (let ((desired-result "#2A((0 -1 -1) (-1 -1 0))")) (loop for i from 1 to 64 - for a = (make-array '(2 3) :element-type `(signed-byte ,i) - :adjustable t - :initial-contents '((0 -1 -1) (-1 -1 0))) - for result = (with-standard-io-syntax - (write-to-string a :readably nil :array t)) - unless (string= desired-result result) - collect (list i a result))) + for a = (make-array '(2 3) :element-type `(signed-byte ,i) + :adjustable t + :initial-contents '((0 -1 -1) (-1 -1 0))) + for result = (with-standard-io-syntax + (write-to-string a :readably nil :array t)) + unless (string= desired-result result) + collect (list i a result))) nil) (deftest print.array.2.16 (let ((desired-result "#2A((1 1) (1 0))")) (loop for i from 2 to 64 - for type = `(unsigned-byte ,i) - for a = (make-array '(2 3) :element-type type - :adjustable t - :initial-contents '((0 1 1) (1 1 0))) - for b = (make-array '(2 2) :displaced-to a :displaced-index-offset 2 - :element-type type) - for result = (with-standard-io-syntax - (write-to-string b :readably nil :array t)) - unless (string= desired-result result) - collect (list i b result))) + for type = `(unsigned-byte ,i) + for a = (make-array '(2 3) :element-type type + :adjustable t + :initial-contents '((0 1 1) (1 1 0))) + for b = (make-array '(2 2) :displaced-to a :displaced-index-offset 2 + :element-type type) + for result = (with-standard-io-syntax + (write-to-string b :readably nil :array t)) + unless (string= desired-result result) + collect (list i b result))) nil) (deftest print.array.2.17 (let ((desired-result "#2A((1 -1) (-2 0))")) (loop for i from 2 to 64 - for type = `(signed-byte ,i) - for a = (make-array '(2 3) :element-type type - :adjustable t - :initial-contents '((0 1 1) (-1 -2 0))) - for b = (make-array '(2 2) :displaced-to a :displaced-index-offset 2 - :element-type type) - for result = (with-standard-io-syntax - (write-to-string b :readably nil :array t)) - unless (string= desired-result result) - collect (list i b result))) + for type = `(signed-byte ,i) + for a = (make-array '(2 3) :element-type type + :adjustable t + :initial-contents '((0 1 1) (-1 -2 0))) + for b = (make-array '(2 2) :displaced-to a :displaced-index-offset 2 + :element-type type) + for result = (with-standard-io-syntax + (write-to-string b :readably nil :array t)) + unless (string= desired-result result) + collect (list i b result))) nil) (deftest print.array.2.20 (let* ((a (make-array '(9) :initial-contents '(1 3 8 2 67 121 65 432 6))) - (b (make-array '(2 2) :displaced-to a - :displaced-index-offset 1))) + (b (make-array '(2 2) :displaced-to a + :displaced-index-offset 1))) (with-standard-io-syntax (write-to-string b :readably nil :array t))) "#2A((3 8) (2 67))") @@ -318,100 +318,100 @@ for a = (make-array dims :initial-element (- (random 1000000) 500000)) repeat 100 nconc (let ((result (randomly-check-readability a :test #'is-similar :can-fail t))) - (and result (list (cons dims (first result)))))) + (and result (list (cons dims (first result)))))) 10) nil) (deftest print.array.2.22 (loop for a = (make-array (list (random 4) (random 4)) - :initial-element (- (random 1000000) 500000) - :adjustable t) - repeat 100 nconc (randomly-check-readability a :test #'is-similar - :can-fail t)) + :initial-element (- (random 1000000) 500000) + :adjustable t) + repeat 100 nconc (randomly-check-readability a :test #'is-similar + :can-fail t)) nil) (deftest print.array.2.23 (loop for d1 = (random 10) - for d2 = (random 10) - for a = (make-array (list d1 d2) - :initial-element (- (random 1000000) 500000)) - for d1a = (random (1+ d1)) - for d2a = (random (1+ d2)) - for offset = (random (1+ (- (* d1 d2) (* d1a d2a)))) - for b = (make-array (list d1a d2a) :displaced-to a - :displaced-index-offset offset) - repeat 100 nconc (randomly-check-readability b :test #'is-similar - :can-fail t)) + for d2 = (random 10) + for a = (make-array (list d1 d2) + :initial-element (- (random 1000000) 500000)) + for d1a = (random (1+ d1)) + for d2a = (random (1+ d2)) + for offset = (random (1+ (- (* d1 d2) (* d1a d2a)))) + for b = (make-array (list d1a d2a) :displaced-to a + :displaced-index-offset offset) + repeat 100 nconc (randomly-check-readability b :test #'is-similar + :can-fail t)) nil) (deftest print.array.2.24 (loop for i from 1 to 64 - for type = `(unsigned-byte ,i) - nconc - (let ((a (make-array '(3 4) :initial-element 1 :element-type type))) - (loop repeat 5 nconc (randomly-check-readability a :test #'is-similar - :can-fail t)))) + for type = `(unsigned-byte ,i) + nconc + (let ((a (make-array '(3 4) :initial-element 1 :element-type type))) + (loop repeat 5 nconc (randomly-check-readability a :test #'is-similar + :can-fail t)))) nil) (deftest print.array.2.25 (let ((a (make-array '(3 4) :initial-element #\a :element-type 'character))) (loop repeat 10 nconc (randomly-check-readability a :test #'is-similar - :can-fail t))) + :can-fail t))) nil) (deftest print.array.2.26 (let ((a (make-array '(3 4) :initial-element #\a :element-type 'base-char))) (loop repeat 10 nconc (randomly-check-readability a :test #'is-similar - :can-fail t))) + :can-fail t))) nil) (deftest print.array.2.27 (let ((str (write-to-string (make-array '(2 3) :initial-element 0) - :readably nil :array nil))) + :readably nil :array nil))) (values (subseq str 0 2) (subseq str (1- (length str))))) "#<" ">") (deftest print.array.2.28 (loop for i from 1 to 64 - for type = `(unsigned-byte ,i) - for a = (make-array '(4 3) :element-type type :initial-element 1) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list i result)) + for type = `(unsigned-byte ,i) + for a = (make-array '(4 3) :element-type type :initial-element 1) + for result = (write-to-string a :readably nil :array nil) + unless (and (string= (subseq result 0 2) "#<") + (string= (subseq result (1- (length result))) ">")) + collect (list i result)) nil) (deftest print.array.2.29 (loop for i from 1 to 64 - for type = `(signed-byte ,i) - for a = (make-array '(4 8) :element-type type :initial-element -1) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list i result)) + for type = `(signed-byte ,i) + for a = (make-array '(4 8) :element-type type :initial-element -1) + for result = (write-to-string a :readably nil :array nil) + unless (and (string= (subseq result 0 2) "#<") + (string= (subseq result (1- (length result))) ">")) + collect (list i result)) nil) (deftest print.array.2.30 (loop for type in '(short-float single-float double-float long-float) - for a = (make-array '(5 7) :element-type type - :initial-element (coerce 17 type)) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list type result)) + for a = (make-array '(5 7) :element-type type + :initial-element (coerce 17 type)) + for result = (write-to-string a :readably nil :array nil) + unless (and (string= (subseq result 0 2) "#<") + (string= (subseq result (1- (length result))) ">")) + collect (list type result)) nil) (deftest print.array.2.31 (loop for type0 in '(short-float single-float double-float - long-float float real) - for type = `(complex ,type0) - for a = (make-array '(13 5) :element-type type - :initial-element (complex 0 (coerce 3 type0))) - for result = (write-to-string a :readably nil :array nil) - unless (and (string= (subseq result 0 2) "#<") - (string= (subseq result (1- (length result))) ">")) - collect (list type result)) + long-float float real) + for type = `(complex ,type0) + for a = (make-array '(13 5) :element-type type + :initial-element (complex 0 (coerce 3 type0))) + for result = (write-to-string a :readably nil :array nil) + unless (and (string= (subseq result 0 2) "#<") + (string= (subseq result (1- (length result))) ">")) + collect (list type result)) nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -419,8 +419,8 @@ (deftest print.array.3.1 (let* ((a (make-array '(1 2 3) :initial-contents '(((:|A| :|B| :|C|) (:|D| :|E| :|F|))))) - (b (make-array '(3 2 1) :displaced-to a - :displaced-index-offset 0))) + (b (make-array '(3 2 1) :displaced-to a + :displaced-index-offset 0))) (with-standard-io-syntax (values (write-to-string a :readably nil :array t) @@ -434,40 +434,40 @@ (deftest print.array.multi-dim.1 (with-standard-io-syntax (loop for d in (remove array-rank-limit - '(4 5 6 7 8 9 10 12 16 20 30 40 100 200 400 600 800 1023) - :test #'<=) - for dims = (make-list d :initial-element 1) - for a = (make-array dims :initial-element 0) - for result = (with-standard-io-syntax - (write-to-string a :readably nil :array t)) - for expected-result = - (concatenate 'string - (format nil "#~DA" d) - (make-string d :initial-element #\() - "0" - (make-string d :initial-element #\))) - unless (string= result expected-result) - collect (list d result expected-result))) + '(4 5 6 7 8 9 10 12 16 20 30 40 100 200 400 600 800 1023) + :test #'<=) + for dims = (make-list d :initial-element 1) + for a = (make-array dims :initial-element 0) + for result = (with-standard-io-syntax + (write-to-string a :readably nil :array t)) + for expected-result = + (concatenate 'string + (format nil "#~DA" d) + (make-string d :initial-element #\() + "0" + (make-string d :initial-element #\))) + unless (string= result expected-result) + collect (list d result expected-result))) nil) (deftest print.array.multi-dim.2 (with-standard-io-syntax (loop for d = (+ 4 (random (min (- array-rank-limit 4) 1000))) - for p = (random d) - for dims = (let ((list (make-list d :initial-element 1))) - (setf (elt list p) 0) - list) - for a = (make-array dims :initial-element 0) - for result = (with-standard-io-syntax - (write-to-string a :readably nil :array t)) - for expected-result = - (concatenate 'string - (format nil "#~DA" d) - (make-string (1+ p) :initial-element #\() - (make-string (1+ p) :initial-element #\))) - repeat 50 - unless (string= result expected-result) - collect (list d result expected-result))) + for p = (random d) + for dims = (let ((list (make-list d :initial-element 1))) + (setf (elt list p) 0) + list) + for a = (make-array dims :initial-element 0) + for result = (with-standard-io-syntax + (write-to-string a :readably nil :array t)) + for expected-result = + (concatenate 'string + (format nil "#~DA" d) + (make-string (1+ p) :initial-element #\() + (make-string (1+ p) :initial-element #\))) + repeat 50 + unless (string= result expected-result) + collect (list d result expected-result))) nil) ;;; To add: more tests for high dimensional arrays, including arrays with diff --git a/ansi-tests/print-backquote.lsp b/ansi-tests/print-backquote.lsp index b72c647b..331ea940 100644 --- a/ansi-tests/print-backquote.lsp +++ b/ansi-tests/print-backquote.lsp @@ -10,7 +10,7 @@ (deftest print.backquote.random.1 (let* ((x '`(a ,b ,@c (d . ,e) ,.f #(1 2 ,p ,@q ,.r s) g)) - (y (copy-tree x))) + (y (copy-tree x))) (or (loop repeat 20 @@ -20,7 +20,7 @@ (deftest print.backquote.random.2 (let* ((x '`(,@a ,@b)) - (y (copy-tree x))) + (y (copy-tree x))) (or (loop repeat 20 @@ -30,7 +30,7 @@ (deftest print.backquote.random.3 (let* ((x '`(,.a ,.b)) - (y (copy-tree x))) + (y (copy-tree x))) (or (loop repeat 20 @@ -40,7 +40,7 @@ (deftest print.backquote.random.4 (let* ((x '`(,a ,b)) - (y (copy-tree x))) + (y (copy-tree x))) (or (loop repeat 20 @@ -50,7 +50,7 @@ (deftest print.backquote.random.5 (let* ((x '`#(,a ,b)) - (y (copy-tree x))) + (y (copy-tree x))) (or (loop repeat 20 @@ -61,37 +61,37 @@ (deftest print.backquote.random.6 (let ((x '`(,@a ,@b))) (and (consp x) - (symbolp (car x)) - (loop - repeat 20 - nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) + (symbolp (car x)) + (loop + repeat 20 + nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.7 (let ((x '`(,.a ,.b))) (and (consp x) - (symbolp (car x)) - (loop - repeat 20 - nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) + (symbolp (car x)) + (loop + repeat 20 + nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.8 (let ((x '`(,a ,b))) (and (consp x) - (symbolp (car x)) - (loop - repeat 20 - nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) + (symbolp (car x)) + (loop + repeat 20 + nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.9 (let ((x '`#(,a ,b))) (and (consp x) - (symbolp (car x)) - (loop - repeat 20 - nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) + (symbolp (car x)) + (loop + repeat 20 + nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.10 @@ -111,24 +111,24 @@ (deftest print.backquote.random.12 (let ((x '`#(,a ,b c))) (and (consp x) - (symbolp (car x)) - (loop - repeat 20 - nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) + (symbolp (car x)) + (loop + repeat 20 + nconc (randomly-check-readability (list (car x)) :test #'is-similar)))) nil) (deftest print.backquote.random.13 (let* ((x '`#(,a ,b c)) - (y (copy-tree x))) + (y (copy-tree x))) (or (loop repeat 20 nconc (randomly-check-readability x :test #'is-similar)) - (and (not (is-similar x y)) (list :modified x y)))) + (and (not (is-similar x y)) (list :modified x y)))) nil) (deftest print.backquote.random.14 (loop for x = (make-random-backquoted-form 100) - repeat 500 - nconc (randomly-check-readability x :test #'is-similar)) - nil) \ No newline at end of file + repeat 500 + nconc (randomly-check-readability x :test #'is-similar)) + nil) diff --git a/ansi-tests/print-bit-vector.lsp b/ansi-tests/print-bit-vector.lsp index 63a6fdee..5e704db4 100644 --- a/ansi-tests/print-bit-vector.lsp +++ b/ansi-tests/print-bit-vector.lsp @@ -15,7 +15,7 @@ (deftest print.bit-vector.2 (with-standard-io-syntax (subseq (write-to-string #* :readably nil :escape nil :array nil) - 0 2)) + 0 2)) "#<") (deftest print.bit-vector.3 @@ -26,24 +26,24 @@ (deftest print.bit-vector.4 (with-standard-io-syntax (subseq (write-to-string #*11010011010110101 - :readably nil :escape nil :array nil) - 0 2)) + :readably nil :escape nil :array nil) + 0 2)) "#<") (deftest print.bit-vector.5 (let* ((bv1 #*0001100101) - (bv2 (make-array 5 :displaced-to bv1 - :displaced-index-offset 1 - :element-type 'bit))) + (bv2 (make-array 5 :displaced-to bv1 + :displaced-index-offset 1 + :element-type 'bit))) (with-standard-io-syntax (write-to-string bv2 :readably nil :escape nil))) "#*00110") (deftest print.bit-vector.6 (let* ((bv (make-array 10 - :element-type 'bit - :initial-contents '(1 0 0 1 0 0 1 1 1 0) - :fill-pointer 5))) + :element-type 'bit + :initial-contents '(1 0 0 1 0 0 1 1 1 0) + :fill-pointer 5))) (with-standard-io-syntax (write-to-string bv :readably nil :escape nil))) "#*10010") @@ -51,9 +51,9 @@ (deftest print.bit-vector.7 (let* ((bv (make-array 10 - :element-type 'bit - :initial-contents '(1 0 0 1 0 0 1 1 1 0) - :adjustable t))) + :element-type 'bit + :initial-contents '(1 0 0 1 0 0 1 1 1 0) + :adjustable t))) (with-standard-io-syntax (write-to-string bv :readably nil :escape nil))) "#*1001001110") diff --git a/ansi-tests/print-characters.lsp b/ansi-tests/print-characters.lsp index 2dc6c518..c220e240 100644 --- a/ansi-tests/print-characters.lsp +++ b/ansi-tests/print-characters.lsp @@ -12,107 +12,107 @@ (deftest print.char.1 (with-standard-io-syntax (loop for c across +standard-chars+ - unless (equal (string c) - (with-output-to-string (s) - (princ c s))) - collect c)) + unless (equal (string c) + (with-output-to-string (s) + (princ c s))) + collect c)) nil) (deftest print.char.2 (with-standard-io-syntax (loop for c across +code-chars+ - unless (equal (string c) - (with-output-to-string (s) - (princ c s))) - collect c)) + unless (equal (string c) + (with-output-to-string (s) + (princ c s))) + collect c)) nil) (deftest print.char.3 (with-standard-io-syntax (let ((*print-readably* nil)) (loop for c across +base-chars+ - unless (or (eql c #\Space) - (equal (format nil "#\\~C" c) - (with-output-to-string (s) - (prin1 c s)))) - collect c))) + unless (or (eql c #\Space) + (equal (format nil "#\\~C" c) + (with-output-to-string (s) + (prin1 c s)))) + collect c))) nil) (deftest print.char.4 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) - (prin1 #\Space s)))) + (prin1 #\Space s)))) "#\\ ") (deftest print.char.5 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) - (prin1 #\Newline s)))) + (prin1 #\Newline s)))) "#\\Newline") (deftest print.char.6 (with-standard-io-syntax (let ((*print-readably* nil)) (with-output-to-string (s) - (princ #\Newline s)))) + (princ #\Newline s)))) #.(string #\Newline)) (deftest print.char.7 (with-standard-io-syntax (let ((*print-readably* nil)) (loop for c across +code-chars+ - for str = (with-output-to-string (s) (prin1 c s)) - for len = (length str) - unless (and (>= len 3) - (equal (subseq str 0 2) "#\\") - (or (= len 3) - (let ((name (subseq str 2))) - (eql c (name-char name))))) - collect c))) + for str = (with-output-to-string (s) (prin1 c s)) + for len = (length str) + unless (and (>= len 3) + (equal (subseq str 0 2) "#\\") + (or (= len 3) + (let ((name (subseq str 2))) + (eql c (name-char name))))) + collect c))) nil) (deftest print.char.8 (loop for i = (random (min char-code-limit (ash 1 16))) - for c = (code-char i) - repeat 1000 - unless (null c) - nconc (let ((result (randomly-check-readability c))) - (and result (list (cons i (first result)))))) + for c = (code-char i) + repeat 1000 + unless (null c) + nconc (let ((result (randomly-check-readability c))) + (and result (list (cons i (first result)))))) nil) (deftest print.char.9 (loop for i = (random (min char-code-limit (ash 1 32))) - for c = (code-char i) - repeat 1000 - unless (null c) - nconc (let ((result (randomly-check-readability c))) - (and result (list (cons i (first result)))))) + for c = (code-char i) + repeat 1000 + unless (null c) + nconc (let ((result (randomly-check-readability c))) + (and result (list (cons i (first result)))))) nil) (deftest print.char.10 (with-standard-io-syntax (let ((*print-readably* nil)) (loop for c across +standard-chars+ - for str = (with-output-to-string (s) (prin1 c s)) - unless (or (eql c #\Newline) - (equal str (concatenate 'string "#\\" (string c)))) - collect (list c str)))) + for str = (with-output-to-string (s) (prin1 c s)) + unless (or (eql c #\Newline) + (equal str (concatenate 'string "#\\" (string c)))) + collect (list c str)))) nil) (deftest print.char.11 (with-standard-io-syntax (let ((*print-readably* nil)) (let ((names '("Newline" "Tab" "Rubout" "Linefeed" "Page" - "Backspace" "Return"))) + "Backspace" "Return"))) (loop for name in names - for c = (name-char name) - for str = (with-output-to-string (s) (prin1 c s)) - unless (or (null c) - (and (>= (length str) 3) - (equal (subseq str 0 2) "#\\") - (member (subseq str 2) names - :test #'equal))) - collect (list c str))))) - nil) \ No newline at end of file + for c = (name-char name) + for str = (with-output-to-string (s) (prin1 c s)) + unless (or (null c) + (and (>= (length str) 3) + (equal (subseq str 0 2) "#\\") + (member (subseq str 2) names + :test #'equal))) + collect (list c str))))) + nil) diff --git a/ansi-tests/print-complex.lsp b/ansi-tests/print-complex.lsp index ade195cb..956fcc4d 100644 --- a/ansi-tests/print-complex.lsp +++ b/ansi-tests/print-complex.lsp @@ -25,30 +25,30 @@ (deftest print.complex.random.1 (loop for numbits = (random 40) - for bound = (ash 1 numbits) - for r = (- (random (+ bound bound)) bound) - for i = (- (random (+ bound bound)) bound) - repeat 1000 - unless (= i 0) - nconc (randomly-check-readability (complex r i))) + for bound = (ash 1 numbits) + for r = (- (random (+ bound bound)) bound) + for i = (- (random (+ bound bound)) bound) + repeat 1000 + unless (= i 0) + nconc (randomly-check-readability (complex r i))) nil) (deftest print.complex.random.2 (loop for numbits = (random 40) - for bound = (ash 1 numbits) - for num1 = (- (random (+ bound bound)) bound) - for num2 = (- (random (+ bound bound)) bound) - for denom1 = (1+ (random bound)) - for denom2 = (1+ (random bound)) - for r = (/ num1 denom1) - for i = (/ num2 denom2) - repeat 1000 - unless (= i 0) - nconc (randomly-check-readability (complex r i))) + for bound = (ash 1 numbits) + for num1 = (- (random (+ bound bound)) bound) + for num2 = (- (random (+ bound bound)) bound) + for denom1 = (1+ (random bound)) + for denom2 = (1+ (random bound)) + for r = (/ num1 denom1) + for i = (/ num2 denom2) + repeat 1000 + unless (= i 0) + nconc (randomly-check-readability (complex r i))) nil) ;; General floating point complex printing tests will go here - + diff --git a/ansi-tests/print-cons.lsp b/ansi-tests/print-cons.lsp index 1d0b46ce..7d9b77a8 100644 --- a/ansi-tests/print-cons.lsp +++ b/ansi-tests/print-cons.lsp @@ -41,18 +41,18 @@ (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string (let ((s1 (make-symbol "X")) - (s2 (make-symbol "X"))) - (list s1 s2 s1 s2)) - :case :upcase :pretty nil :escape t :circle t))) + (s2 (make-symbol "X"))) + (list s1 s2 s1 s2)) + :case :upcase :pretty nil :escape t :circle t))) "(#1=#:X #2=#:X #1# #2#)") (deftest print.cons.7 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string (let ((a (list 17 nil))) - (setf (cdr a) a) - a) - :circle t :pretty nil :escape nil))) + (setf (cdr a) a) + a) + :circle t :pretty nil :escape nil))) "#1=(17 . #1#)") ;;; Random printing @@ -70,17 +70,17 @@ #-lispworks (deftest print.cons.random.2 (loop repeat 50 - nconc - (let* ((n 20) - (conses (apply #'vector - (loop repeat n collect (cons nil nil))))) - (loop for x across conses - for j = (random n) - for k = (random n) - do (setf (car x) (elt conses j) - (cdr x) (elt conses k))) - (randomly-check-readability (elt conses 0) :test #'is-similar - :circle t))) + nconc + (let* ((n 20) + (conses (apply #'vector + (loop repeat n collect (cons nil nil))))) + (loop for x across conses + for j = (random n) + for k = (random n) + do (setf (car x) (elt conses j) + (cdr x) (elt conses k))) + (randomly-check-readability (elt conses 0) :test #'is-similar + :circle t))) nil) ;;; Printing with *print-length* @@ -105,7 +105,7 @@ (deftest print.cons.length.4 (my-with-standard-io-syntax - (let ((*print-readably* nil)) + (let ((*print-readably* nil)) (write-to-string '(4 8) :length 1 :pretty nil :escape nil))) "(4 ...)") @@ -113,17 +113,17 @@ (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a b c d e f g h i j k l m n o p) - :case :downcase :length 10 - :pretty nil :escape nil))) + :case :downcase :length 10 + :pretty nil :escape nil))) "(a b c d e f g h i j ...)") (deftest print.cons.length.6 (my-with-standard-io-syntax - (let ((*print-readably* nil)) + (let ((*print-readably* nil)) (write-to-string '(((((((0))))))) - :case :downcase :length 3 - :pretty nil :escape nil))) + :case :downcase :length 3 + :pretty nil :escape nil))) "(((((((0)))))))") ;;; Printing with *print-level* @@ -132,24 +132,24 @@ (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a) - :case :downcase :level 0 - :escape nil :pretty nil))) + :case :downcase :level 0 + :escape nil :pretty nil))) "#") (deftest print.cons.level.2 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a) - :case :downcase :level 1 - :escape nil :pretty nil))) + :case :downcase :level 1 + :escape nil :pretty nil))) "(a)") (deftest print.cons.level.3 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '((a)) - :case :downcase :level 1 - :escape nil :pretty nil))) + :case :downcase :level 1 + :escape nil :pretty nil))) "(#)") @@ -157,14 +157,14 @@ (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(a) - :case :downcase :level 2 - :escape nil :pretty nil))) + :case :downcase :level 2 + :escape nil :pretty nil))) "(a)") (deftest print.cons.level.5 (my-with-standard-io-syntax (let ((*print-readably* nil)) (write-to-string '(#(a) #*1101 "abc") - :case :downcase :level 1 - :pretty nil))) + :case :downcase :level 1 + :pretty nil))) "(# #*1101 \"abc\")") diff --git a/ansi-tests/print-floats.lsp b/ansi-tests/print-floats.lsp index 35a7eb4e..81869ba1 100644 --- a/ansi-tests/print-floats.lsp +++ b/ansi-tests/print-floats.lsp @@ -10,94 +10,94 @@ (deftest print.short-float.1 (with-standard-io-syntax (let ((*print-readably* nil) - (*read-default-float-format* 'short-float)) + (*read-default-float-format* 'short-float)) (loop for i from -4000 to 4000 - for f = (float i 0.0s0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - unless (equalp s1 s2) - collect (list i f s1 s2)))) + for f = (float i 0.0s0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for s2 = (format nil "~A.0" i) + unless (equalp s1 s2) + collect (list i f s1 s2)))) nil) (deftest print.short-float.2 (with-standard-io-syntax (let ((*print-readably* nil) - (*read-default-float-format* 'short-float)) + (*read-default-float-format* 'short-float)) (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0s0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (equalp s1 s2)) - collect (list i f s1 s2)))) + for f = (float i 0.0s0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for s2 = (format nil "~A.0" i) + repeat 10000 + unless (or (/= i (rational f)) ; not enough bits + ;; (> (nth-value 1 (integer-decode-float f)) 0) + (equalp s1 s2)) + collect (list i f s1 s2)))) nil) (defparameter *possible-short-float-exponent-markers* (loop for type in '(short-float single-float double-float long-float) - for c across "SFDL" - when (subtypep 'short-float type) - nconc (list c (char-downcase c)))) + for c across "SFDL" + when (subtypep 'short-float type) + nconc (list c (char-downcase c)))) (deftest print.short-float.3 (let ((chars *possible-short-float-exponent-markers*)) (loop for type in '(single-float double-float long-float) - nconc - (and (not (subtypep 'short-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i from -4000 to 4000 - for f = (float i 0.0s0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - unless (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars)) - collect (list type i f s1 s2))))))) + nconc + (and (not (subtypep 'short-float type)) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*read-default-float-format* type)) + (loop for i from -4000 to 4000 + for f = (float i 0.0s0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for len1 = (length s1) + for s2 = (format nil "~A.0" i) + unless (and (> len1 4) + (string-equal s1 s2 :start1 0 :end1 (- len1 2)) + (eql (char s1 (- len1 1)) #\0) + (member (char s1 (- len1 2)) chars)) + collect (list type i f s1 s2))))))) nil) (deftest print.short-float.4 (let ((chars *possible-short-float-exponent-markers*)) (loop for type in '(single-float double-float long-float) - nconc - (and (not (subtypep 'short-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0s0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars))) - collect (list type i f s1 s2))))))) + nconc + (and (not (subtypep 'short-float type)) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*read-default-float-format* type)) + (loop for i = (- (random 20000000) 10000000) + for f = (float i 0.0s0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for len1 = (length s1) + for s2 = (format nil "~A.0" i) + repeat 10000 + unless (or (/= i (rational f)) ;; not enough bits + ;; (> (nth-value 1 (integer-decode-float f)) 0) + (and (> len1 4) + (string-equal s1 s2 :start1 0 :end1 (- len1 2)) + (eql (char s1 (- len1 1)) #\0) + (member (char s1 (- len1 2)) chars))) + collect (list type i f s1 s2))))))) nil) (deftest print.short-float.random (let ((lower-bound (if (< (log least-positive-short-float 10) -100) - (expt 0.1s0 100) - least-positive-short-float)) - (upper-bound (/ (if (> (log most-positive-short-float 10) 100) - (expt 10.0s0 100) - most-positive-short-float) - 10))) + (expt 0.1s0 100) + least-positive-short-float)) + (upper-bound (/ (if (> (log most-positive-short-float 10) 100) + (expt 10.0s0 100) + most-positive-short-float) + 10))) (loop for sf = lower-bound then (* 10 sf) - while (< sf upper-bound) - nconc - (loop for x = (handler-case (random sf) (arithmetic-error (c) 0.0s0)) - for y = (if (coin) (- x) x) - repeat 10 - nconc (randomly-check-readability y)))) + while (< sf upper-bound) + nconc + (loop for x = (handler-case (random sf) (arithmetic-error (c) 0.0s0)) + for y = (if (coin) (- x) x) + repeat 10 + nconc (randomly-check-readability y)))) nil) ;;; single floats @@ -105,94 +105,94 @@ (deftest print.single-float.1 (with-standard-io-syntax (let ((*print-readably* nil) - (*read-default-float-format* 'single-float)) + (*read-default-float-format* 'single-float)) (loop for i from -4000 to 4000 - for f = (float i 0.0f0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - unless (equalp s1 s2) - collect (list i f s1 s2)))) + for f = (float i 0.0f0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for s2 = (format nil "~A.0" i) + unless (equalp s1 s2) + collect (list i f s1 s2)))) nil) (deftest print.single-float.2 (with-standard-io-syntax (let ((*print-readably* nil) - (*read-default-float-format* 'single-float)) + (*read-default-float-format* 'single-float)) (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0f0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (equalp s1 s2)) - collect (list i f s1 s2)))) + for f = (float i 0.0f0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for s2 = (format nil "~A.0" i) + repeat 10000 + unless (or (/= i (rational f)) ;; not enough bits + ;; (> (nth-value 1 (integer-decode-float f)) 0) + (equalp s1 s2)) + collect (list i f s1 s2)))) nil) (defparameter *possible-single-float-exponent-markers* (loop for type in '(short-float single-float double-float long-float) - for c across "SFDL" - when (subtypep 'single-float type) - nconc (list c (char-downcase c)))) + for c across "SFDL" + when (subtypep 'single-float type) + nconc (list c (char-downcase c)))) (deftest print.single-float.3 (let ((chars *possible-single-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) - nconc - (and (not (subtypep 'single-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i from -4000 to 4000 - for f = (float i 0.0f0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - unless (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars)) - collect (list type i f s1 s2))))))) + nconc + (and (not (subtypep 'single-float type)) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*read-default-float-format* type)) + (loop for i from -4000 to 4000 + for f = (float i 0.0f0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for len1 = (length s1) + for s2 = (format nil "~A.0" i) + unless (and (> len1 4) + (string-equal s1 s2 :start1 0 :end1 (- len1 2)) + (eql (char s1 (- len1 1)) #\0) + (member (char s1 (- len1 2)) chars)) + collect (list type i f s1 s2))))))) nil) (deftest print.single-float.4 (let ((chars *possible-single-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) - nconc - (and (not (subtypep 'single-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0f0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars))) - collect (list type i f s1 s2))))))) + nconc + (and (not (subtypep 'single-float type)) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*read-default-float-format* type)) + (loop for i = (- (random 20000000) 10000000) + for f = (float i 0.0f0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for len1 = (length s1) + for s2 = (format nil "~A.0" i) + repeat 10000 + unless (or (/= i (rational f)) ;; not enough bits + ;; (> (nth-value 1 (integer-decode-float f)) 0) + (and (> len1 4) + (string-equal s1 s2 :start1 0 :end1 (- len1 2)) + (eql (char s1 (- len1 1)) #\0) + (member (char s1 (- len1 2)) chars))) + collect (list type i f s1 s2))))))) nil) (deftest print.single-float.random (let ((lower-bound (if (< (log least-positive-single-float 10) -100) - (expt 0.1f0 100) - least-positive-single-float)) - (upper-bound (/ (if (> (log most-positive-single-float 10) 100) - (expt 10.0f0 100) - most-positive-single-float) - 10))) + (expt 0.1f0 100) + least-positive-single-float)) + (upper-bound (/ (if (> (log most-positive-single-float 10) 100) + (expt 10.0f0 100) + most-positive-single-float) + 10))) (loop for f = lower-bound then (* 10 f) - while (< f upper-bound) - nconc - (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0f0)) - for y = (if (coin) (- x) x) - repeat 10 - nconc (randomly-check-readability y)))) + while (< f upper-bound) + nconc + (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0f0)) + for y = (if (coin) (- x) x) + repeat 10 + nconc (randomly-check-readability y)))) nil) ;;; double float @@ -200,94 +200,94 @@ (deftest print.double-float.1 (with-standard-io-syntax (let ((*print-readably* nil) - (*read-default-float-format* 'double-float)) + (*read-default-float-format* 'double-float)) (loop for i from -4000 to 4000 - for f = (float i 0.0d0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - unless (equalp s1 s2) - collect (list i f s1 s2)))) + for f = (float i 0.0d0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for s2 = (format nil "~A.0" i) + unless (equalp s1 s2) + collect (list i f s1 s2)))) nil) (deftest print.double-float.2 (with-standard-io-syntax (let ((*print-readably* nil) - (*read-default-float-format* 'double-float)) + (*read-default-float-format* 'double-float)) (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0d0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (equalp s1 s2)) - collect (list i f s1 s2)))) + for f = (float i 0.0d0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for s2 = (format nil "~A.0" i) + repeat 10000 + unless (or (/= i (rational f)) ;; not enough bits + ;; (> (nth-value 1 (integer-decode-float f)) 0) + (equalp s1 s2)) + collect (list i f s1 s2)))) nil) (defparameter *possible-double-float-exponent-markers* (loop for type in '(short-float single-float double-float long-float) - for c across "SFDL" - when (subtypep 'double-float type) - nconc (list c (char-downcase c)))) + for c across "SFDL" + when (subtypep 'double-float type) + nconc (list c (char-downcase c)))) (deftest print.double-float.3 (let ((chars *possible-double-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) - nconc - (and (not (subtypep 'double-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i from -4000 to 4000 - for f = (float i 0.0d0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - unless (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars)) - collect (list type i f s1 s2))))))) + nconc + (and (not (subtypep 'double-float type)) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*read-default-float-format* type)) + (loop for i from -4000 to 4000 + for f = (float i 0.0d0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for len1 = (length s1) + for s2 = (format nil "~A.0" i) + unless (and (> len1 4) + (string-equal s1 s2 :start1 0 :end1 (- len1 2)) + (eql (char s1 (- len1 1)) #\0) + (member (char s1 (- len1 2)) chars)) + collect (list type i f s1 s2))))))) nil) (deftest print.double-float.4 (let ((chars *possible-double-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) - nconc - (and (not (subtypep 'double-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0d0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars))) - collect (list type i f s1 s2))))))) + nconc + (and (not (subtypep 'double-float type)) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*read-default-float-format* type)) + (loop for i = (- (random 20000000) 10000000) + for f = (float i 0.0d0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for len1 = (length s1) + for s2 = (format nil "~A.0" i) + repeat 10000 + unless (or (/= i (rational f)) ;; not enough bits + ;; (> (nth-value 1 (integer-decode-float f)) 0) + (and (> len1 4) + (string-equal s1 s2 :start1 0 :end1 (- len1 2)) + (eql (char s1 (- len1 1)) #\0) + (member (char s1 (- len1 2)) chars))) + collect (list type i f s1 s2))))))) nil) (deftest print.double-float.random (let ((lower-bound (if (< (log least-positive-double-float 10) -100) - (expt 0.1d0 100) - least-positive-double-float)) - (upper-bound (/ (if (> (log most-positive-double-float 10) 100) - (expt 10.0d0 100) - most-positive-double-float) - 10))) + (expt 0.1d0 100) + least-positive-double-float)) + (upper-bound (/ (if (> (log most-positive-double-float 10) 100) + (expt 10.0d0 100) + most-positive-double-float) + 10))) (loop for f = lower-bound then (* 10 f) - while (< f upper-bound) - nconc - (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0d0)) - for y = (if (coin) (- x) x) - repeat 10 - nconc (randomly-check-readability y)))) + while (< f upper-bound) + nconc + (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0d0)) + for y = (if (coin) (- x) x) + repeat 10 + nconc (randomly-check-readability y)))) nil) ;;; long float @@ -295,92 +295,92 @@ (deftest print.long-float.1 (with-standard-io-syntax (let ((*print-readably* nil) - (*read-default-float-format* 'long-float)) + (*read-default-float-format* 'long-float)) (loop for i from -4000 to 4000 - for f = (float i 0.0l0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - unless (equalp s1 s2) - collect (list i f s1 s2)))) + for f = (float i 0.0l0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for s2 = (format nil "~A.0" i) + unless (equalp s1 s2) + collect (list i f s1 s2)))) nil) (deftest print.long-float.2 (with-standard-io-syntax (let ((*print-readably* nil) - (*read-default-float-format* 'long-float)) + (*read-default-float-format* 'long-float)) (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0l0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (equalp s1 s2)) - collect (list i f s1 s2)))) + for f = (float i 0.0l0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for s2 = (format nil "~A.0" i) + repeat 10000 + unless (or (/= i (rational f)) ;; not enough bits + ;; (> (nth-value 1 (integer-decode-float f)) 0) + (equalp s1 s2)) + collect (list i f s1 s2)))) nil) (defparameter *possible-long-float-exponent-markers* (loop for type in '(short-float single-float double-float long-float) - for c across "SFDL" - when (subtypep 'long-float type) - nconc (list c (char-downcase c)))) + for c across "SFDL" + when (subtypep 'long-float type) + nconc (list c (char-downcase c)))) (deftest print.long-float.3 (let ((chars *possible-long-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) - nconc - (and (not (subtypep 'long-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i from -4000 to 4000 - for f = (float i 0.0l0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - unless (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars)) - collect (list type i f s1 s2))))))) + nconc + (and (not (subtypep 'long-float type)) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*read-default-float-format* type)) + (loop for i from -4000 to 4000 + for f = (float i 0.0l0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for len1 = (length s1) + for s2 = (format nil "~A.0" i) + unless (and (> len1 4) + (string-equal s1 s2 :start1 0 :end1 (- len1 2)) + (eql (char s1 (- len1 1)) #\0) + (member (char s1 (- len1 2)) chars)) + collect (list type i f s1 s2))))))) nil) (deftest print.long-float.4 (let ((chars *possible-long-float-exponent-markers*)) (loop for type in '(short-float double-float long-float) - nconc - (and (not (subtypep 'long-float type)) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*read-default-float-format* type)) - (loop for i = (- (random 20000000) 10000000) - for f = (float i 0.0l0) - for s1 = (with-output-to-string (s) (prin1 f s)) - for len1 = (length s1) - for s2 = (format nil "~A.0" i) - repeat 10000 - unless (or (/= i (rational f)) ;; not enough bits - ;; (> (nth-value 1 (integer-decode-float f)) 0) - (and (> len1 4) - (string-equal s1 s2 :start1 0 :end1 (- len1 2)) - (eql (char s1 (- len1 1)) #\0) - (member (char s1 (- len1 2)) chars))) - collect (list type i f s1 s2))))))) + nconc + (and (not (subtypep 'long-float type)) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*read-default-float-format* type)) + (loop for i = (- (random 20000000) 10000000) + for f = (float i 0.0l0) + for s1 = (with-output-to-string (s) (prin1 f s)) + for len1 = (length s1) + for s2 = (format nil "~A.0" i) + repeat 10000 + unless (or (/= i (rational f)) ;; not enough bits + ;; (> (nth-value 1 (integer-decode-float f)) 0) + (and (> len1 4) + (string-equal s1 s2 :start1 0 :end1 (- len1 2)) + (eql (char s1 (- len1 1)) #\0) + (member (char s1 (- len1 2)) chars))) + collect (list type i f s1 s2))))))) nil) (deftest print.long-float.random (let ((lower-bound (if (< (log least-positive-long-float 10) -100) - (expt 0.1l0 100) - least-positive-long-float)) - (upper-bound (/ (if (> (log most-positive-long-float 10) 100) - (expt 10.0l0 100) - most-positive-long-float) - 10))) + (expt 0.1l0 100) + least-positive-long-float)) + (upper-bound (/ (if (> (log most-positive-long-float 10) 100) + (expt 10.0l0 100) + most-positive-long-float) + 10))) (loop for f = lower-bound then (* 10 f) - while (< f upper-bound) - nconc - (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0l0)) - for y = (if (coin) (- x) x) - repeat 10 - nconc (randomly-check-readability y)))) - nil) \ No newline at end of file + while (< f upper-bound) + nconc + (loop for x = (handler-case (random f) (arithmetic-error (c) 0.0l0)) + for y = (if (coin) (- x) x) + repeat 10 + nconc (randomly-check-readability y)))) + nil) diff --git a/ansi-tests/print-integers.lsp b/ansi-tests/print-integers.lsp index 8d5e49dc..aa62498e 100644 --- a/ansi-tests/print-integers.lsp +++ b/ansi-tests/print-integers.lsp @@ -269,59 +269,59 @@ (deftest print.integers.base.various.1 (with-standard-io-syntax (loop for b from 2 to 36 - nconc - (let ((*print-base* b) (*read-base* b)) - (loop for i from 1 to 100 - for n = (expt b i) - for str = (with-output-to-string (s) (prin1 n s)) - for result = (read-from-string str) - unless (= n result) - collect (list b i n str result))))) + nconc + (let ((*print-base* b) (*read-base* b)) + (loop for i from 1 to 100 + for n = (expt b i) + for str = (with-output-to-string (s) (prin1 n s)) + for result = (read-from-string str) + unless (= n result) + collect (list b i n str result))))) nil) (deftest print.integers.base.various.2 (with-standard-io-syntax (loop for b from 2 to 36 - nconc - (let ((*print-base* b) (*read-base* b)) - (loop for i from 1 to 100 - for n = (- (expt b i)) - for str = (with-output-to-string (s) (prin1 n s)) - for result = (read-from-string str) - unless (= n result) - collect (list b i n str result))))) + nconc + (let ((*print-base* b) (*read-base* b)) + (loop for i from 1 to 100 + for n = (- (expt b i)) + for str = (with-output-to-string (s) (prin1 n s)) + for result = (read-from-string str) + unless (= n result) + collect (list b i n str result))))) nil) (deftest print.integers.base.various.3 (with-standard-io-syntax (loop for b from 2 to 36 - nconc - (let ((*print-base* b) (*read-base* b) (*print-radix* t)) - (loop for i from 1 to 100 - for n = (expt b i) - for str = (with-output-to-string (s) (prin1 n s)) - for result = (read-from-string str) - unless (= n result) - collect (list b i n str result))))) + nconc + (let ((*print-base* b) (*read-base* b) (*print-radix* t)) + (loop for i from 1 to 100 + for n = (expt b i) + for str = (with-output-to-string (s) (prin1 n s)) + for result = (read-from-string str) + unless (= n result) + collect (list b i n str result))))) nil) (deftest print.integers.base.various.4 (with-standard-io-syntax (loop for b from 2 to 36 - nconc - (let ((*print-base* b) (*read-base* b) (*print-radix* t)) - (loop for i from 1 to 100 - for n = (- (expt b i)) - for str = (with-output-to-string (s) (prin1 n s)) - for result = (read-from-string str) - unless (= n result) - collect (list b i n str result))))) - nil) + nconc + (let ((*print-base* b) (*read-base* b) (*print-radix* t)) + (loop for i from 1 to 100 + for n = (- (expt b i)) + for str = (with-output-to-string (s) (prin1 n s)) + for result = (read-from-string str) + unless (= n result) + collect (list b i n str result))))) + nil) (deftest print.integers.random.1 (loop for numbits = (random 40) - for bound = (ash 1 numbits) - for r = (- (random (+ bound bound)) bound) - repeat 10000 - nconc (randomly-check-readability r)) + for bound = (ash 1 numbits) + for r = (- (random (+ bound bound)) bound) + repeat 10000 + nconc (randomly-check-readability r)) nil) diff --git a/ansi-tests/print-length.lsp b/ansi-tests/print-length.lsp index 645c2042..b513d40d 100644 --- a/ansi-tests/print-length.lsp +++ b/ansi-tests/print-length.lsp @@ -31,15 +31,15 @@ (let ((x '(|A| |B| |C| |D| |E| |F|))) (with-standard-io-syntax (let ((*print-case* :upcase) - (*print-escape* nil) - (*print-readably* nil) - (*print-pretty* nil) - (*print-length* nil)) + (*print-escape* nil) + (*print-readably* nil) + (*print-pretty* nil) + (*print-length* nil)) (apply - #'values - (loop for i from 0 to 8 - collect (let ((*print-length* i)) - (write-to-string x))))))) + #'values + (loop for i from 0 to 8 + collect (let ((*print-length* i)) + (write-to-string x))))))) "(...)" "(A ...)" "(A B ...)" @@ -54,15 +54,15 @@ (let ((x '(|A| |B| |C| |D| |E| |F| . |G|))) (with-standard-io-syntax (let ((*print-case* :upcase) - (*print-escape* nil) - (*print-readably* nil) - (*print-pretty* nil) - (*print-length* nil)) + (*print-escape* nil) + (*print-readably* nil) + (*print-pretty* nil) + (*print-length* nil)) (apply - #'values - (loop for i from 0 to 8 - collect (let ((*print-length* i)) - (write-to-string x))))))) + #'values + (loop for i from 0 to 8 + collect (let ((*print-length* i)) + (write-to-string x))))))) "(...)" "(A ...)" "(A B ...)" @@ -82,15 +82,15 @@ (let ((x #(|A| |B| |C| |D| |E| |F|))) (with-standard-io-syntax (let ((*print-case* :upcase) - (*print-escape* nil) - (*print-readably* nil) - (*print-pretty* nil) - (*print-length* nil)) + (*print-escape* nil) + (*print-readably* nil) + (*print-pretty* nil) + (*print-length* nil)) (apply - #'values - (loop for i from 0 to 8 - collect (let ((*print-length* i)) - (write-to-string x))))))) + #'values + (loop for i from 0 to 8 + collect (let ((*print-length* i)) + (write-to-string x))))))) "#(...)" "#(A ...)" "#(A B ...)" @@ -117,31 +117,31 @@ (deftest print-length.11 (let ((result - (with-standard-io-syntax - (let ((*print-case* :upcase) - (*print-escape* nil) - (*print-readably* nil) - (*print-pretty* nil) - (*print-length* nil) - (*package* (find-package "CL-TEST")) - (s (make-print-length-struct :foo 17))) - (apply - #'list - (loop for i from 0 to 4 - collect (let ((*print-length* i)) - (write-to-string s)))))))) + (with-standard-io-syntax + (let ((*print-case* :upcase) + (*print-escape* nil) + (*print-readably* nil) + (*print-pretty* nil) + (*print-length* nil) + (*package* (find-package "CL-TEST")) + (s (make-print-length-struct :foo 17))) + (apply + #'list + (loop for i from 0 to 4 + collect (let ((*print-length* i)) + (write-to-string s)))))))) (if (member result - '(("#S(...)" - "#S(PRINT-LENGTH-STRUCT ...)" - "#S(PRINT-LENGTH-STRUCT :FOO ...)" - "#S(PRINT-LENGTH-STRUCT :FOO 17)" - "#S(PRINT-LENGTH-STRUCT :FOO 17)") - ("#S(PRINT-LENGTH-STRUCT ...)" - "#S(PRINT-LENGTH-STRUCT :FOO 17)" - "#S(PRINT-LENGTH-STRUCT :FOO 17)" - "#S(PRINT-LENGTH-STRUCT :FOO 17)" - "#S(PRINT-LENGTH-STRUCT :FOO 17)")) - :test 'equal) - :good + '(("#S(...)" + "#S(PRINT-LENGTH-STRUCT ...)" + "#S(PRINT-LENGTH-STRUCT :FOO ...)" + "#S(PRINT-LENGTH-STRUCT :FOO 17)" + "#S(PRINT-LENGTH-STRUCT :FOO 17)") + ("#S(PRINT-LENGTH-STRUCT ...)" + "#S(PRINT-LENGTH-STRUCT :FOO 17)" + "#S(PRINT-LENGTH-STRUCT :FOO 17)" + "#S(PRINT-LENGTH-STRUCT :FOO 17)" + "#S(PRINT-LENGTH-STRUCT :FOO 17)")) + :test 'equal) + :good result)) :good) diff --git a/ansi-tests/print-level.lsp b/ansi-tests/print-level.lsp index 04f9e6bf..841af68e 100644 --- a/ansi-tests/print-level.lsp +++ b/ansi-tests/print-level.lsp @@ -12,15 +12,15 @@ (with-standard-io-syntax (let ((*print-readably* nil)) (loop for x in *mini-universe* - for s1 = (write-to-string x) - for s2 = (let ((*print-level* 0)) (write-to-string x)) - when (and (or (consp x) - (and (arrayp x) - (not (stringp x)) - (not (typep x 'bit-vector))) - (typep (class-of x) 'structure-class)) - (not (string= s2 "#"))) - collect (list x s1 s2)))) + for s1 = (write-to-string x) + for s2 = (let ((*print-level* 0)) (write-to-string x)) + when (and (or (consp x) + (and (arrayp x) + (not (stringp x)) + (not (typep x 'bit-vector))) + (typep (class-of x) 'structure-class)) + (not (string= s2 "#"))) + collect (list x s1 s2)))) nil) |# @@ -34,34 +34,34 @@ (deftest print-level.2 (with-standard-io-syntax (write-to-string (make-instance 'print-level-test-class) - :level 0 - :readably nil)) + :level 0 + :readably nil)) "#") |# (deftest print-level.3 (with-standard-io-syntax (write-to-string (make-array '(4) :initial-contents '(a b c d)) - :readably nil - :array t - :level 0)) + :readably nil + :array t + :level 0)) "#") (deftest print-level.4 (with-standard-io-syntax (write-to-string (make-array '(4) :initial-contents '(1 1 0 1) - :element-type 'bit) - :readably nil - :array t - :level 0)) + :element-type 'bit) + :readably nil + :array t + :level 0)) "#*1101") (deftest print-level.5 (with-standard-io-syntax (write-to-string "abcd" - :readably nil - :array t - :level 0)) + :readably nil + :array t + :level 0)) "\"abcd\"") (define-condition print-level-condition (condition) (a b c)) @@ -70,13 +70,13 @@ (deftest print-level.6 (with-standard-io-syntax (write-to-string (make-condition 'print-level-condition) - :level 0 :pretty nil :readably nil)) + :level 0 :pretty nil :readably nil)) "#") (deftest print-level.7 (with-standard-io-syntax (write-to-string (make-condition 'print-level-condition) - :level 0 :pretty t :readably nil)) + :level 0 :pretty t :readably nil)) "#") |# @@ -85,8 +85,8 @@ (deftest print-level.8 (with-standard-io-syntax (let* ((*package* (find-package "CL-TEST")) - (*print-pretty* nil) - (s (make-print-level-struct))) + (*print-pretty* nil) + (s (make-print-level-struct))) (values (write-to-string s :level 0 :readably nil) (write-to-string s :level 1 :readably nil) @@ -99,8 +99,8 @@ (deftest print-level.9 (with-standard-io-syntax (let* ((*package* (find-package "CL-TEST")) - (*print-pretty* t) - (s (make-print-level-struct))) + (*print-pretty* t) + (s (make-print-level-struct))) (values (write-to-string s :level 0 :readably nil) (write-to-string s :level 1 :readably nil) @@ -117,14 +117,14 @@ (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (write-to-string (make-print-level-struct2) - :level 0 :pretty nil :readably nil))) + :level 0 :pretty nil :readably nil))) "#") (deftest print-level.11 (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (write-to-string (make-print-level-struct2) - :level 0 :pretty t :readably nil))) + :level 0 :pretty t :readably nil))) "#") |# diff --git a/ansi-tests/print-lines.lsp b/ansi-tests/print-lines.lsp index 211e95bf..91d9d1a0 100644 --- a/ansi-tests/print-lines.lsp +++ b/ansi-tests/print-lines.lsp @@ -14,21 +14,21 @@ (deftest print-lines.2 (with-standard-io-syntax (let ((*print-lines* 1) - (*print-readably* nil) - (*print-miser-width* nil) - (*print-pprint-dispatch* (copy-pprint-dispatch))) + (*print-readably* nil) + (*print-miser-width* nil) + (*print-pprint-dispatch* (copy-pprint-dispatch))) (set-pprint-dispatch '(cons (eql 1) t) 'pprint-fill) (apply #'values (loop for i from 1 to 10 - collect - (let ((*print-right-margin* i)) - (subseq - (with-output-to-string - (*standard-output*) - (terpri) - (pprint '(1 2 3 4 5 6 7 8 9))) - 2)))))) + collect + (let ((*print-right-margin* i)) + (subseq + (with-output-to-string + (*standard-output*) + (terpri) + (pprint '(1 2 3 4 5 6 7 8 9))) + 2)))))) "(1 ..)" "(1 ..)" "(1 ..)" diff --git a/ansi-tests/print-pathname.lsp b/ansi-tests/print-pathname.lsp index 7393e150..6baa9825 100644 --- a/ansi-tests/print-pathname.lsp +++ b/ansi-tests/print-pathname.lsp @@ -9,27 +9,27 @@ (deftest print.pathname.1 (loop for p in *universe* - when (typep p 'pathname) - nconc - (loop repeat 10 - nconc (randomly-check-readability p :test #'is-similar - :can-fail t))) + when (typep p 'pathname) + nconc + (loop repeat 10 + nconc (randomly-check-readability p :test #'is-similar + :can-fail t))) nil) (deftest print.pathname.2 (loop for p in *universe* - when (typep p 'pathname) - nconc - (let ((ns (ignore-errors (namestring p)))) - "Read 22.1.3.11 before commenting on this test" - (when ns - (let ((expected-result + when (typep p 'pathname) + nconc + (let ((ns (ignore-errors (namestring p)))) + "Read 22.1.3.11 before commenting on this test" + (when ns + (let ((expected-result (concatenate 'string "#P" (with-standard-io-syntax - (write-to-string ns :readably nil - :escape t)))) - (result (with-standard-io-syntax - (write-to-string p :readably nil :escape t)))) - (unless (string= expected-result result) - (list (list expected-result result))))))) + (write-to-string ns :readably nil + :escape t)))) + (result (with-standard-io-syntax + (write-to-string p :readably nil :escape t)))) + (unless (string= expected-result result) + (list (list expected-result result))))))) nil) diff --git a/ansi-tests/print-random-state.lsp b/ansi-tests/print-random-state.lsp index 0b7f407b..5ba76963 100644 --- a/ansi-tests/print-random-state.lsp +++ b/ansi-tests/print-random-state.lsp @@ -9,13 +9,13 @@ (deftest print.random-state.1 (loop repeat 100 - do (loop repeat 50 do (random 1000)) - nconc - (let* ((rs1 (make-random-state *random-state*)) - (rs2 (with-standard-io-syntax - (read-from-string - (write-to-string rs1 :readably t)))) - (result (list (notnot (random-state-p rs2)) - (is-similar rs1 rs2)))) - (unless (equal result '(t t)) (list result rs1 rs2)))) + do (loop repeat 50 do (random 1000)) + nconc + (let* ((rs1 (make-random-state *random-state*)) + (rs2 (with-standard-io-syntax + (read-from-string + (write-to-string rs1 :readably t)))) + (result (list (notnot (random-state-p rs2)) + (is-similar rs1 rs2)))) + (unless (equal result '(t t)) (list result rs1 rs2)))) nil) diff --git a/ansi-tests/print-ratios.lsp b/ansi-tests/print-ratios.lsp index ef34c4df..4d42c6c2 100644 --- a/ansi-tests/print-ratios.lsp +++ b/ansi-tests/print-ratios.lsp @@ -9,11 +9,11 @@ (deftest print.ratios.random (loop for i from 1 to 1000 - for numbits = (1+ (random 40)) - for bound = (ash 1 numbits) - for num = (- (random (+ bound bound)) bound) - for denom = (1+ (random bound)) - for r = (/ num denom) - nconc (randomly-check-readability r)) + for numbits = (1+ (random 40)) + for bound = (ash 1 numbits) + for num = (- (random (+ bound bound)) bound) + for denom = (1+ (random bound)) + for r = (/ num denom) + nconc (randomly-check-readability r)) nil) diff --git a/ansi-tests/print-strings.lsp b/ansi-tests/print-strings.lsp index c021924c..0c8ba3eb 100644 --- a/ansi-tests/print-strings.lsp +++ b/ansi-tests/print-strings.lsp @@ -15,31 +15,31 @@ (deftest print.string.2 (with-standard-io-syntax (loop for c across +standard-chars+ - for s1 = (string c) - for s2 = (write-to-string s1 :escape nil :readably nil) - unless (string= s1 s2) - collect (list c s1 s2))) + for s1 = (string c) + for s2 = (write-to-string s1 :escape nil :readably nil) + unless (string= s1 s2) + collect (list c s1 s2))) nil) (deftest print.string.3 (with-standard-io-syntax (loop for i below 256 - for c = (code-char i) - when c - nconc - (let* ((s1 (string c)) - (s2 (write-to-string s1 :escape nil :readably nil))) - (unless (string= s1 s2) - (list (list c s1 s2)))))) + for c = (code-char i) + when c + nconc + (let* ((s1 (string c)) + (s2 (write-to-string s1 :escape nil :readably nil))) + (unless (string= s1 s2) + (list (list c s1 s2)))))) nil) (deftest print.string.4 (with-standard-io-syntax (loop for c across +standard-chars+ - for s1 = (string c) - for s2 = (write-to-string s1 :escape t :readably nil) - unless (or (find c "\"\\") (string= (concatenate 'string "\"" s1 "\"") s2)) - collect (list c s1 s2))) + for s1 = (string c) + for s2 = (write-to-string s1 :escape t :readably nil) + unless (or (find c "\"\\") (string= (concatenate 'string "\"" s1 "\"") s2)) + collect (list c s1 s2))) nil) (deftest print.string.5 @@ -57,65 +57,65 @@ (deftest print.string.7 (with-standard-io-syntax (loop for s1 in (remove-if-not #'stringp *universe*) - for s2 = (write-to-string s1 :escape nil :readably nil) - for s3 = (write-to-string s1 :array t :escape nil :readably nil) - unless (string= s2 s3) - collect (list s1 s2 s3))) + for s2 = (write-to-string s1 :escape nil :readably nil) + for s3 = (write-to-string s1 :array t :escape nil :readably nil) + unless (string= s2 s3) + collect (list s1 s2 s3))) nil) (deftest print.string.8 (with-standard-io-syntax (loop for s1 in (remove-if-not #'stringp *universe*) - for s2 = (write-to-string s1 :escape t :readably nil) - for s3 = (write-to-string s1 :array t :escape t :readably nil) - unless (string= s2 s3) - collect (list s1 s2 s3))) + for s2 = (write-to-string s1 :escape t :readably nil) + for s3 = (write-to-string s1 :array t :escape t :readably nil) + unless (string= s2 s3) + collect (list s1 s2 s3))) nil) ;;; Only active elements of the string are printed (deftest print.string.9 (let* ((s (make-array '(10) :fill-pointer 5 :element-type 'character - :initial-contents "abcdefghij")) - (result - (with-standard-io-syntax - (write-to-string s :escape nil :readably nil)))) + :initial-contents "abcdefghij")) + (result + (with-standard-io-syntax + (write-to-string s :escape nil :readably nil)))) (or (and (string= result "abcde") t) - result)) + result)) t) (deftest print.string.10 (let* ((s (make-array '(10) :fill-pointer 5 :element-type 'character - :initial-contents "aBcDefGHij")) - (result - (with-standard-io-syntax - (write-to-string s :escape t :readably nil)))) + :initial-contents "aBcDefGHij")) + (result + (with-standard-io-syntax + (write-to-string s :escape t :readably nil)))) (or (and (string= result "\"aBcDe\"") t) - result)) + result)) t) (deftest print.string.11 (let* ((s (make-array '(8) :element-type 'base-char - :initial-contents "abcdefgh" - :adjustable t)) - (result - (with-standard-io-syntax - (write-to-string s :escape t :readably nil)))) + :initial-contents "abcdefgh" + :adjustable t)) + (result + (with-standard-io-syntax + (write-to-string s :escape t :readably nil)))) (or (and (string= result "\"abcdefgh\"") t) - result)) + result)) t) (deftest print.string.12 (let* ((s1 (make-array '(8) :element-type 'character - :initial-contents "abcdefgh")) - (s2 (make-array '(4) :element-type 'character - :displaced-to s1 - :displaced-index-offset 2)) - (result - (with-standard-io-syntax - (write-to-string s2 :escape t :readably nil)))) + :initial-contents "abcdefgh")) + (s2 (make-array '(4) :element-type 'character + :displaced-to s1 + :displaced-index-offset 2)) + (result + (with-standard-io-syntax + (write-to-string s2 :escape t :readably nil)))) (or (and (string= result "\"cdef\"") t) - result)) + result)) t) ;;; *print-array* should not affect string printing @@ -124,7 +124,7 @@ (with-standard-io-syntax (write-to-string "1234" :array nil :readably nil :escape t)) "\"1234\"") - + ;;; The ever-popular nil string @@ -146,10 +146,10 @@ (deftest print.string.random.1 (trim-list (loop for len = (1+ (random 5)) - for s = (coerce (loop repeat len - collect (random-from-seq +standard-chars+)) - 'string) - repeat 1000 - append (randomly-check-readability s)) + for s = (coerce (loop repeat len + collect (random-from-seq +standard-chars+)) + 'string) + repeat 1000 + append (randomly-check-readability s)) 10) nil) diff --git a/ansi-tests/print-structure.lsp b/ansi-tests/print-structure.lsp index 0f68fdfb..d3b15927 100644 --- a/ansi-tests/print-structure.lsp +++ b/ansi-tests/print-structure.lsp @@ -15,22 +15,22 @@ (with-standard-io-syntax (let ((*package* (find-package "CL-TEST"))) (let ((str (write-to-string s :readably nil :case :upcase :escape nil))) - (assert (string= (subseq str 0 3) "#S(")) - (let ((vals (read-from-string (subseq str 2)))) - (assert (listp vals)) - (assert (= (length vals) 5)) - (assert (eq (car vals) 'print-struct-1)) - (assert (symbolp (cadr vals))) - (assert (symbolp (cadddr vals))) - (cond - ((string= (symbol-name (cadr vals)) "FOO") - (assert (string= (symbol-name (cadddr vals)) "BAR")) - (assert (= (caddr vals) 1)) - (assert (= (car (cddddr vals)) 2))) - (t - (assert (string= (symbol-name (cadr vals)) "BAR")) - (assert (string= (symbol-name (cadddr vals)) "FOO")) - (assert (= (caddr vals) 2)) - (assert (= (car (cddddr vals)) 1)))) - nil))))) + (assert (string= (subseq str 0 3) "#S(")) + (let ((vals (read-from-string (subseq str 2)))) + (assert (listp vals)) + (assert (= (length vals) 5)) + (assert (eq (car vals) 'print-struct-1)) + (assert (symbolp (cadr vals))) + (assert (symbolp (cadddr vals))) + (cond + ((string= (symbol-name (cadr vals)) "FOO") + (assert (string= (symbol-name (cadddr vals)) "BAR")) + (assert (= (caddr vals) 1)) + (assert (= (car (cddddr vals)) 2))) + (t + (assert (string= (symbol-name (cadr vals)) "BAR")) + (assert (string= (symbol-name (cadddr vals)) "FOO")) + (assert (= (caddr vals) 2)) + (assert (= (car (cddddr vals)) 1)))) + nil))))) nil) diff --git a/ansi-tests/print-symbols.lsp b/ansi-tests/print-symbols.lsp index f5bffcd9..401e7a6b 100644 --- a/ansi-tests/print-symbols.lsp +++ b/ansi-tests/print-symbols.lsp @@ -13,252 +13,252 @@ (setf (readtable-case *readtable*) case) (let ((str (with-output-to-string (s) (princ sym s)))) (or (equalt str expected) - (list str expected)))) + (list str expected)))) (defun prin1.symbol.fn (sym case *print-case* expected) (setf (readtable-case *readtable*) case) (let ((str (with-output-to-string (s) (prin1 sym s)))) (or (and (member str expected :test #'string=) t) - (list str expected)))) + (list str expected)))) (deftest print.symbol.1 (with-standard-io-syntax (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values - (%p '|XYZ| :upcase :upcase "XYZ") - (%p '|XYZ| :upcase :downcase "xyz") - (%p '|XYZ| :upcase :capitalize "Xyz") - (%p '|XYZ| :downcase :upcase "XYZ") - (%p '|XYZ| :downcase :downcase "XYZ") - (%p '|XYZ| :downcase :capitalize "XYZ") - (%p '|XYZ| :preserve :upcase "XYZ") - (%p '|XYZ| :preserve :downcase "XYZ") - (%p '|XYZ| :preserve :capitalize "XYZ") - (%p '|XYZ| :invert :upcase "xyz") - (%p '|XYZ| :invert :downcase "xyz") - (%p '|XYZ| :invert :capitalize "xyz"))))) + (%p '|XYZ| :upcase :upcase "XYZ") + (%p '|XYZ| :upcase :downcase "xyz") + (%p '|XYZ| :upcase :capitalize "Xyz") + (%p '|XYZ| :downcase :upcase "XYZ") + (%p '|XYZ| :downcase :downcase "XYZ") + (%p '|XYZ| :downcase :capitalize "XYZ") + (%p '|XYZ| :preserve :upcase "XYZ") + (%p '|XYZ| :preserve :downcase "XYZ") + (%p '|XYZ| :preserve :capitalize "XYZ") + (%p '|XYZ| :invert :upcase "xyz") + (%p '|XYZ| :invert :downcase "xyz") + (%p '|XYZ| :invert :capitalize "xyz"))))) t t t t t t t t t t t t) (deftest print.symbol.2 (with-standard-io-syntax (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values - (%p '|xyz| :upcase :upcase "xyz") - (%p '|xyz| :upcase :downcase "xyz") - (%p '|xyz| :upcase :capitalize "xyz") - (%p '|xyz| :downcase :upcase "XYZ") - (%p '|xyz| :downcase :downcase "xyz") - (%p '|xyz| :downcase :capitalize "Xyz") - (%p '|xyz| :preserve :upcase "xyz") - (%p '|xyz| :preserve :downcase "xyz") - (%p '|xyz| :preserve :capitalize "xyz") - (%p '|xyz| :invert :upcase "XYZ") - (%p '|xyz| :invert :downcase "XYZ") - (%p '|xyz| :invert :capitalize "XYZ"))))) + (%p '|xyz| :upcase :upcase "xyz") + (%p '|xyz| :upcase :downcase "xyz") + (%p '|xyz| :upcase :capitalize "xyz") + (%p '|xyz| :downcase :upcase "XYZ") + (%p '|xyz| :downcase :downcase "xyz") + (%p '|xyz| :downcase :capitalize "Xyz") + (%p '|xyz| :preserve :upcase "xyz") + (%p '|xyz| :preserve :downcase "xyz") + (%p '|xyz| :preserve :capitalize "xyz") + (%p '|xyz| :invert :upcase "XYZ") + (%p '|xyz| :invert :downcase "XYZ") + (%p '|xyz| :invert :capitalize "XYZ"))))) t t t t t t t t t t t t) (deftest print.symbol.3 (with-standard-io-syntax (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values - (%p '|Xyz| :upcase :upcase "Xyz") - (%p '|Xyz| :upcase :downcase "xyz") - (%p '|Xyz| :upcase :capitalize "Xyz") - (%p '|Xyz| :downcase :upcase "XYZ") - (%p '|Xyz| :downcase :downcase "Xyz") - (%p '|Xyz| :downcase :capitalize "Xyz") - (%p '|Xyz| :preserve :upcase "Xyz") - (%p '|Xyz| :preserve :downcase "Xyz") - (%p '|Xyz| :preserve :capitalize "Xyz") - (%p '|Xyz| :invert :upcase "Xyz") - (%p '|Xyz| :invert :downcase "Xyz") - (%p '|Xyz| :invert :capitalize "Xyz"))))) + (%p '|Xyz| :upcase :upcase "Xyz") + (%p '|Xyz| :upcase :downcase "xyz") + (%p '|Xyz| :upcase :capitalize "Xyz") + (%p '|Xyz| :downcase :upcase "XYZ") + (%p '|Xyz| :downcase :downcase "Xyz") + (%p '|Xyz| :downcase :capitalize "Xyz") + (%p '|Xyz| :preserve :upcase "Xyz") + (%p '|Xyz| :preserve :downcase "Xyz") + (%p '|Xyz| :preserve :capitalize "Xyz") + (%p '|Xyz| :invert :upcase "Xyz") + (%p '|Xyz| :invert :downcase "Xyz") + (%p '|Xyz| :invert :capitalize "Xyz"))))) t t t t t t t t t t t t) (deftest print.symbol.4 (with-standard-io-syntax (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values - (%p '|xYZ| :upcase :upcase "xYZ") - (%p '|xYZ| :upcase :downcase "xyz") - (%p '|xYZ| :upcase :capitalize "xyz") - (%p '|xYZ| :downcase :upcase "XYZ") - (%p '|xYZ| :downcase :downcase "xYZ") - (%p '|xYZ| :downcase :capitalize "XYZ") - (%p '|xYZ| :preserve :upcase "xYZ") - (%p '|xYZ| :preserve :downcase "xYZ") - (%p '|xYZ| :preserve :capitalize "xYZ") - (%p '|xYZ| :invert :upcase "xYZ") - (%p '|xYZ| :invert :downcase "xYZ") - (%p '|xYZ| :invert :capitalize "xYZ"))))) + (%p '|xYZ| :upcase :upcase "xYZ") + (%p '|xYZ| :upcase :downcase "xyz") + (%p '|xYZ| :upcase :capitalize "xyz") + (%p '|xYZ| :downcase :upcase "XYZ") + (%p '|xYZ| :downcase :downcase "xYZ") + (%p '|xYZ| :downcase :capitalize "XYZ") + (%p '|xYZ| :preserve :upcase "xYZ") + (%p '|xYZ| :preserve :downcase "xYZ") + (%p '|xYZ| :preserve :capitalize "xYZ") + (%p '|xYZ| :invert :upcase "xYZ") + (%p '|xYZ| :invert :downcase "xYZ") + (%p '|xYZ| :invert :capitalize "xYZ"))))) t t t t t t t t t t t t) (deftest print.symbol.5 (with-standard-io-syntax (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values - (%p '|X1Z| :upcase :upcase "X1Z") - (%p '|X1Z| :upcase :downcase "x1z") - (%p '|X1Z| :upcase :capitalize "X1z") - (%p '|X1Z| :downcase :upcase "X1Z") - (%p '|X1Z| :downcase :downcase "X1Z") - (%p '|X1Z| :downcase :capitalize "X1Z") - (%p '|X1Z| :preserve :upcase "X1Z") - (%p '|X1Z| :preserve :downcase "X1Z") - (%p '|X1Z| :preserve :capitalize "X1Z") - (%p '|X1Z| :invert :upcase "x1z") - (%p '|X1Z| :invert :downcase "x1z") - (%p '|X1Z| :invert :capitalize "x1z"))))) + (%p '|X1Z| :upcase :upcase "X1Z") + (%p '|X1Z| :upcase :downcase "x1z") + (%p '|X1Z| :upcase :capitalize "X1z") + (%p '|X1Z| :downcase :upcase "X1Z") + (%p '|X1Z| :downcase :downcase "X1Z") + (%p '|X1Z| :downcase :capitalize "X1Z") + (%p '|X1Z| :preserve :upcase "X1Z") + (%p '|X1Z| :preserve :downcase "X1Z") + (%p '|X1Z| :preserve :capitalize "X1Z") + (%p '|X1Z| :invert :upcase "x1z") + (%p '|X1Z| :invert :downcase "x1z") + (%p '|X1Z| :invert :capitalize "x1z"))))) t t t t t t t t t t t t) (deftest print.symbol.6 (with-standard-io-syntax (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values - (%p '|x1z| :upcase :upcase "x1z") - (%p '|x1z| :upcase :downcase "x1z") - (%p '|x1z| :upcase :capitalize "x1z") - (%p '|x1z| :downcase :upcase "X1Z") - (%p '|x1z| :downcase :downcase "x1z") - (%p '|x1z| :downcase :capitalize "X1z") - (%p '|x1z| :preserve :upcase "x1z") - (%p '|x1z| :preserve :downcase "x1z") - (%p '|x1z| :preserve :capitalize "x1z") - (%p '|x1z| :invert :upcase "X1Z") - (%p '|x1z| :invert :downcase "X1Z") - (%p '|x1z| :invert :capitalize "X1Z"))))) + (%p '|x1z| :upcase :upcase "x1z") + (%p '|x1z| :upcase :downcase "x1z") + (%p '|x1z| :upcase :capitalize "x1z") + (%p '|x1z| :downcase :upcase "X1Z") + (%p '|x1z| :downcase :downcase "x1z") + (%p '|x1z| :downcase :capitalize "X1z") + (%p '|x1z| :preserve :upcase "x1z") + (%p '|x1z| :preserve :downcase "x1z") + (%p '|x1z| :preserve :capitalize "x1z") + (%p '|x1z| :invert :upcase "X1Z") + (%p '|x1z| :invert :downcase "X1Z") + (%p '|x1z| :invert :capitalize "X1Z"))))) t t t t t t t t t t t t) (deftest print.symbol.7 (with-standard-io-syntax (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values - (%p '|X1z| :upcase :upcase "X1z") - (%p '|X1z| :upcase :downcase "x1z") - (%p '|X1z| :upcase :capitalize "X1z") - (%p '|X1z| :downcase :upcase "X1Z") - (%p '|X1z| :downcase :downcase "X1z") - (%p '|X1z| :downcase :capitalize "X1z") - (%p '|X1z| :preserve :upcase "X1z") - (%p '|X1z| :preserve :downcase "X1z") - (%p '|X1z| :preserve :capitalize "X1z") - (%p '|X1z| :invert :upcase "X1z") - (%p '|X1z| :invert :downcase "X1z") - (%p '|X1z| :invert :capitalize "X1z"))))) + (%p '|X1z| :upcase :upcase "X1z") + (%p '|X1z| :upcase :downcase "x1z") + (%p '|X1z| :upcase :capitalize "X1z") + (%p '|X1z| :downcase :upcase "X1Z") + (%p '|X1z| :downcase :downcase "X1z") + (%p '|X1z| :downcase :capitalize "X1z") + (%p '|X1z| :preserve :upcase "X1z") + (%p '|X1z| :preserve :downcase "X1z") + (%p '|X1z| :preserve :capitalize "X1z") + (%p '|X1z| :invert :upcase "X1z") + (%p '|X1z| :invert :downcase "X1z") + (%p '|X1z| :invert :capitalize "X1z"))))) t t t t t t t t t t t t) (deftest print.symbol.8 (with-standard-io-syntax (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values - (%p '|x1Z| :upcase :upcase "x1Z") - (%p '|x1Z| :upcase :downcase "x1z") - (%p '|x1Z| :upcase :capitalize "x1z") - (%p '|x1Z| :downcase :upcase "X1Z") - (%p '|x1Z| :downcase :downcase "x1Z") - (%p '|x1Z| :downcase :capitalize "X1Z") - (%p '|x1Z| :preserve :upcase "x1Z") - (%p '|x1Z| :preserve :downcase "x1Z") - (%p '|x1Z| :preserve :capitalize "x1Z") - (%p '|x1Z| :invert :upcase "x1Z") - (%p '|x1Z| :invert :downcase "x1Z") - (%p '|x1Z| :invert :capitalize "x1Z"))))) + (%p '|x1Z| :upcase :upcase "x1Z") + (%p '|x1Z| :upcase :downcase "x1z") + (%p '|x1Z| :upcase :capitalize "x1z") + (%p '|x1Z| :downcase :upcase "X1Z") + (%p '|x1Z| :downcase :downcase "x1Z") + (%p '|x1Z| :downcase :capitalize "X1Z") + (%p '|x1Z| :preserve :upcase "x1Z") + (%p '|x1Z| :preserve :downcase "x1Z") + (%p '|x1Z| :preserve :capitalize "x1Z") + (%p '|x1Z| :invert :upcase "x1Z") + (%p '|x1Z| :invert :downcase "x1Z") + (%p '|x1Z| :invert :capitalize "x1Z"))))) t t t t t t t t t t t t) (deftest print.symbol.9 (with-standard-io-syntax (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values - (%p '|X Z| :upcase :upcase "X Z") - (%p '|X Z| :upcase :downcase "x z") - (%p '|X Z| :upcase :capitalize "X Z") - (%p '|X Z| :downcase :upcase "X Z") - (%p '|X Z| :downcase :downcase "X Z") - (%p '|X Z| :downcase :capitalize "X Z") - (%p '|X Z| :preserve :upcase "X Z") - (%p '|X Z| :preserve :downcase "X Z") - (%p '|X Z| :preserve :capitalize "X Z") - (%p '|X Z| :invert :upcase "x z") - (%p '|X Z| :invert :downcase "x z") - (%p '|X Z| :invert :capitalize "x z"))))) + (%p '|X Z| :upcase :upcase "X Z") + (%p '|X Z| :upcase :downcase "x z") + (%p '|X Z| :upcase :capitalize "X Z") + (%p '|X Z| :downcase :upcase "X Z") + (%p '|X Z| :downcase :downcase "X Z") + (%p '|X Z| :downcase :capitalize "X Z") + (%p '|X Z| :preserve :upcase "X Z") + (%p '|X Z| :preserve :downcase "X Z") + (%p '|X Z| :preserve :capitalize "X Z") + (%p '|X Z| :invert :upcase "x z") + (%p '|X Z| :invert :downcase "x z") + (%p '|X Z| :invert :capitalize "x z"))))) t t t t t t t t t t t t) (deftest print.symbol.10 (with-standard-io-syntax (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values - (%p '|x z| :upcase :upcase "x z") - (%p '|x z| :upcase :downcase "x z") - (%p '|x z| :upcase :capitalize "x z") - (%p '|x z| :downcase :upcase "X Z") - (%p '|x z| :downcase :downcase "x z") - (%p '|x z| :downcase :capitalize "X Z") - (%p '|x z| :preserve :upcase "x z") - (%p '|x z| :preserve :downcase "x z") - (%p '|x z| :preserve :capitalize "x z") - (%p '|x z| :invert :upcase "X Z") - (%p '|x z| :invert :downcase "X Z") - (%p '|x z| :invert :capitalize "X Z"))))) + (%p '|x z| :upcase :upcase "x z") + (%p '|x z| :upcase :downcase "x z") + (%p '|x z| :upcase :capitalize "x z") + (%p '|x z| :downcase :upcase "X Z") + (%p '|x z| :downcase :downcase "x z") + (%p '|x z| :downcase :capitalize "X Z") + (%p '|x z| :preserve :upcase "x z") + (%p '|x z| :preserve :downcase "x z") + (%p '|x z| :preserve :capitalize "x z") + (%p '|x z| :invert :upcase "X Z") + (%p '|x z| :invert :downcase "X Z") + (%p '|x z| :invert :capitalize "X Z"))))) t t t t t t t t t t t t) (deftest print.symbol.11 (with-standard-io-syntax (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values - (%p '|X z| :upcase :upcase "X z") - (%p '|X z| :upcase :downcase "x z") - (%p '|X z| :upcase :capitalize "X z") - (%p '|X z| :downcase :upcase "X Z") - (%p '|X z| :downcase :downcase "X z") - (%p '|X z| :downcase :capitalize "X Z") - (%p '|X z| :preserve :upcase "X z") - (%p '|X z| :preserve :downcase "X z") - (%p '|X z| :preserve :capitalize "X z") - (%p '|X z| :invert :upcase "X z") - (%p '|X z| :invert :downcase "X z") - (%p '|X z| :invert :capitalize "X z"))))) + (%p '|X z| :upcase :upcase "X z") + (%p '|X z| :upcase :downcase "x z") + (%p '|X z| :upcase :capitalize "X z") + (%p '|X z| :downcase :upcase "X Z") + (%p '|X z| :downcase :downcase "X z") + (%p '|X z| :downcase :capitalize "X Z") + (%p '|X z| :preserve :upcase "X z") + (%p '|X z| :preserve :downcase "X z") + (%p '|X z| :preserve :capitalize "X z") + (%p '|X z| :invert :upcase "X z") + (%p '|X z| :invert :downcase "X z") + (%p '|X z| :invert :capitalize "X z"))))) t t t t t t t t t t t t) (deftest print.symbol.12 (with-standard-io-syntax (let ((*print-readably* nil) - (*readtable* (copy-readtable nil))) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'princ.symbol.fn args))) (values - (%p '|x Z| :upcase :upcase "x Z") - (%p '|x Z| :upcase :downcase "x z") - (%p '|x Z| :upcase :capitalize "x Z") - (%p '|x Z| :downcase :upcase "X Z") - (%p '|x Z| :downcase :downcase "x Z") - (%p '|x Z| :downcase :capitalize "X Z") - (%p '|x Z| :preserve :upcase "x Z") - (%p '|x Z| :preserve :downcase "x Z") - (%p '|x Z| :preserve :capitalize "x Z") - (%p '|x Z| :invert :upcase "x Z") - (%p '|x Z| :invert :downcase "x Z") - (%p '|x Z| :invert :capitalize "x Z"))))) + (%p '|x Z| :upcase :upcase "x Z") + (%p '|x Z| :upcase :downcase "x z") + (%p '|x Z| :upcase :capitalize "x Z") + (%p '|x Z| :downcase :upcase "X Z") + (%p '|x Z| :downcase :downcase "x Z") + (%p '|x Z| :downcase :capitalize "X Z") + (%p '|x Z| :preserve :upcase "x Z") + (%p '|x Z| :preserve :downcase "x Z") + (%p '|x Z| :preserve :capitalize "x Z") + (%p '|x Z| :invert :upcase "x Z") + (%p '|x Z| :invert :downcase "x Z") + (%p '|x Z| :invert :capitalize "x Z"))))) t t t t t t t t t t t t) ;;; Randomized printing tests @@ -268,13 +268,13 @@ (when (find-package pkg-name) (delete-package pkg-name)) (prog1 - (let ((*package* (make-package pkg-name))) - (trim-list - (loop for c across +standard-chars+ - nconc - (loop repeat 50 - nconc (randomly-check-readability (intern (string c))))) - 10)) + (let ((*package* (make-package pkg-name))) + (trim-list + (loop for c across +standard-chars+ + nconc + (loop repeat 50 + nconc (randomly-check-readability (intern (string c))))) + 10)) ;; (delete-package pkg-name) )) nil) @@ -284,56 +284,56 @@ (when (find-package pkg-name) (delete-package pkg-name)) (prog1 - (let ((*package* (make-package pkg-name)) - (count 0)) - (trim-list - (loop for c1 = (random-from-seq +standard-chars+) - for c2 = (random-from-seq +standard-chars+) - for string = (concatenate 'string (string c1) (string c2)) - for result = (randomly-check-readability (intern string)) - for tries from 1 to 10000 - when result do (incf count) - nconc result - when (= count 10) - collect (format nil "... ~A out of ~A, stopping test ..." - count tries) - while (< count 10)) - 10)) + (let ((*package* (make-package pkg-name)) + (count 0)) + (trim-list + (loop for c1 = (random-from-seq +standard-chars+) + for c2 = (random-from-seq +standard-chars+) + for string = (concatenate 'string (string c1) (string c2)) + for result = (randomly-check-readability (intern string)) + for tries from 1 to 10000 + when result do (incf count) + nconc result + when (= count 10) + collect (format nil "... ~A out of ~A, stopping test ..." + count tries) + while (< count 10)) + 10)) ;; (delete-package pkg-name) )) nil) (deftest print.symbol.random.3 (let ((count 0) - (symbols (make-array '(1000) :fill-pointer 0 :adjustable t))) + (symbols (make-array '(1000) :fill-pointer 0 :adjustable t))) ;; Find all symbols that have a home package, put into array SYMBOLS (do-all-symbols (s) (when (symbol-package s) - (vector-push-extend s symbols (array-dimension symbols 0)))) + (vector-push-extend s symbols (array-dimension symbols 0)))) (loop for i = (random (fill-pointer symbols)) - for s = (aref symbols i) - for tries from 1 to 10000 - for problem = (randomly-check-readability s) - nconc problem - when problem do (incf count) - while (< count 10))) + for s = (aref symbols i) + for tries from 1 to 10000 + for problem = (randomly-check-readability s) + nconc problem + when problem do (incf count) + while (< count 10))) nil) (deftest print.symbol.random.4 (let ((count 0) - (symbols (make-array '(1000) :fill-pointer 0 :adjustable t))) + (symbols (make-array '(1000) :fill-pointer 0 :adjustable t))) ;; Find all symbols that have a home package, put into array SYMBOLS (do-all-symbols (s) (when (symbol-package s) - (vector-push-extend s symbols (array-dimension symbols 0)))) + (vector-push-extend s symbols (array-dimension symbols 0)))) (loop for i = (random (fill-pointer symbols)) - for s = (aref symbols i) - for tries from 1 to 10000 - for problem = (let ((*package* (symbol-package s))) - (randomly-check-readability s)) - nconc problem - when problem do (incf count) - while (< count 10))) + for s = (aref symbols i) + for tries from 1 to 10000 + for problem = (let ((*package* (symbol-package s))) + (randomly-check-readability s)) + nconc problem + when problem do (incf count) + while (< count 10))) nil) ;;;; Tests of printing with escaping enabled @@ -341,67 +341,67 @@ (deftest prin1.symbol.1 (with-standard-io-syntax (let ((*print-readably* nil) - (*package* (find-package :cl-test)) - (*readtable* (copy-readtable nil))) + (*package* (find-package :cl-test)) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'prin1.symbol.fn args))) (values - (%p '|X| :upcase :upcase '("x" "X" "\\X" "|X|")) - (%p '|X| :upcase :downcase '("x" "X" "\\X" "|X|")) - (%p '|X| :upcase :capitalize '("x" "X" "\\X" "|X|")) - (%p '|X| :downcase :upcase '("\\X" "|X|")) - (%p '|X| :downcase :downcase '("\\X" "|X|")) - (%p '|X| :downcase :capitalize '("\\X" "|X|")) - (%p '|X| :preserve :upcase '("X" "\\X" "|X|")) - (%p '|X| :preserve :downcase '("X" "\\X" "|X|")) - (%p '|X| :preserve :capitalize '("X" "\\X" "|X|")) - (%p '|X| :invert :upcase '("x" "\\X" "|X|")) - (%p '|X| :invert :downcase '("x" "\\X" "|X|")) - (%p '|X| :invert :capitalize '("x" "\\X" "|X|")) - )))) + (%p '|X| :upcase :upcase '("x" "X" "\\X" "|X|")) + (%p '|X| :upcase :downcase '("x" "X" "\\X" "|X|")) + (%p '|X| :upcase :capitalize '("x" "X" "\\X" "|X|")) + (%p '|X| :downcase :upcase '("\\X" "|X|")) + (%p '|X| :downcase :downcase '("\\X" "|X|")) + (%p '|X| :downcase :capitalize '("\\X" "|X|")) + (%p '|X| :preserve :upcase '("X" "\\X" "|X|")) + (%p '|X| :preserve :downcase '("X" "\\X" "|X|")) + (%p '|X| :preserve :capitalize '("X" "\\X" "|X|")) + (%p '|X| :invert :upcase '("x" "\\X" "|X|")) + (%p '|X| :invert :downcase '("x" "\\X" "|X|")) + (%p '|X| :invert :capitalize '("x" "\\X" "|X|")) + )))) t t t t t t t t t t t t) (deftest prin1.symbol.2 (with-standard-io-syntax (let ((*print-readably* nil) - (*package* (find-package :cl-test)) - (*readtable* (copy-readtable nil))) + (*package* (find-package :cl-test)) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'prin1.symbol.fn args))) (values - (%p '|x| :upcase :upcase '("\\x" "|x|")) - (%p '|x| :upcase :downcase '("\\x" "|x|")) - (%p '|x| :upcase :capitalize '("\\x" "|x|")) - (%p '|x| :downcase :upcase '("x" "X" "\\x" "|x|")) - (%p '|x| :downcase :downcase '("x" "X" "\\x" "|x|")) - (%p '|x| :downcase :capitalize '("x" "X" "\\x" "|x|")) - (%p '|x| :preserve :upcase '("x" "\\x" "|x|")) - (%p '|x| :preserve :downcase '("x" "\\x" "|x|")) - (%p '|x| :preserve :capitalize '("x" "\\x" "|x|")) - (%p '|x| :invert :upcase '("X" "\\x" "|x|")) - (%p '|x| :invert :downcase '("X" "\\x" "|x|")) - (%p '|x| :invert :capitalize '("X" "\\x" "|x|")) - )))) + (%p '|x| :upcase :upcase '("\\x" "|x|")) + (%p '|x| :upcase :downcase '("\\x" "|x|")) + (%p '|x| :upcase :capitalize '("\\x" "|x|")) + (%p '|x| :downcase :upcase '("x" "X" "\\x" "|x|")) + (%p '|x| :downcase :downcase '("x" "X" "\\x" "|x|")) + (%p '|x| :downcase :capitalize '("x" "X" "\\x" "|x|")) + (%p '|x| :preserve :upcase '("x" "\\x" "|x|")) + (%p '|x| :preserve :downcase '("x" "\\x" "|x|")) + (%p '|x| :preserve :capitalize '("x" "\\x" "|x|")) + (%p '|x| :invert :upcase '("X" "\\x" "|x|")) + (%p '|x| :invert :downcase '("X" "\\x" "|x|")) + (%p '|x| :invert :capitalize '("X" "\\x" "|x|")) + )))) t t t t t t t t t t t t) (deftest prin1.symbol.3 (with-standard-io-syntax (let ((*print-readably* nil) - (*package* (find-package :cl-test)) - (*readtable* (copy-readtable nil))) + (*package* (find-package :cl-test)) + (*readtable* (copy-readtable nil))) (flet ((%p (&rest args) (apply #'prin1.symbol.fn args))) (values - (%p '|1| :upcase :upcase '("\\1" "|1|")) - (%p '|1| :upcase :downcase '("\\1" "|1|")) - (%p '|1| :upcase :capitalize '("\\1" "|1|")) - (%p '|1| :downcase :upcase '("1" "\\1" "|1|")) - (%p '|1| :downcase :downcase '("1" "\\1" "|1|")) - (%p '|1| :downcase :capitalize '("1" "\\1" "|1|")) - (%p '|1| :preserve :upcase '("1" "\\1" "|1|")) - (%p '|1| :preserve :downcase '("1" "\\1" "|1|")) - (%p '|1| :preserve :capitalize '("1" "\\1" "|1|")) - (%p '|1| :invert :upcase '("1" "\\1" "|1|")) - (%p '|1| :invert :downcase '("1" "\\1" "|1|")) - (%p '|1| :invert :capitalize '("1" "\\1" "|1|")) - )))) + (%p '|1| :upcase :upcase '("\\1" "|1|")) + (%p '|1| :upcase :downcase '("\\1" "|1|")) + (%p '|1| :upcase :capitalize '("\\1" "|1|")) + (%p '|1| :downcase :upcase '("1" "\\1" "|1|")) + (%p '|1| :downcase :downcase '("1" "\\1" "|1|")) + (%p '|1| :downcase :capitalize '("1" "\\1" "|1|")) + (%p '|1| :preserve :upcase '("1" "\\1" "|1|")) + (%p '|1| :preserve :downcase '("1" "\\1" "|1|")) + (%p '|1| :preserve :capitalize '("1" "\\1" "|1|")) + (%p '|1| :invert :upcase '("1" "\\1" "|1|")) + (%p '|1| :invert :downcase '("1" "\\1" "|1|")) + (%p '|1| :invert :capitalize '("1" "\\1" "|1|")) + )))) t t t t t t t t t t t t) ;;; Random symbol printing tests when *print-escape* is true @@ -415,33 +415,33 @@ (when (find-package pkg-name) (delete-package pkg-name)) (prog1 - (let ((*package* (make-package pkg-name)) - (result - (loop for c across +standard-chars+ - for s = (intern (string c)) - append - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t))))) - (subseq result 0 (min (length result) 10))) + (let ((*package* (make-package pkg-name)) + (result + (loop for c across +standard-chars+ + for s = (intern (string c)) + append + (loop repeat 50 + nconc (randomly-check-readability + s + :readable nil + :escape t))))) + (subseq result 0 (min (length result) 10))) ;; (delete-package pkg-name) )) nil) (deftest print.symbol.escaped-random.2 (let ((result - (loop for c across +standard-chars+ - for s = (make-symbol (string c)) - nconc - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t - :gensym t - :test #'similar-uninterned-symbols))))) + (loop for c across +standard-chars+ + for s = (make-symbol (string c)) + nconc + (loop repeat 50 + nconc (randomly-check-readability + s + :readable nil + :escape t + :gensym t + :test #'similar-uninterned-symbols))))) (subseq result 0 (min (length result) 10))) nil) @@ -450,99 +450,99 @@ (when (find-package pkg-name) (delete-package pkg-name)) (prog1 - (let ((*package* (make-package pkg-name)) - (result - (loop for i below 256 - for c = (code-char i) - when c - nconc - (let ((s (intern (string c)))) - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t)))))) - (subseq result 0 (min (length result) 10))) + (let ((*package* (make-package pkg-name)) + (result + (loop for i below 256 + for c = (code-char i) + when c + nconc + (let ((s (intern (string c)))) + (loop repeat 50 + nconc (randomly-check-readability + s + :readable nil + :escape t)))))) + (subseq result 0 (min (length result) 10))) ;; (delete-package pkg-name) )) nil) - + (deftest print.symbol.escaped-random.4 (let ((result - (loop for i below 256 - for c = (code-char i) - when c - nconc - (let ((s (make-symbol (string c)))) - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t - :gensym t - :test #'similar-uninterned-symbols)))))) + (loop for i below 256 + for c = (code-char i) + when c + nconc + (let ((s (make-symbol (string c)))) + (loop repeat 50 + nconc (randomly-check-readability + s + :readable nil + :escape t + :gensym t + :test #'similar-uninterned-symbols)))))) (subseq result 0 (min (length result) 10))) nil) (deftest print.symbol.escaped-random.5 (loop for s in *universe* - when (and (symbolp s) (symbol-package s) ) - nconc - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t))) + when (and (symbolp s) (symbol-package s) ) + nconc + (loop repeat 50 + nconc (randomly-check-readability + s + :readable nil + :escape t))) nil) (deftest print.symbol.escaped-random.6 (let ((*package* (find-package "KEYWORD"))) (loop for s in *universe* - when (and (symbolp s) (symbol-package s)) - nconc - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t)))) + when (and (symbolp s) (symbol-package s)) + nconc + (loop repeat 50 + nconc (randomly-check-readability + s + :readable nil + :escape t)))) nil) (deftest print.symbol.escaped-random.7 (loop for s in *universe* - when (and (symbolp s) (not (symbol-package s))) - nconc - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t - :gensym t - :test #'similar-uninterned-symbols))) - nil) - + when (and (symbolp s) (not (symbol-package s))) + nconc + (loop repeat 50 + nconc (randomly-check-readability + s + :readable nil + :escape t + :gensym t + :test #'similar-uninterned-symbols))) + nil) + (deftest print.symbol.escaped-random.8 (let ((*package* (find-package "KEYWORD"))) (loop for s in *universe* - when (and (symbolp s) (not (symbol-package s))) - nconc - (loop repeat 50 - nconc (randomly-check-readability - s - :readable nil - :escape t - :gensym t - :test #'similar-uninterned-symbols)))) + when (and (symbolp s) (not (symbol-package s))) + nconc + (loop repeat 50 + nconc (randomly-check-readability + s + :readable nil + :escape t + :gensym t + :test #'similar-uninterned-symbols)))) nil) (deftest print.symbol.escaped.9 (let* ((*package* (find-package "CL-TEST")) - (s (intern "()"))) + (s (intern "()"))) (randomly-check-readability s :readable nil :escape t)) nil) (deftest print.symbol.escaped.10 (let* ((*package* (find-package "KEYWORD")) - (s (intern "()"))) + (s (intern "()"))) (randomly-check-readability s :readable nil :escape t)) nil) @@ -565,11 +565,11 @@ (deftest print.symbol.prefix.3 (with-standard-io-syntax (let ((s (write-to-string (make-symbol "ABC") - :gensym nil :case :upcase - :readably t :escape nil))) + :gensym nil :case :upcase + :readably t :escape nil))) (if (and (string= (subseq s 0 2) "#:") - (string= (symbol-name (read-from-string s)) "ABC")) - t s))) + (string= (symbol-name (read-from-string s)) "ABC")) + t s))) t) (deftest print.symbol.prefix.4 @@ -585,17 +585,17 @@ (delete-package pkg-name)) (let ((pkg (make-package pkg-name))) (multiple-value-prog1 - (let* ((*package* (find-package "CL-TEST")) - (s (intern "ABC" pkg))) - (values - (write-to-string s :case :upcase :readably nil :escape t) - (let ((*package* pkg)) - (write-to-string s :case :upcase :readably nil :escape t)) - (let ((*package* pkg)) - (write-to-string s :case :downcase :readably nil :escape t)) - )) - ;; (delete-package pkg) - )))) + (let* ((*package* (find-package "CL-TEST")) + (s (intern "ABC" pkg))) + (values + (write-to-string s :case :upcase :readably nil :escape t) + (let ((*package* pkg)) + (write-to-string s :case :upcase :readably nil :escape t)) + (let ((*package* pkg)) + (write-to-string s :case :downcase :readably nil :escape t)) + )) + ;; (delete-package pkg) + )))) "PRINT-SYMBOL-TEST-PACKAGE::ABC" "ABC" "abc") @@ -607,12 +607,12 @@ (delete-package pkg-name)) (let ((pkg (make-package pkg-name))) (prog1 - (with-standard-io-syntax - (let* ((*package* pkg) - (s (intern "X" pkg))) - (write-to-string s :case :upcase :readably nil)) - ;; (delete-package pkg) - )))) + (with-standard-io-syntax + (let* ((*package* pkg) + (s (intern "X" pkg))) + (write-to-string s :case :upcase :readably nil)) + ;; (delete-package pkg) + )))) "X") (deftest print.symbol.prefix.6a @@ -628,25 +628,25 @@ '(lambda () (declare (optimize speed (safety 0))) (with-standard-io-syntax - (let ((*package* (find-package "CL-TEST"))) - (write-to-string 'cl-test::x :case :upcase :readably nil)))))) + (let ((*package* (find-package "CL-TEST"))) + (write-to-string 'cl-test::x :case :upcase :readably nil)))))) "X") (deftest print.symbol.prefix.7 (with-standard-io-syntax (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE") - (pkg-name2 "ANOTHER-PRINT-SYMBOL-TEST-PACKAGE")) + (pkg-name2 "ANOTHER-PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (when (find-package pkg-name2) (delete-package pkg-name2)) (prog1 - (let* ((pkg (make-package pkg-name)) - (pkg2 (make-package pkg-name2)) - (s (intern "ABC" pkg))) - (import s pkg2) - (let ((*package* pkg2)) - (write-to-string s :case :upcase :readably nil :escape t))) + (let* ((pkg (make-package pkg-name)) + (pkg2 (make-package pkg-name2)) + (s (intern "ABC" pkg))) + (import s pkg2) + (let ((*package* pkg2)) + (write-to-string s :case :upcase :readably nil :escape t))) ;; (delete-package pkg) ))) "ABC") @@ -654,19 +654,19 @@ (deftest print.symbol.prefix.8 (with-standard-io-syntax (let ((pkg-name "PRINT-SYMBOL-TEST-PACKAGE") - (pkg-name2 "ANOTHER-PRINT-SYMBOL-TEST-PACKAGE")) + (pkg-name2 "ANOTHER-PRINT-SYMBOL-TEST-PACKAGE")) (when (find-package pkg-name) (delete-package pkg-name)) (when (find-package pkg-name2) (delete-package pkg-name2)) (prog1 - (let* ((pkg (make-package pkg-name)) - (pkg2 (make-package pkg-name2)) - (s (intern "ABC" pkg2))) - (import s pkg) - (delete-package pkg2) - (let ((*package* pkg)) - (write-to-string s :case :upcase :gensym t :readably nil :escape t))) + (let* ((pkg (make-package pkg-name)) + (pkg2 (make-package pkg-name2)) + (s (intern "ABC" pkg2))) + (import s pkg) + (delete-package pkg2) + (let ((*package* pkg)) + (write-to-string s :case :upcase :gensym t :readably nil :escape t))) ;; (delete-package pkg) ))) "#:ABC") @@ -677,11 +677,11 @@ (when (find-package pkg-name) (delete-package pkg-name)) (prog1 - (let* ((pkg (make-package pkg-name)) - (s (intern "ABC" pkg))) - (export s pkg) - (let ((*package* (find-package "CL-TEST"))) - (write-to-string s :case :upcase :readably nil :escape t))) + (let* ((pkg (make-package pkg-name)) + (s (intern "ABC" pkg))) + (export s pkg) + (let ((*package* (find-package "CL-TEST"))) + (write-to-string s :case :upcase :readably nil :escape t))) ;; (delete-package pkg) ))) "PRINT-SYMBOL-TEST-PACKAGE:ABC") @@ -693,11 +693,11 @@ (when (find-package pkg-name) (delete-package pkg-name)) (prog1 - (let* ((pkg (make-package pkg-name)) - (s :|X|)) - (import s pkg) - (let ((*package* pkg)) - (write-to-string s :case :upcase :readably nil :escape t))) + (let* ((pkg (make-package pkg-name)) + (s :|X|)) + (import s pkg) + (let ((*package* pkg)) + (write-to-string s :case :upcase :readably nil :escape t))) ;; (delete-package pkg) ))) ":X") diff --git a/ansi-tests/print-unreadable-object.lsp b/ansi-tests/print-unreadable-object.lsp index 97b0cd5e..ab74b4e7 100644 --- a/ansi-tests/print-unreadable-object.lsp +++ b/ansi-tests/print-unreadable-object.lsp @@ -12,11 +12,11 @@ for x in *mini-universe* for return-vals = nil for s = (with-output-to-string - (s) - (setq return-vals - (multiple-value-list (print-unreadable-object (x s))))) + (s) + (setq return-vals + (multiple-value-list (print-unreadable-object (x s))))) unless (and (equal return-vals '(nil)) - (equal s "#<>")) + (equal s "#<>")) collect (list x return-vals s)) nil) @@ -26,22 +26,22 @@ for return-vals1 = nil for return-vals2 = nil for s1 = (with-output-to-string - (s) - (setq return-vals1 - (multiple-value-list (print-unreadable-object - (x s :type t))))) + (s) + (setq return-vals1 + (multiple-value-list (print-unreadable-object + (x s :type t))))) for s2 = (with-output-to-string - (s) - (setq return-vals2 - (multiple-value-list (print-unreadable-object - (x s :type t) - (write-char #\X s))))) + (s) + (setq return-vals2 + (multiple-value-list (print-unreadable-object + (x s :type t) + (write-char #\X s))))) unless (and (equal return-vals1 '(nil)) - (equal return-vals2 '(nil)) - (string= s1 "#<" :end1 2) - (string= s1 s2 :end1 (- (length s1) 1) - :end2 (- (length s2) 2)) - (string= s2 " X>" :start1 (- (length s2) 3))) + (equal return-vals2 '(nil)) + (string= s1 "#<" :end1 2) + (string= s1 s2 :end1 (- (length s1) 1) + :end2 (- (length s2) 2)) + (string= s2 " X>" :start1 (- (length s2) 3))) collect (list x return-vals1 return-vals2 s1 s2)) nil) @@ -51,26 +51,26 @@ for return-vals1 = nil for return-vals2 = nil for s1 = (with-output-to-string - (s) - (setq return-vals1 - (multiple-value-list (print-unreadable-object - (x s :identity t) - (write "FOO" :stream s) - (values 1 2 3 4 5) ;; test if this is ignored - )))) + (s) + (setq return-vals1 + (multiple-value-list (print-unreadable-object + (x s :identity t) + (write "FOO" :stream s) + (values 1 2 3 4 5) ;; test if this is ignored + )))) for s2 = (with-output-to-string - (s) - (setq return-vals2 - (multiple-value-list (print-unreadable-object - (x s :identity t) - )))) + (s) + (setq return-vals2 + (multiple-value-list (print-unreadable-object + (x s :identity t) + )))) unless (and (equal return-vals1 '(nil)) - (equal return-vals2 '(nil)) - (string= s1 "#<FOO " :end1 6) - (string= s2 "#< " :end1 3) - (eql (char s1 (1- (length s1))) #\>) - (eql (char s2 (1- (length s2))) #\>) - (string= s1 s2 :start2 3 :start1 6)) + (equal return-vals2 '(nil)) + (string= s1 "#<FOO " :end1 6) + (string= s2 "#< " :end1 3) + (eql (char s1 (1- (length s1))) #\>) + (eql (char s2 (1- (length s2))) #\>) + (string= s1 s2 :start2 3 :start1 6)) collect (list x return-vals1 return-vals2 s1 s2)) nil) @@ -79,17 +79,17 @@ for x in *mini-universe* for return-vals = nil for s = (with-output-to-string - (s) - (setq return-vals - (multiple-value-list (print-unreadable-object - (x s :identity t :type t) - (write "FOO" :stream s) - (values) ;; test if this is ignored - )))) + (s) + (setq return-vals + (multiple-value-list (print-unreadable-object + (x s :identity t :type t) + (write "FOO" :stream s) + (values) ;; test if this is ignored + )))) unless (and (equal return-vals '(nil)) - (string= s "#<" :end1 2) - (eql (char s (1- (length s))) #\>) - (>= (count #\Space s) 2)) + (string= s "#<" :end1 2) + (eql (char s (1- (length s))) #\>) + (>= (count #\Space s) 2)) collect (list x return-vals s)) nil) @@ -105,13 +105,13 @@ (with-standard-io-syntax (let ((*print-readably* t)) (loop for x in *mini-universe* - for form = `(with-output-to-string - (*standard-output*) - (assert (signals-error - (print-unreadable-object (',x *standard-output*)) - print-not-readable))) - unless (equal (eval form) "") - collect x))) + for form = `(with-output-to-string + (*standard-output*) + (assert (signals-error + (print-unreadable-object (',x *standard-output*)) + print-not-readable))) + unless (equal (eval form) "") + collect x))) nil) ;;; Stream designators @@ -124,9 +124,9 @@ (with-open-stream (*terminal-io* (make-two-way-stream is os)) (let ((*print-readably* nil)) - (assert - (equal (multiple-value-list (print-unreadable-object (1 t))) - '(nil))))))) + (assert + (equal (multiple-value-list (print-unreadable-object (1 t))) + '(nil))))))) "#<>") (deftest print-unreadable-object.nil.1 @@ -135,7 +135,7 @@ (let ((*print-readably* nil)) (assert (equal (multiple-value-list (print-unreadable-object (1 nil))) - '(nil))))) + '(nil))))) "#<>") diff --git a/ansi-tests/print-vector.lsp b/ansi-tests/print-vector.lsp index fcae4e52..4798fec9 100644 --- a/ansi-tests/print-vector.lsp +++ b/ansi-tests/print-vector.lsp @@ -17,28 +17,28 @@ (deftest print.vector.2 (with-standard-io-syntax (loop for i from 2 to 100 - for a = (make-array '(0) :element-type `(unsigned-byte ,i)) - for s = (write-to-string a :readably nil :array t :pretty nil) - unless (string= s "#()") - collect (list i s))) + for a = (make-array '(0) :element-type `(unsigned-byte ,i)) + for s = (write-to-string a :readably nil :array t :pretty nil) + unless (string= s "#()") + collect (list i s))) nil) (deftest print.vector.3 (with-standard-io-syntax (loop for i from 1 to 100 - for a = (make-array '(0) :element-type `(signed-byte ,i)) - for s = (write-to-string a :readably nil :array t :pretty nil) - unless (string= s "#()") - collect (list i s))) + for a = (make-array '(0) :element-type `(signed-byte ,i)) + for s = (write-to-string a :readably nil :array t :pretty nil) + unless (string= s "#()") + collect (list i s))) nil) (deftest print.vector.4 (with-standard-io-syntax (loop for type in '(short-float single-float double-float long-float) - for a = (make-array '(0) :element-type type) - for s = (write-to-string a :readably nil :array t :pretty nil) - unless (string= s "#()") - collect (list type s))) + for a = (make-array '(0) :element-type type) + for s = (write-to-string a :readably nil :array t :pretty nil) + unless (string= s "#()") + collect (list type s))) nil) ;;; Nonempty vectors @@ -46,12 +46,12 @@ (deftest print.vector.5 (with-standard-io-syntax (let* ((*package* (find-package "CL-TEST")) - (result - (write-to-string #(a b c) - :readably nil :array t - :pretty nil :case :downcase))) + (result + (write-to-string #(a b c) + :readably nil :array t + :pretty nil :case :downcase))) (or (and (string= result "#(a b c)") t) - result))) + result))) t) (deftest print.vector.6 @@ -59,7 +59,7 @@ (loop for i from 2 to 100 for a = (make-array '(4) :element-type `(unsigned-byte ,i) - :initial-contents '(3 0 2 1)) + :initial-contents '(3 0 2 1)) for s = (write-to-string a :readably nil :array t :pretty nil) unless (string= s "#(3 0 2 1)") collect (list i a s))) @@ -70,7 +70,7 @@ (loop for i from 2 to 100 for a = (make-array '(4) :element-type `(signed-byte ,i) - :initial-contents '(-2 -1 0 1)) + :initial-contents '(-2 -1 0 1)) for s = (write-to-string a :readably nil :array t :pretty nil) unless (string= s "#(-2 -1 0 1)") collect (list i a s))) @@ -81,12 +81,12 @@ (deftest print.vector.fill.1 (with-standard-io-syntax (let ((v (make-array '(10) :initial-contents '(a b c d e f g h i j) - :fill-pointer 0)) - (*package* (find-package "CL-TEST"))) + :fill-pointer 0)) + (*package* (find-package "CL-TEST"))) (loop for i from 0 to 10 - do (setf (fill-pointer v) i) - collect (write-to-string v :readably nil :array t :pretty nil - :case :downcase)))) + do (setf (fill-pointer v) i) + collect (write-to-string v :readably nil :array t :pretty nil + :case :downcase)))) ("#()" "#(a)" "#(a b)" @@ -103,79 +103,79 @@ (with-standard-io-syntax (let ((expected '("#()" "#(0)" "#(0 1)" "#(0 1 2)" "#(0 1 2 3)"))) (loop for i from 2 to 100 - nconc - (let ((v (make-array '(4) :initial-contents '(0 1 2 3) - :element-type `(unsigned-byte ,i) - :fill-pointer 0))) - (loop for fp from 0 to 4 - for expected-result in expected - for actual-result = - (progn - (setf (fill-pointer v) fp) - (write-to-string v :readably nil :array t :pretty nil)) - unless (string= expected-result actual-result) - collect (list i fp expected-result actual-result)))))) + nconc + (let ((v (make-array '(4) :initial-contents '(0 1 2 3) + :element-type `(unsigned-byte ,i) + :fill-pointer 0))) + (loop for fp from 0 to 4 + for expected-result in expected + for actual-result = + (progn + (setf (fill-pointer v) fp) + (write-to-string v :readably nil :array t :pretty nil)) + unless (string= expected-result actual-result) + collect (list i fp expected-result actual-result)))))) nil) (deftest print.vector.fill.3 (with-standard-io-syntax (let ((expected '("#()" "#(0)" "#(0 -1)" "#(0 -1 -2)" "#(0 -1 -2 1)"))) (loop for i from 2 to 100 - nconc - (let ((v (make-array '(4) :initial-contents '(0 -1 -2 1) - :element-type `(signed-byte ,i) - :fill-pointer 0))) - (loop for fp from 0 to 4 - for expected-result in expected - for actual-result = - (progn - (setf (fill-pointer v) fp) - (write-to-string v :readably nil :array t :pretty nil)) - unless (string= expected-result actual-result) - collect (list i fp expected-result actual-result)))))) + nconc + (let ((v (make-array '(4) :initial-contents '(0 -1 -2 1) + :element-type `(signed-byte ,i) + :fill-pointer 0))) + (loop for fp from 0 to 4 + for expected-result in expected + for actual-result = + (progn + (setf (fill-pointer v) fp) + (write-to-string v :readably nil :array t :pretty nil)) + unless (string= expected-result actual-result) + collect (list i fp expected-result actual-result)))))) nil) ;;; Displaced vectors (deftest print.vector.displaced.1 (let* ((v1 (vector 'a 'b 'c 'd 'e 'f 'g)) - (v2 (make-array 3 :displaced-to v1 :displaced-index-offset 4))) + (v2 (make-array 3 :displaced-to v1 :displaced-index-offset 4))) (with-standard-io-syntax (write-to-string v2 :readably nil :array t :case :downcase :pretty nil - :escape nil))) + :escape nil))) "#(e f g)") (deftest print.vector.displaced.2 (with-standard-io-syntax (loop for i from 2 to 100 - nconc - (let* ((type `(unsigned-byte ,i)) - (v1 (make-array 8 :element-type type - :initial-contents '(0 1 2 3 0 1 2 3))) - (v2 (make-array 5 :displaced-to v1 - :displaced-index-offset 2 - :element-type type)) - (result - (write-to-string v2 :readably nil :array t :pretty nil))) - (unless (string= result "#(2 3 0 1 2)") - (list (list i v1 v2 result)))))) + nconc + (let* ((type `(unsigned-byte ,i)) + (v1 (make-array 8 :element-type type + :initial-contents '(0 1 2 3 0 1 2 3))) + (v2 (make-array 5 :displaced-to v1 + :displaced-index-offset 2 + :element-type type)) + (result + (write-to-string v2 :readably nil :array t :pretty nil))) + (unless (string= result "#(2 3 0 1 2)") + (list (list i v1 v2 result)))))) nil) (deftest print.vector.displaced.3 (with-standard-io-syntax (loop for i from 2 to 100 - nconc - (let* ((type `(signed-byte ,i)) - (v1 (make-array 8 :element-type type - :initial-contents '(0 1 -1 -2 0 1 -1 -2))) - (v2 (make-array 5 :displaced-to v1 - :displaced-index-offset 2 - :element-type type)) - (result - (write-to-string v2 :readably nil :array t :pretty nil))) - (unless (string= result "#(-1 -2 0 1 -1)") - (list (list i v1 v2 result)))))) + nconc + (let* ((type `(signed-byte ,i)) + (v1 (make-array 8 :element-type type + :initial-contents '(0 1 -1 -2 0 1 -1 -2))) + (v2 (make-array 5 :displaced-to v1 + :displaced-index-offset 2 + :element-type type)) + (result + (write-to-string v2 :readably nil :array t :pretty nil))) + (unless (string= result "#(-1 -2 0 1 -1)") + (list (list i v1 v2 result)))))) nil) @@ -184,35 +184,35 @@ (deftest print.vector.adjustable.1 (with-standard-io-syntax (let ((v (make-array '(10) :initial-contents '(a b c d e f g h i j) - :adjustable t))) + :adjustable t))) (write-to-string v :readably nil :array t :case :downcase :pretty nil - :escape nil))) + :escape nil))) "#(a b c d e f g h i j)") (deftest print.vector.adjustable.2 (with-standard-io-syntax (loop for i from 2 to 100 - for type = `(unsigned-byte ,i) - for v = (make-array '(8) :initial-contents '(0 1 2 3 3 0 2 1) - :adjustable t) - for s = - (write-to-string v :readably nil :array t :case :downcase :pretty nil - :escape nil) - unless (string= s "#(0 1 2 3 3 0 2 1)") - collect (list i v s))) + for type = `(unsigned-byte ,i) + for v = (make-array '(8) :initial-contents '(0 1 2 3 3 0 2 1) + :adjustable t) + for s = + (write-to-string v :readably nil :array t :case :downcase :pretty nil + :escape nil) + unless (string= s "#(0 1 2 3 3 0 2 1)") + collect (list i v s))) nil) (deftest print.vector.adjustable.3 (with-standard-io-syntax (loop for i from 2 to 100 - for type = `(signed-byte ,i) - for v = (make-array '(8) :initial-contents '(0 1 -1 -2 -1 0 -2 1) - :adjustable t) - for s = - (write-to-string v :readably nil :array t :case :downcase :pretty nil - :escape nil) - unless (string= s "#(0 1 -1 -2 -1 0 -2 1)") - collect (list i v s))) + for type = `(signed-byte ,i) + for v = (make-array '(8) :initial-contents '(0 1 -1 -2 -1 0 -2 1) + :adjustable t) + for s = + (write-to-string v :readably nil :array t :case :downcase :pretty nil + :escape nil) + unless (string= s "#(0 1 -1 -2 -1 0 -2 1)") + collect (list i v s))) nil) ;;; Printing with *print-array* and *print-readably* bound to nil @@ -225,24 +225,24 @@ (deftest print.vector.unreadable.2 (with-standard-io-syntax (loop for i from 2 to 100 - for type = `(unsigned-byte ,i) - for v = (make-array '(4) :element-type type - :initial-contents '(0 1 2 3)) - for result = (write-to-string v :array nil :readably nil) - unless (string= (subseq result 0 2) "#<") - collect (list i type v result))) + for type = `(unsigned-byte ,i) + for v = (make-array '(4) :element-type type + :initial-contents '(0 1 2 3)) + for result = (write-to-string v :array nil :readably nil) + unless (string= (subseq result 0 2) "#<") + collect (list i type v result))) nil) (deftest print.vector.unreadable.3 (with-standard-io-syntax (loop for i from 2 to 100 - for type = `(signed-byte ,i) - for v = (make-array '(4) :element-type type - :initial-contents '(0 1 -2 -1)) - for result = (write-to-string v :array nil :readably nil) - unless (string= (subseq result 0 2) "#<") - collect (list i type v result))) + for type = `(signed-byte ,i) + for v = (make-array '(4) :element-type type + :initial-contents '(0 1 -2 -1)) + for result = (write-to-string v :array nil :readably nil) + unless (string= (subseq result 0 2) "#<") + collect (list i type v result))) nil) ;;; Readability tests @@ -250,46 +250,46 @@ (deftest print.vector.random.1 (trim-list (loop for v in *universe* - when (vectorp v) - nconc - (loop repeat 10 - nconc (randomly-check-readability - v :test #'equalp - :can-fail (not (subtypep t (array-element-type v)))))) + when (vectorp v) + nconc + (loop repeat 10 + nconc (randomly-check-readability + v :test #'equalp + :can-fail (not (subtypep t (array-element-type v)))))) 10) nil) (deftest print.vector.random.2 (trim-list (loop for i from 2 to 100 - for type = `(unsigned-byte ,i) - for v = (make-array '(4) :element-type type - :initial-contents '(1 3 2 0)) - nconc - (loop repeat 10 - nconc (randomly-check-readability v :test #'equalp - :can-fail t))) + for type = `(unsigned-byte ,i) + for v = (make-array '(4) :element-type type + :initial-contents '(1 3 2 0)) + nconc + (loop repeat 10 + nconc (randomly-check-readability v :test #'equalp + :can-fail t))) 10) nil) (deftest print.vector.random.3 (trim-list (loop for i from 2 to 100 - for type = `(signed-byte ,i) - for v = (make-array '(4) :element-type type - :initial-contents '(-1 1 0 -2)) - nconc - (loop repeat 10 - nconc (randomly-check-readability v :test #'equalp - :can-fail t))) + for type = `(signed-byte ,i) + for v = (make-array '(4) :element-type type + :initial-contents '(-1 1 0 -2)) + nconc + (loop repeat 10 + nconc (randomly-check-readability v :test #'equalp + :can-fail t))) 10) nil) (deftest print.vector.random.4 (trim-list (loop for v = (make-random-vector (1+ (random 100))) - repeat 1000 - nconc (randomly-check-readability v :test #'equalp)) + repeat 1000 + nconc (randomly-check-readability v :test #'equalp)) 10) nil) @@ -313,80 +313,80 @@ (deftest print.vector.length.4 (with-standard-io-syntax (write-to-string #(a b c d e f g h) - :pretty nil - :array t :escape nil - :length 5 :case :downcase - :readably nil)) + :pretty nil + :array t :escape nil + :length 5 :case :downcase + :readably nil)) "#(a b c d e ...)") (deftest print.vector.length.5 (with-standard-io-syntax (loop for i from 2 to 100 - for type = `(unsigned-byte ,i) - for v = (make-array '(0) :element-type type) - for result = (write-to-string v :array t :readably nil - :pretty nil - :length 0) - unless (string= result "#()") - collect (list i type v result))) + for type = `(unsigned-byte ,i) + for v = (make-array '(0) :element-type type) + for result = (write-to-string v :array t :readably nil + :pretty nil + :length 0) + unless (string= result "#()") + collect (list i type v result))) nil) (deftest print.vector.length.6 (with-standard-io-syntax (loop for i from 2 to 100 - for type = `(unsigned-byte ,i) - for v = (make-array '(1) :element-type type :initial-contents '(2)) - for result = (write-to-string v - :pretty nil - :array t - :readably nil - :length 0) - unless (string= result "#(...)") - collect (list i type v result))) + for type = `(unsigned-byte ,i) + for v = (make-array '(1) :element-type type :initial-contents '(2)) + for result = (write-to-string v + :pretty nil + :array t + :readably nil + :length 0) + unless (string= result "#(...)") + collect (list i type v result))) nil) (deftest print.vector.length.7 (with-standard-io-syntax (loop for i from 1 to 100 - for type = `(signed-byte ,i) - for v = (make-array '(1) :element-type type :initial-contents '(-1)) - for result = (write-to-string v - :pretty nil - :array t - :readably nil - :length 0) - unless (string= result "#(...)") - collect (list i type v result))) + for type = `(signed-byte ,i) + for v = (make-array '(1) :element-type type :initial-contents '(-1)) + for result = (write-to-string v + :pretty nil + :array t + :readably nil + :length 0) + unless (string= result "#(...)") + collect (list i type v result))) nil) (deftest print.vector.length.8 (with-standard-io-syntax (loop for i from 2 to 100 - for type = `(unsigned-byte ,i) - for v = (make-array '(4) :element-type type - :initial-contents '(1 3 0 2)) - for result = (write-to-string v - :pretty nil - :array t - :readably nil - :length 2) - unless (string= result "#(1 3 ...)") - collect (list i type v result))) + for type = `(unsigned-byte ,i) + for v = (make-array '(4) :element-type type + :initial-contents '(1 3 0 2)) + for result = (write-to-string v + :pretty nil + :array t + :readably nil + :length 2) + unless (string= result "#(1 3 ...)") + collect (list i type v result))) nil) (deftest print.vector.length.9 (with-standard-io-syntax (loop for i from 2 to 100 - for type = `(signed-byte ,i) - for v = (make-array '(4) :element-type type - :initial-contents '(1 -2 0 -1)) - for result = (write-to-string v - :pretty nil - :array t - :readably nil - :length 2) - unless (string= result "#(1 -2 ...)") - collect (list i type v result))) + for type = `(signed-byte ,i) + for v = (make-array '(4) :element-type type + :initial-contents '(1 -2 0 -1)) + for result = (write-to-string v + :pretty nil + :array t + :readably nil + :length 2) + unless (string= result "#(1 -2 ...)") + collect (list i type v result))) nil) ;;; Printing with *print-level* bound diff --git a/ansi-tests/print.lsp b/ansi-tests/print.lsp index 55121b84..5f71bcde 100644 --- a/ansi-tests/print.lsp +++ b/ansi-tests/print.lsp @@ -20,7 +20,7 @@ (with-input-from-string (is "") (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (print 2 t))))) + (print 2 t))))) " 2 ") diff --git a/ansi-tests/printer-aux.lsp b/ansi-tests/printer-aux.lsp index 2e4202c3..5846c677 100644 --- a/ansi-tests/printer-aux.lsp +++ b/ansi-tests/printer-aux.lsp @@ -10,37 +10,37 @@ (defmacro def-print-test (name form result &rest bindings) `(deftest ,name (if (equalpt - (my-with-standard-io-syntax - (let ((*print-readably* nil)) - (let ,bindings - (with-output-to-string (*standard-output*) (prin1 ,form))))) - ,result) - t + (my-with-standard-io-syntax + (let ((*print-readably* nil)) + (let ,bindings + (with-output-to-string (*standard-output*) (prin1 ,form))))) + ,result) + t ,result) t)) (defmacro def-pprint-test (name form expected-value - &key - (margin 100) - (miser nil) - (circle nil) - (len nil) - (pretty t) - (escape nil) - (readably nil) - (package (find-package "CL-TEST"))) + &key + (margin 100) + (miser nil) + (circle nil) + (len nil) + (pretty t) + (escape nil) + (readably nil) + (package (find-package "CL-TEST"))) `(deftest ,name (with-standard-io-syntax (let ((*print-pretty* ,pretty) - (*print-escape* ,escape) - (*print-readably* ,readably) - (*print-right-margin* ,margin) - (*package* ,package) - (*print-length* ,len) - (*print-miser-width* ,miser) - (*print-circle* ,circle)) - ,form)) + (*print-escape* ,escape) + (*print-readably* ,readably) + (*print-right-margin* ,margin) + (*package* ,package) + (*print-length* ,len) + (*print-miser-width* ,miser) + (*print-circle* ,circle)) + ,form)) ,expected-value)) (defmacro def-ppblock-test (name form expected-value &rest key-args) @@ -64,81 +64,81 @@ error that occurs is fatal.") (defun randomly-check-readability (obj &key - (can-fail nil) - (test #'equal) - (readable t) - (circle nil circle-p) - (escape nil escape-p) - (gensym nil gensym-p) - (debug *random-read-check-debug*)) + (can-fail nil) + (test #'equal) + (readable t) + (circle nil circle-p) + (escape nil escape-p) + (gensym nil gensym-p) + (debug *random-read-check-debug*)) (declare (type function test)) ;; Generate random printer-control values (my-with-standard-io-syntax (let ((*print-array* (coin)) - (*print-base* (+ 2 (random 34))) - (*print-radix* (coin)) - (*print-case* (random-from-seq #(:upcase :downcase :capitalize))) - (*print-circle* (if circle-p circle (coin))) - (*print-escape* (if escape-p escape (coin))) - (*print-gensym* (if gensym-p gensym (coin))) - (*print-level* (random 50)) - (*print-length* (if readable (random 50) nil)) - (*print-lines* (if readable (random 50) nil)) - (*print-miser-width* (and (coin) (random 100))) - (*print-pretty* (coin)) - (*print-right-margin* (and (coin) (random 100))) - (*print-readably* readable) - (*read-default-float-format* (rcase (1 'short-float) (1 'single-float) - (1 'double-float) (1 'long-float) - (1 *read-default-float-format*))) - (*readtable* (copy-readtable)) - (readcase (random-from-seq #(:upcase :downcase :preserve :invert))) - ) + (*print-base* (+ 2 (random 34))) + (*print-radix* (coin)) + (*print-case* (random-from-seq #(:upcase :downcase :capitalize))) + (*print-circle* (if circle-p circle (coin))) + (*print-escape* (if escape-p escape (coin))) + (*print-gensym* (if gensym-p gensym (coin))) + (*print-level* (random 50)) + (*print-length* (if readable (random 50) nil)) + (*print-lines* (if readable (random 50) nil)) + (*print-miser-width* (and (coin) (random 100))) + (*print-pretty* (coin)) + (*print-right-margin* (and (coin) (random 100))) + (*print-readably* readable) + (*read-default-float-format* (rcase (1 'short-float) (1 'single-float) + (1 'double-float) (1 'long-float) + (1 *read-default-float-format*))) + (*readtable* (copy-readtable)) + (readcase (random-from-seq #(:upcase :downcase :preserve :invert))) + ) (flet ((%params () - (list (list '*print-readably* *print-readably*) - (list '*print-array* *print-array*) - (list '*print-base* *print-base*) - (list '*print-radix* *print-radix*) - (list '*print-case* *print-case*) - (list '*print-circle* *print-circle*) - (list '*print-escape* *print-escape*) - (list '*print-gensym* *print-gensym*) - (list '*print-level* *print-level*) - (list '*print-length* *print-length*) - (list '*print-lines* *print-lines*) - (list '*print-miser-width* *print-miser-width*) - (list '*print-pretty* *print-pretty*) - (list '*print-right-margin* *print-right-margin*) - (list '*read-default-float-format* *read-default-float-format*) - (list 'readtable-case readcase)))) + (list (list '*print-readably* *print-readably*) + (list '*print-array* *print-array*) + (list '*print-base* *print-base*) + (list '*print-radix* *print-radix*) + (list '*print-case* *print-case*) + (list '*print-circle* *print-circle*) + (list '*print-escape* *print-escape*) + (list '*print-gensym* *print-gensym*) + (list '*print-level* *print-level*) + (list '*print-length* *print-length*) + (list '*print-lines* *print-lines*) + (list '*print-miser-width* *print-miser-width*) + (list '*print-pretty* *print-pretty*) + (list '*print-right-margin* *print-right-margin*) + (list '*read-default-float-format* *read-default-float-format*) + (list 'readtable-case readcase)))) (when debug - (let ((params (%params))) - (with-standard-io-syntax (format *debug-io* "~%~A~%" params))) - (finish-output *debug-io*)) - + (let ((params (%params))) + (with-standard-io-syntax (format *debug-io* "~%~A~%" params))) + (finish-output *debug-io*)) + (setf (readtable-case *readtable*) readcase) (let* ((str (handler-case - (with-output-to-string (s) (write obj :stream s)) - (print-not-readable - () - (if can-fail - (return-from randomly-check-readability nil) - ":print-not-readable-error")))) - (obj2 (let ((*read-base* *print-base*)) - (handler-case - (let ((*readtable* (if *print-readably* - (copy-readtable nil) - *readtable*))) - (read-from-string str)) - (reader-error () :reader-error) - (end-of-file () :end-of-file) - (stream-error () :stream-error) - (file-error () :file-error) - )))) - (unless (funcall test obj obj2) - (list - (list* obj str obj2 (%params) - )))))))) + (with-output-to-string (s) (write obj :stream s)) + (print-not-readable + () + (if can-fail + (return-from randomly-check-readability nil) + ":print-not-readable-error")))) + (obj2 (let ((*read-base* *print-base*)) + (handler-case + (let ((*readtable* (if *print-readably* + (copy-readtable nil) + *readtable*))) + (read-from-string str)) + (reader-error () :reader-error) + (end-of-file () :end-of-file) + (stream-error () :stream-error) + (file-error () :file-error) + )))) + (unless (funcall test obj obj2) + (list + (list* obj str obj2 (%params) + )))))))) (defun parse-escaped-string (string) "Parse a string into a list of either characters (representing @@ -146,37 +146,37 @@ escaped characters.)" (assert (stringp string) () "Not a string: ~A" string) (let ((result nil) - (len (length string)) - (index 0)) + (len (length string)) + (index 0)) (prog () normal ; parsing in normal mode (when (= index len) (return)) (let ((c (elt string index))) (cond ((eql c #\\) - (assert (< (incf index) len) - () - "End of string after \\") - (push `(,(elt string index) :escaped) result) - (incf index) - (go normal)) - ((eql c #\|) - (incf index) - (go multiple-escaped)) - (t (push c result) - (incf index) - (go normal)))) + (assert (< (incf index) len) + () + "End of string after \\") + (push `(,(elt string index) :escaped) result) + (incf index) + (go normal)) + ((eql c #\|) + (incf index) + (go multiple-escaped)) + (t (push c result) + (incf index) + (go normal)))) multiple-escaped ; parsing inside |s (assert (< index len) () "End of string inside |") (let ((c (elt string index))) (cond ((eq c #\|) - (incf index) - (go normal)) - (t - (push `(,c :escaped) result) - (incf index) - (go multiple-escaped))))) + (incf index) + (go normal)) + (t + (push `(,c :escaped) result) + (incf index) + (go multiple-escaped))))) (nreverse result))) (defun escaped-equal (list1 list2) @@ -184,14 +184,14 @@ in list2, and that the characters are also the same." (and (= (length list1) (length list2)) (loop for e1 in list1 - for e2 in list2 - for is-escaped1 = (and (consp e1) (eq (cadr e1) :escaped)) - for is-escaped2 = (and (consp e2) (eq (cadr e2) :escaped)) - for c1 = (if is-escaped1 (car e1) e1) - for c2 = (if is-escaped2 (car e2) e2) - always - (and (if is-escaped1 is-escaped2 t) - (char= c1 c2))))) + for e2 in list2 + for is-escaped1 = (and (consp e1) (eq (cadr e1) :escaped)) + for is-escaped2 = (and (consp e2) (eq (cadr e2) :escaped)) + for c1 = (if is-escaped1 (car e1) e1) + for c2 = (if is-escaped2 (car e2) e2) + always + (and (if is-escaped1 is-escaped2 t) + (char= c1 c2))))) (defun similar-uninterned-symbols (s1 s2) (and (symbolp s1) @@ -199,7 +199,7 @@ (null (symbol-package s1)) (null (symbol-package s2)) (string= (symbol-name s1) - (symbol-name s2)))) + (symbol-name s2)))) (defun make-random-cons-tree (size) (if (<= size 1) @@ -210,13 +210,13 @@ (2 (random-from-seq #(a b c d e f g |1| |2| |.|)))) (let ((s1 (1+ (random (1- size))))) (cons (make-random-cons-tree s1) - (make-random-cons-tree (- size s1)))))) + (make-random-cons-tree (- size s1)))))) (defun make-random-vector (size) (if (> size 1) (let* ((nelems (min (1- size) (1+ (random (max 2 (floor size 4)))))) - (sizes (mapcar #'1+ (random-partition* (- size nelems 1) nelems)))) - (make-array nelems :initial-contents (mapcar #'make-random-vector sizes))) + (sizes (mapcar #'1+ (random-partition* (- size nelems 1) nelems)))) + (make-array nelems :initial-contents (mapcar #'make-random-vector sizes))) (rcase (1 (random-from-seq #(a b c d e f g))) (1 (- (random 2001) 1000)) @@ -244,7 +244,7 @@ ((:right-margin *print-right-margin*) *print-right-margin*) ((:stream *standard-output*) *standard-output*)) (funcall fun)) - + (defun output-test (obj &key (fun #'write) @@ -271,66 +271,66 @@ (defun make-random-key-param (name) (rcase (1 nil) - (1 `(,name nil)) - (1 `(,name t)))) + (1 `(,name nil)) + (1 `(,name t)))) (defun make-random-key-integer-or-nil-param (name bound) (rcase (1 nil) - (1 `(,name nil)) - (1 `(,name ,(random bound))))) + (1 `(,name nil)) + (1 `(,name ,(random bound))))) (defun make-random-write-args () (let* ((arg-lists `(,@(mapcar #'make-random-key-param - '(:array :circle :escape :gensym :pretty :radix :readably)) - ,(rcase (1 nil) - (1 `(:base ,(+ 2 (random 35))))) - ,(and (coin) - `(:case ,(random-from-seq #(:upcase :downcase :capitalize)))) - ,@(mapcar #'make-random-key-integer-or-nil-param - '(:length :level :lines :miser-width :right-margin) - '(100 20 50 200 200))))) - (reduce #'append (random-permute arg-lists) :from-end t))) + '(:array :circle :escape :gensym :pretty :radix :readably)) + ,(rcase (1 nil) + (1 `(:base ,(+ 2 (random 35))))) + ,(and (coin) + `(:case ,(random-from-seq #(:upcase :downcase :capitalize)))) + ,@(mapcar #'make-random-key-integer-or-nil-param + '(:length :level :lines :miser-width :right-margin) + '(100 20 50 200 200))))) + (reduce #'append (random-permute arg-lists) :from-end t))) (defun filter-unreadable-forms (string) "Find #<...> strings and replace with #<>." (let ((len (length string)) - (pos 0)) + (pos 0)) (loop while (< pos len) - do (let ((next (search "#<" string :start2 pos))) - (unless next (return string)) - (let ((end (position #\> string :start next))) - (unless end (return string)) - (setq string - (concatenate 'string - (subseq string 0 next) - "#<>" - (subseq string (1+ end))) - pos (+ next 3) - len (+ len (- next end) 3))))))) - + do (let ((next (search "#<" string :start2 pos))) + (unless next (return string)) + (let ((end (position #\> string :start next))) + (unless end (return string)) + (setq string + (concatenate 'string + (subseq string 0 next) + "#<>" + (subseq string (1+ end))) + pos (+ next 3) + len (+ len (- next end) 3))))))) + (defmacro def-random-write-test-fun (name write-args test-fn - &key - (prefix "") - (suffix "")) + &key + (prefix "") + (suffix "")) `(defun ,name (n &key (size 10)) (loop for args = (make-random-write-args) for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD"))) for obj = (let ((*random-readable* t)) - (declare (special *random-readable*)) - (random-thing (random size))) + (declare (special *random-readable*)) + (random-thing (random size))) for s1 = (let ((*package* package)) - (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args))) + (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args))) for s2 = (let ((*package* package)) - (with-output-to-string - (*standard-output*) - (apply #'output-test obj :fun ,test-fn args))) + (with-output-to-string + (*standard-output*) + (apply #'output-test obj :fun ,test-fn args))) repeat n ;; We filter the contents of #<...> forms since they may change with time ;; if they contain object addresses. unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix)) - (filter-unreadable-forms s2)) + (filter-unreadable-forms s2)) collect (list obj s1 s2 args)))) (def-random-write-test-fun random-write-test nil #'write) @@ -342,23 +342,23 @@ :prefix (string #\Newline)) (defmacro def-random-write-to-string-test-fun (name write-args test-fn - &key - (prefix "") - (suffix "")) + &key + (prefix "") + (suffix "")) `(defun ,name (n) (loop for args = (make-random-write-args) for package = (find-package (random-from-seq #("CL-TEST" "CL-USER" "KEYWORD"))) for obj = (let ((*random-readable* t)) - (declare (special *random-readable*)) - (random-thing (random 10))) + (declare (special *random-readable*)) + (random-thing (random 10))) for s1 = (let ((*package* package)) - (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args))) + (with-output-to-string (s) (apply #'write obj :stream s ,@write-args args))) for s2 = (let ((*package* package)) - (apply ,test-fn obj args)) + (apply ,test-fn obj args)) repeat n unless (string= (filter-unreadable-forms (concatenate 'string ,prefix s1 ,suffix)) - (filter-unreadable-forms s2)) + (filter-unreadable-forms s2)) collect (list obj s1 s2)))) (def-random-write-to-string-test-fun random-write-to-string-test nil #'write-to-string) @@ -385,20 +385,20 @@ (let ((dot-pos (position #\. s))) (assert dot-pos) (let ((prefix (subseq s 0 dot-pos)) - (suffix (subseq s (1+ dot-pos)))) - (assert (every #'digit-char-p prefix)) - (assert (every #'digit-char-p suffix)) - (let* ((prefix-len (length prefix)) - (prefix-integer (if (eql prefix-len 0) - 0 - (parse-integer prefix))) - (suffix-len (length suffix)) - (suffix-integer (if (eql suffix-len 0) - 0 - (parse-integer suffix))) - (magnitude (+ prefix-integer - (* suffix-integer (expt 1/10 suffix-len))))) - (if neg (- magnitude) magnitude)))))) + (suffix (subseq s (1+ dot-pos)))) + (assert (every #'digit-char-p prefix)) + (assert (every #'digit-char-p suffix)) + (let* ((prefix-len (length prefix)) + (prefix-integer (if (eql prefix-len 0) + 0 + (parse-integer prefix))) + (suffix-len (length suffix)) + (suffix-integer (if (eql suffix-len 0) + 0 + (parse-integer suffix))) + (magnitude (+ prefix-integer + (* suffix-integer (expt 1/10 suffix-len))))) + (if neg (- magnitude) magnitude)))))) ;;; Macro to define both FORMAT and FORMATTER tests @@ -406,40 +406,40 @@ (defmacro def-format-test (name string args expected-output &optional (num-left 0)) (assert (symbolp name)) (let* ((s (symbol-name name)) - (expected-prefix (string 'format.)) - (expected-prefix-length (length expected-prefix))) + (expected-prefix (string 'format.)) + (expected-prefix-length (length expected-prefix))) (assert (>= (length s) expected-prefix-length)) (assert (string-equal (subseq s 0 expected-prefix-length) - expected-prefix)) + expected-prefix)) (let* ((formatter-test-name-string - (concatenate 'string (string 'formatter.) - (subseq s expected-prefix-length))) - (formatter-test-name (intern formatter-test-name-string - (symbol-package name))) - (formatter-form (if (stringp string) - `(formatter ,string) - (list 'formatter (eval string))))) + (concatenate 'string (string 'formatter.) + (subseq s expected-prefix-length))) + (formatter-test-name (intern formatter-test-name-string + (symbol-package name))) + (formatter-form (if (stringp string) + `(formatter ,string) + (list 'formatter (eval string))))) `(progn - (deftest ,name - (with-standard-io-syntax - (let ((*print-readably* nil) - (*package* (symbol-package 'ABC))) - (format nil ,string ,@args))) - ,expected-output) - (deftest ,formatter-test-name - (let ((fn ,formatter-form) - (args (list ,@args))) - (with-standard-io-syntax - (let ((*print-readably* nil) - (*package* (symbol-package 'ABC))) - (with-output-to-string - (stream) - (let ((tail (apply fn stream args))) - ;; FIXME -- Need to check that TAIL really is a tail of ARGS - (assert (= (length tail) ,num-left) (tail) "Tail is ~A, length should be ~A" - tail ,num-left) - ))))) - ,expected-output))))) + (deftest ,name + (with-standard-io-syntax + (let ((*print-readably* nil) + (*package* (symbol-package 'ABC))) + (format nil ,string ,@args))) + ,expected-output) + (deftest ,formatter-test-name + (let ((fn ,formatter-form) + (args (list ,@args))) + (with-standard-io-syntax + (let ((*print-readably* nil) + (*package* (symbol-package 'ABC))) + (with-output-to-string + (stream) + (let ((tail (apply fn stream args))) + ;; FIXME -- Need to check that TAIL really is a tail of ARGS + (assert (= (length tail) ,num-left) (tail) "Tail is ~A, length should be ~A" + tail ,num-left) + ))))) + ,expected-output))))) ;;; Macro used for an idiom in testing FORMATTER calls diff --git a/ansi-tests/probe-file.lsp b/ansi-tests/probe-file.lsp index 976d3d50..f637d848 100644 --- a/ansi-tests/probe-file.lsp +++ b/ansi-tests/probe-file.lsp @@ -12,8 +12,8 @@ (deftest probe-file.2 (let ((s (open #p"probe-file.lsp" :direction :input))) (prog1 - (equalpt (truename #p"probe-file.lsp") - (probe-file s)) + (equalpt (truename #p"probe-file.lsp") + (probe-file s)) (close s))) t) @@ -21,12 +21,12 @@ (let ((s (open #p"probe-file.lsp" :direction :input))) (close s) (equalpt (truename #p"probe-file.lsp") - (probe-file s))) + (probe-file s))) t) (deftest probe-file.4 (equalpt (truename #p"probe-file.lsp") - (probe-file "CLTEST:probe-file.lsp")) + (probe-file "CLTEST:probe-file.lsp")) t) ;;; Specialized string tests @@ -38,7 +38,7 @@ (assert (equalpt (truename #p"probe-file.lsp") (probe-file s))) (close s))) nil) - + ;;; Error tests (deftest probe-file.error.1 diff --git a/ansi-tests/proclaim.lsp b/ansi-tests/proclaim.lsp index bcd37250..76f61838 100644 --- a/ansi-tests/proclaim.lsp +++ b/ansi-tests/proclaim.lsp @@ -9,7 +9,7 @@ (let ((sym (gensym))) (proclaim `(special ,sym)) (eval `(flet ((%f () ,sym)) - (let ((,sym :good)) (%f))))) + (let ((,sym :good)) (%f))))) :good) (deftest proclaim.2 diff --git a/ansi-tests/prog.lsp b/ansi-tests/prog.lsp index 784c877b..400cba80 100644 --- a/ansi-tests/prog.lsp +++ b/ansi-tests/prog.lsp @@ -24,8 +24,8 @@ (deftest prog.5 (let ((x 'a)) (prog ((x 'b) (y x)) - (declare (type symbol x y)) - (return (values x y)))) + (declare (type symbol x y)) + (return (values x y)))) b a) (deftest prog.6 @@ -36,39 +36,39 @@ (deftest prog.7 (prog ((i 1) (s 0)) - (declare (type fixnum i s)) - again - (when (> i 10) (return s)) - (incf s i) - (incf i) - (go again)) + (declare (type fixnum i s)) + again + (when (> i 10) (return s)) + (incf s i) + (incf i) + (go again)) 55) (deftest prog.8 (let ((x 0)) (prog ((y (incf x)) (z (incf x))) - (return (values x y z)))) + (return (values x y z)))) 2 1 2) (deftest prog.9 (flet ((%f () (locally (declare (special z)) z))) (prog ((z 10)) - (declare (special z)) - (return (%f)))) + (declare (special z)) + (return (%f)))) 10) (deftest prog.10 (prog () - (return - (1+ - (prog () - (go end) - done - (return 1) - end - (go done)))) - done - (return 'bad)) + (return + (1+ + (prog () + (go end) + done + (return 1) + end + (go done)))) + done + (return 'bad)) 2) (deftest prog.11 @@ -76,8 +76,8 @@ (declare (special x)) (let ((x :good)) (prog ((y x)) - (declare (special x)) - (return y)))) + (declare (special x)) + (return y)))) :good) ;;; Test that explicit calls to macroexpand in subforms @@ -112,8 +112,8 @@ (deftest prog*.5 (let ((x 'a)) (prog* ((z x) (x 'b) (y x)) - (declare (type symbol x y)) - (return (values x y z)))) + (declare (type symbol x y)) + (return (values x y z)))) b b a) (deftest prog*.6 @@ -124,39 +124,39 @@ (deftest prog*.7 (prog* ((i 1) (s 0)) - (declare (type fixnum i s)) - again - (when (> i 10) (return s)) - (incf s i) - (incf i) - (go again)) + (declare (type fixnum i s)) + again + (when (> i 10) (return s)) + (incf s i) + (incf i) + (go again)) 55) (deftest prog*.8 (let ((x 0)) (prog* ((y (incf x)) (z (incf x))) - (return (values x y z)))) + (return (values x y z)))) 2 1 2) (deftest prog*.9 (flet ((%f () (locally (declare (special z)) z))) (prog* ((z 10)) - (declare (special z)) - (return (%f)))) + (declare (special z)) + (return (%f)))) 10) (deftest prog*.10 (prog* () - (return - (1+ - (prog* () - (go end) - done - (return 1) - end - (go done)))) - done - (return 'bad)) + (return + (1+ + (prog* () + (go end) + done + (return 1) + end + (go done)))) + done + (return 'bad)) 2) (deftest prog*.11 @@ -164,8 +164,8 @@ (declare (special x)) (let ((x :good)) (prog* ((y x)) - (declare (special x)) - (return y)))) + (declare (special x)) + (return y)))) :good) ;;; Test that explicit calls to macroexpand in subforms diff --git a/ansi-tests/progn.lsp b/ansi-tests/progn.lsp index 902fc103..40e6fae8 100644 --- a/ansi-tests/progn.lsp +++ b/ansi-tests/progn.lsp @@ -31,10 +31,10 @@ (deftest progn.7 (let ((x 0)) (prog () - (progn (go x) x 'a) - (return 'bad) - x - (return 'good))) + (progn (go x) x 'a) + (return 'bad) + x + (return 'good))) good) ;;; No implicit tagbody @@ -61,7 +61,7 @@ (macrolet ((%m (z) z)) (progn (expand-in-current-env (%m :bad)) - (expand-in-current-env (%m :good)))) + (expand-in-current-env (%m :good)))) :good) diff --git a/ansi-tests/progv.lsp b/ansi-tests/progv.lsp index 83a53cfe..db15c6ef 100644 --- a/ansi-tests/progv.lsp +++ b/ansi-tests/progv.lsp @@ -20,7 +20,7 @@ (deftest progv.4 (progv '(x) '(1) (locally (declare (special x)) - x)) + x)) 1) (deftest progv.5 @@ -45,13 +45,13 @@ (deftest progv.7 (progv '(x y z) '(1 2 3) (locally (declare (special x y z)) - (values x y z))) + (values x y z))) 1 2 3) (deftest progv.8 (progv '(x y z) '(1 2 3 4 5 6 7 8) (locally (declare (special x y z)) - (values x y z))) + (values x y z))) 1 2 3) (deftest progv.9 @@ -59,9 +59,9 @@ (declare (special x)) (progv '(x y z w) '(1) (values (not (not (boundp 'x))) - (boundp 'y) - (boundp 'z) - (boundp 'w)))) + (boundp 'y) + (boundp 'z) + (boundp 'w)))) t nil nil nil) ;; forms are evaluated in order @@ -69,8 +69,8 @@ (deftest progv.10 (let ((x 0) (y 0) (c 0)) (progv - (progn (setf x (incf c)) nil) - (progn (setf y (incf c)) nil) + (progn (setf x (incf c)) nil) + (progn (setf y (incf c)) nil) (values x y c))) 1 2 2) @@ -89,9 +89,9 @@ (deftest progv.12 (progv '(x y) '(1) (locally (declare (special x y) (type nil y)) - (values - x - (boundp 'y)))) + (values + x + (boundp 'y)))) 1 nil) ;;; Macros are expanded in the appropriate environment @@ -100,32 +100,32 @@ (macrolet ((%m (z) z)) (progv (expand-in-current-env (%m '(x))) - '(:good) - (locally (declare (special x)) x))) + '(:good) + (locally (declare (special x)) x))) :good) (deftest progv.14 (macrolet ((%m (z) z)) (progv (list (expand-in-current-env (%m 'x))) - '(:good) - (locally (declare (special x)) x))) + '(:good) + (locally (declare (special x)) x))) :good) (deftest progv.15 (macrolet ((%m (z) z)) (progv '(x) - (expand-in-current-env (%m '(:good))) - (locally (declare (special x)) x))) + (expand-in-current-env (%m '(:good))) + (locally (declare (special x)) x))) :good) (deftest progv.16 (macrolet ((%m (z) z)) (progv '(x) - (list (expand-in-current-env (%m :good))) - (locally (declare (special x)) x))) + (list (expand-in-current-env (%m :good))) + (locally (declare (special x)) x))) :good) (deftest progv.17 diff --git a/ansi-tests/psetf.lsp b/ansi-tests/psetf.lsp index d4c08153..cab62808 100644 --- a/ansi-tests/psetf.lsp +++ b/ansi-tests/psetf.lsp @@ -7,16 +7,16 @@ (deftest psetf.order.1 (let ((x (vector nil nil nil nil)) - (i 0)) + (i 0)) (psetf (aref x (incf i)) (incf i)) (values x i)) #(nil 2 nil nil) 2) (deftest psetf.order.2 (let ((x (vector nil nil nil nil)) - (i 0)) + (i 0)) (psetf (aref x (incf i)) (incf i) - (aref x (incf i)) (incf i 10)) + (aref x (incf i)) (incf i 10)) (values x i)) #(nil 2 nil 13) 13) @@ -39,8 +39,8 @@ (values (symbol-macrolet ((x y)) (let ((y 1)) - (psetf x 2) - y)) + (psetf x 2) + y)) x)) 2 0) @@ -55,7 +55,7 @@ (deftest psetf.6 (let ((c 0) x y) (psetf x (incf c) - y (incf c)) + y (incf c)) (values c x y)) 2 1 2) @@ -67,20 +67,20 @@ (deftest psetf.7 (symbol-macrolet ((x (aref a (incf i))) - (y (aref a (incf i)))) + (y (aref a (incf i)))) (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) - (i 0)) + (i 0)) (psetf x (aref a (incf i)) - y (aref a (incf i))) + y (aref a (incf i))) (values a i))) #(0 2 2 4 4 5 6 7 8 9) 4) (deftest psetf.8 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) - (i 0)) + (i 0)) (psetf (aref a (incf i)) (aref a (incf i)) - (aref a (incf i)) (aref a (incf i))) + (aref a (incf i)) (aref a (incf i))) (values a i)) #(0 2 2 4 4 5 6 7 8 9) 4) @@ -88,7 +88,7 @@ (deftest psetf.9 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))) (psetf (aref a 1) (aref a 2) - (aref a 3) (aref a 4)) + (aref a 3) (aref a 4)) a) #(0 2 2 4 4 5 6 7 8 9)) @@ -98,7 +98,7 @@ (values *x* *y* (psetf *x* 6 - *y* 15) + *y* 15) *x* *y*)) 0 10 nil 6 15) @@ -108,7 +108,7 @@ (values *x* *y* (psetf *x* *y* - *y* *x*) + *y* *x*) *x* *y*)) 0 10 nil 10 0) @@ -119,56 +119,56 @@ (deftest psetf.12 (let* ((x (list 'a 'b)) - (y (list 'c 'd))) + (y (list 'c 'd))) (psetf (car x) 1 (car y) 2) (values x y)) (1 b) (2 d)) (deftest psetf.12a (let* ((x (list 'a 'b)) - (y (list 'c 'd))) + (y (list 'c 'd))) (psetf (first x) 1 (first y) 2) (values x y)) (1 b) (2 d)) (deftest psetf.13 (let* ((x (list 'a 'b)) - (y (list 'c 'd))) + (y (list 'c 'd))) (psetf (cdr x) 1 (cdr y) 2) (values x y)) (a . 1) (c . 2)) (deftest psetf.13a (let* ((x (list 'a 'b)) - (y (list 'c 'd))) + (y (list 'c 'd))) (psetf (rest x) 1 (rest y) 2) (values x y)) (a . 1) (c . 2)) (deftest psetf.14 (let* ((x (list 'a 'b)) - (y (list 'c 'd))) + (y (list 'c 'd))) (psetf (cadr x) 1 (cadr y) 2) (values x y)) (a 1) (c 2)) (deftest psetf.15 (let* ((x (list 'a 'b)) - (y (list 'c 'd))) + (y (list 'c 'd))) (psetf (cddr x) 1 (cddr y) 2) (values x y)) (a b . 1) (c d . 2)) (deftest psetf.16 (let* ((x (list (list 'a))) - (y (list (list 'c)))) + (y (list (list 'c)))) (psetf (caar x) 1 (caar y) 2) (values x y)) ((1)) ((2))) (deftest psetf.17 (let* ((x (list (list 'a))) - (y (list (list 'c)))) + (y (list (list 'c)))) (psetf (cdar x) 1 (cdar y) 2) (values x y)) ((a . 1)) ((c . 2))) @@ -178,211 +178,211 @@ (deftest psetf.18 (let* ((x (vector 'a 'b)) - (y (vector 'c 'd))) + (y (vector 'c 'd))) (psetf (aref x 0) 1 (aref y 0) 2) (values x y)) #(1 b) #(2 d)) (deftest psetf.18a (let* ((x (vector 'a 'b)) - (y (vector 'c 'd))) + (y (vector 'c 'd))) (psetf (svref x 0) 1 (svref y 0) 2) (values x y)) #(1 b) #(2 d)) (deftest psetf.19 (let* ((x (copy-seq #*11000)) - (y (copy-seq #*11100))) + (y (copy-seq #*11100))) (psetf (bit x 1) 0 (bit x 2) 1 (bit y 4) 1 (bit y 0) 0) (values x y)) #*10100 #*01101) (deftest psetf.20 (let* ((x (copy-seq "abcde")) - (y (copy-seq "fghij"))) + (y (copy-seq "fghij"))) (psetf (char x 1) #\X (char y 2) #\Y) (values x y)) "aXcde" "fgYij") (deftest psetf.21 (let* ((x (copy-seq #*11000)) - (y (copy-seq #*11100))) + (y (copy-seq #*11100))) (psetf (sbit x 1) 0 (sbit x 2) 1 (sbit y 4) 1 (sbit y 0) 0) (values x y)) #*10100 #*01101) (deftest psetf.22 (let* ((x (copy-seq "abcde")) - (y (copy-seq "fghij"))) + (y (copy-seq "fghij"))) (psetf (schar x 1) #\X (schar y 2) #\Y) (values x y)) "aXcde" "fgYij") (deftest psetf.23 (let* ((x (copy-seq '(a b c d e))) - (y (copy-seq '(f g h i j)))) + (y (copy-seq '(f g h i j)))) (psetf (elt x 1) 'u (elt y 2) 'v) (values x y)) (a u c d e) (f g v i j)) (deftest psetf.24 (let ((x #b110110001) - (y #b101001100)) + (y #b101001100)) (psetf (ldb (byte 5 1) x) #b10110 - (ldb (byte 3 6) y) #b10) + (ldb (byte 3 6) y) #b10) (values x y)) #b110101101 #b010001100) (deftest psetf.25 (let* ((f1 (gensym)) - (f2 (gensym)) - (fn1 (constantly :foo)) - (fn2 (constantly :bar))) + (f2 (gensym)) + (fn1 (constantly :foo)) + (fn2 (constantly :bar))) (psetf (fdefinition f1) fn1 - (fdefinition f2) fn2) + (fdefinition f2) fn2) (values (funcall f1) (funcall f2))) :foo :bar) (deftest psetf.26 (let* ((a1 (make-array '(10) :fill-pointer 5)) - (a2 (make-array '(20) :fill-pointer 7))) + (a2 (make-array '(20) :fill-pointer 7))) (psetf (fill-pointer a1) (1+ (fill-pointer a2)) - (fill-pointer a2) (1- (fill-pointer a1))) + (fill-pointer a2) (1- (fill-pointer a1))) (values (fill-pointer a1) (fill-pointer a2))) 8 4) (deftest psetf.27 (let* ((x (list 'a 'b 'c 'd)) - (y (list 'd 'e 'f 'g)) - (n1 1) (n2 2) - (v1 :foo) (v2 :bar)) + (y (list 'd 'e 'f 'g)) + (n1 1) (n2 2) + (v1 :foo) (v2 :bar)) (psetf (nth n1 x) v1 - (nth n2 y) v2) + (nth n2 y) v2) (values x y)) (a :foo c d) (d e :bar g)) (deftest psetf.28 (let* ((f1 (gensym)) - (f2 (gensym)) - (fn1 (constantly :foo)) - (fn2 (constantly :bar))) + (f2 (gensym)) + (fn1 (constantly :foo)) + (fn2 (constantly :bar))) (psetf (symbol-function f1) fn1 - (symbol-function f2) fn2) + (symbol-function f2) fn2) (values (funcall f1) (funcall f2))) :foo :bar) (deftest psetf.29 (let* ((s1 (gensym)) - (s2 (gensym)) - (v1 :foo) - (v2 :bar)) + (s2 (gensym)) + (v1 :foo) + (v2 :bar)) (psetf (symbol-value s1) v1 - (symbol-value s2) v2) + (symbol-value s2) v2) (values (symbol-value s1) (symbol-value s2))) :foo :bar) (deftest psetf.30 (let* ((s1 (gensym)) - (s2 (gensym)) - (v1 (list :foo 1)) - (v2 (list :bar 2))) + (s2 (gensym)) + (v1 (list :foo 1)) + (v2 (list :bar 2))) (psetf (symbol-plist s1) v1 - (symbol-plist s2) v2) + (symbol-plist s2) v2) (values (symbol-plist s1) (symbol-plist s2))) (:foo 1) (:bar 2)) (deftest psetf.31 (let* ((x (list 'a 'b 'c 'd 'e)) - (y (list 'f 'g 'h 'i 'j)) - (v1 (list 1 2)) - (v2 (list 3 4 5)) - (p1 1) (p2 2) - (l1 (length v1)) - (l2 (length v2))) + (y (list 'f 'g 'h 'i 'j)) + (v1 (list 1 2)) + (v2 (list 3 4 5)) + (p1 1) (p2 2) + (l1 (length v1)) + (l2 (length v2))) (psetf (subseq x p1 (+ p1 l1)) v1 - (subseq y p2 (+ p2 l2)) v2) + (subseq y p2 (+ p2 l2)) v2) (values x y)) (a 1 2 d e) (f g 3 4 5)) (deftest psetf.32 (let* ((x (gensym)) - (y (gensym)) - (k1 :foo) - (k2 :bar) - (v1 1) - (v2 2)) + (y (gensym)) + (k1 :foo) + (k2 :bar) + (v1 1) + (v2 2)) (psetf (get x k1) v1 (get y k2) v2) (values (symbol-plist x) (symbol-plist y))) (:foo 1) (:bar 2)) (deftest psetf.33 (let* ((x nil) - (y nil) - (k1 :foo) - (k2 :bar) - (v1 1) - (v2 2)) + (y nil) + (k1 :foo) + (k2 :bar) + (v1 1) + (v2 2)) (psetf (getf x k1) v1 (getf y k2) v2) (values x y)) (:foo 1) (:bar 2)) (deftest psetf.34 (let* ((ht1 (make-hash-table)) - (ht2 (make-hash-table)) - (k1 :foo) (v1 1) - (k2 :bar) (v2 2)) + (ht2 (make-hash-table)) + (k1 :foo) (v1 1) + (k2 :bar) (v2 2)) (psetf (gethash k1 ht1) v1 - (gethash k2 ht2) v2) + (gethash k2 ht2) v2) (values (gethash k1 ht1) (gethash k2 ht2))) 1 2) (deftest psetf.35 (let ((n1 (gensym)) - (n2 (gensym)) - (n3 (gensym)) - (n4 (gensym))) + (n2 (gensym)) + (n3 (gensym)) + (n4 (gensym))) (eval `(defclass ,n1 () ())) (eval `(defclass ,n2 () ())) (psetf (find-class n3) (find-class n1) - (find-class n4) (find-class n2)) + (find-class n4) (find-class n2)) (values (eqlt (find-class n1) (find-class n3)) - (eqlt (find-class n2) (find-class n4)))) + (eqlt (find-class n2) (find-class n4)))) t t) (deftest psetf.36 (let ((fn1 (constantly :foo)) - (fn2 (constantly :bar)) - (n1 (gensym)) - (n2 (gensym))) + (fn2 (constantly :bar)) + (n1 (gensym)) + (n2 (gensym))) (psetf (macro-function n1) fn1 - (macro-function n2) fn2) + (macro-function n2) fn2) (values (eval `(,n1)) (eval `(,n2)))) :foo :bar) (deftest psetf.37 (let ((b1 (byte 3 1)) - (b2 (byte 4 2)) - (x #b1100101011010101) - (y #b11010101000110) - (m1 #b101010101101101) - (m2 #b11110010110101)) + (b2 (byte 4 2)) + (x #b1100101011010101) + (y #b11010101000110) + (m1 #b101010101101101) + (m2 #b11110010110101)) (psetf (mask-field b1 x) m1 - (mask-field b2 y) m2) + (mask-field b2 y) m2) (values x y)) #b1100101011011101 #b11010101110110) (deftest psetf.38 (let* ((a1 (make-array '(2 3) :initial-contents '((a b c)(d e f)))) - (a2 (make-array '(3 4) :initial-contents - '((1 2 3 4) (5 6 7 8) (9 10 11 12)))) - (i1 2) (i2 5) - (v1 'u) (v2 'v)) + (a2 (make-array '(3 4) :initial-contents + '((1 2 3 4) (5 6 7 8) (9 10 11 12)))) + (i1 2) (i2 5) + (v1 'u) (v2 'v)) (psetf (row-major-aref a1 i1) v1 - (row-major-aref a2 i2) v2) + (row-major-aref a2 i2) v2) (values a1 a2)) #2a((a b u)(d e f)) #2a((1 2 3 4)(5 v 7 8)(9 10 11 12))) @@ -396,7 +396,7 @@ (let ((x 1) (y 2)) (values (psetf (expand-in-current-env (%m x)) y - y x) + y x) x y))) nil 2 1) @@ -406,7 +406,7 @@ (let ((x 1) (y 2)) (values (psetf x (expand-in-current-env (%m y)) - y x) + y x) x y))) nil 2 1) diff --git a/ansi-tests/psetq.lsp b/ansi-tests/psetq.lsp index f6a1c49c..4d00dde7 100644 --- a/ansi-tests/psetq.lsp +++ b/ansi-tests/psetq.lsp @@ -24,8 +24,8 @@ (values (symbol-macrolet ((x y)) (let ((y 1)) - (psetq x 2) - y)) + (psetq x 2) + y)) x)) 2 0) @@ -40,7 +40,7 @@ (deftest psetq.6 (let ((c 0) x y) (psetq x (incf c) - y (incf c)) + y (incf c)) (values c x y)) 2 1 2) @@ -49,11 +49,11 @@ (deftest psetq.7 (symbol-macrolet ((x (aref a (incf i))) - (y (aref a (incf i)))) + (y (aref a (incf i)))) (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) - (i 0)) + (i 0)) (psetq x (aref a (incf i)) - y (aref a (incf i))) + y (aref a (incf i))) (values a i))) #(0 2 2 4 4 5 6 7 8 9) 4) @@ -64,7 +64,7 @@ (values *x* *y* (psetq *x* 6 - *y* 15) + *y* 15) *x* *y*)) 0 10 nil 6 15) @@ -74,7 +74,7 @@ (values *x* *y* (psetq *x* *y* - *y* *x*) + *y* *x*) *x* *y*)) 0 10 nil 10 0) @@ -87,7 +87,7 @@ (let ((x nil) (y nil)) (values (psetq x (expand-in-current-env (%m 1)) - y (expand-in-current-env (%m 2))) + y (expand-in-current-env (%m 2))) x y))) nil 1 2) @@ -97,10 +97,10 @@ (deftest psetq.error.2 (signals-error (funcall (macro-function 'psetq) '(psetq)) - program-error) + program-error) t) (deftest psetq.error.3 (signals-error (funcall (macro-function 'psetq) '(psetq) nil nil) - program-error) + program-error) t) diff --git a/ansi-tests/push.lsp b/ansi-tests/push.lsp index 04bb131f..e1d97bdd 100644 --- a/ansi-tests/push.lsp +++ b/ansi-tests/push.lsp @@ -53,15 +53,15 @@ (let ((x (list nil)) (i 0) a b) (values (push (progn (setf a (incf i)) 'z) - (car (progn (setf b (incf i)) x))) + (car (progn (setf b (incf i)) x))) x i a b)) (z) ((z)) 2 1 2) (deftest push.order.2 (let ((x (vector nil nil nil nil)) - (y (vector 'a 'b 'c 'd)) - (i 1)) + (y (vector 'a 'b 'c 'd)) + (i 1)) (push (aref y (incf i)) (aref x (incf i))) (values x y i)) #(nil nil nil (c)) diff --git a/ansi-tests/pushnew.lsp b/ansi-tests/pushnew.lsp index e11a624b..e3faa990 100644 --- a/ansi-tests/pushnew.lsp +++ b/ansi-tests/pushnew.lsp @@ -18,7 +18,7 @@ (deftest pushnew.2 (let* ((x (copy-tree '(b c d a k f q))) - (y (pushnew 'a x))) + (y (pushnew 'a x))) (and (eqt x y) x)) @@ -26,7 +26,7 @@ (deftest pushnew.3 (let* ((x (copy-tree '(1 2 3 4 5 6 7 8))) - (y (pushnew 7 x))) + (y (pushnew 7 x))) (and (eqt x y) x)) @@ -34,16 +34,16 @@ (deftest pushnew.4 (let* ((x (copy-tree '((a b) 1 "and" c d e))) - (y (pushnew (copy-tree '(c d)) x - :test 'equal))) + (y (pushnew (copy-tree '(c d)) x + :test 'equal))) (and (eqt x y) - x)) + x)) ((c d) (a b) 1 "and" c d e)) (deftest pushnew.5 (let* ((x (copy-tree '((a b) 1 "and" c d e))) - (y (pushnew (copy-tree '(a b)) x - :test 'equal))) + (y (pushnew (copy-tree '(a b)) x + :test 'equal))) (and (eqt x y) x)) @@ -51,20 +51,20 @@ (deftest pushnew.6 (let* ((x (copy-tree '((a b) (c e) (d f) (g h)))) - (y (pushnew (copy-tree '(d i)) x :key #'car)) - (z (pushnew (copy-tree '(z 10)) x :key #'car))) + (y (pushnew (copy-tree '(d i)) x :key #'car)) + (z (pushnew (copy-tree '(z 10)) x :key #'car))) (and (eqt y (cdr z)) - (eqt z x) - x)) + (eqt z x) + x)) ((z 10) (a b) (c e) (d f) (g h))) (deftest pushnew.7 (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) - (y (pushnew (copy-tree '("def" 4)) x - :key #'car :test #'string=)) - (z (pushnew (copy-tree '("xyz" 10)) - x - :key #'car :test #'string=))) + (y (pushnew (copy-tree '("def" 4)) x + :key #'car :test #'string=)) + (z (pushnew (copy-tree '("xyz" 10)) + x + :key #'car :test #'string=))) (and (eqt y (cdr x)) (eqt x z) @@ -73,10 +73,10 @@ (deftest pushnew.8 (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) - (y (pushnew (copy-tree '("def" 4)) x - :key #'car :test-not (complement #'string=))) - (z (pushnew (copy-tree '("xyz" 10)) x - :key #'car :test-not (complement #'string=)))) + (y (pushnew (copy-tree '("def" 4)) x + :key #'car :test-not (complement #'string=))) + (z (pushnew (copy-tree '("xyz" 10)) x + :key #'car :test-not (complement #'string=)))) (and (eqt y (cdr x)) (eqt x z) @@ -85,10 +85,10 @@ (deftest pushnew.9 (let* ((x (copy-tree '(("abc" 1) ("def" 2) ("ghi" 3)))) - (y (pushnew (copy-tree '("def" 4)) x - :key 'car :test-not (complement #'string=))) - (z (pushnew (copy-tree '("xyz" 10)) x - :key 'car :test-not (complement #'string=)))) + (y (pushnew (copy-tree '("def" 4)) x + :key 'car :test-not (complement #'string=))) + (z (pushnew (copy-tree '("xyz" 10)) x + :key 'car :test-not (complement #'string=)))) (and (eqt y (cdr x)) (eqt x z) @@ -98,15 +98,15 @@ ;; Check that a NIL :key argument is the same as no key argument at all (deftest pushnew.10 (let* ((x (list 'a 'b 'c 'd)) - (result (pushnew 'z x :key nil))) + (result (pushnew 'z x :key nil))) result) (z a b c d)) ;; Check that a NIL :key argument is the same as no key argument at all (deftest pushnew.11 (let* ((x (copy-tree '((a b) 1 "and" c d e))) - (y (pushnew (copy-tree '(a b)) x - :test 'equal :key nil))) + (y (pushnew (copy-tree '(a b)) x + :test 'equal :key nil))) (and (eqt x y) x)) @@ -116,9 +116,9 @@ (let ((i 0) x y z (d '(b c))) (values (pushnew (progn (setf x (incf i)) 'a) - d - :key (progn (setf y (incf i)) #'identity) - :test (progn (setf z (incf i)) #'eql)) + d + :key (progn (setf y (incf i)) #'identity) + :test (progn (setf z (incf i)) #'eql)) d i x y z)) (a b c) (a b c) 3 1 2 3) @@ -127,9 +127,9 @@ (let ((i 0) x y z (d '(b c))) (values (pushnew (progn (setf x (incf i)) 'a) - d - :key (progn (setf y (incf i)) #'identity) - :test-not (progn (setf z (incf i)) (complement #'eql))) + d + :key (progn (setf y (incf i)) #'identity) + :test-not (progn (setf z (incf i)) (complement #'eql))) d i x y z)) (a b c) (a b c) 3 1 2 3) @@ -138,9 +138,9 @@ (let ((i 0) x y z (d '(b c))) (values (pushnew (progn (setf x (incf i)) 'a) - d - :test (progn (setf z (incf i)) #'eql) - :key (progn (setf y (incf i)) #'identity)) + d + :test (progn (setf z (incf i)) #'eql) + :key (progn (setf y (incf i)) #'identity)) d i x y z)) (a b c) (a b c) 3 1 3 2) @@ -149,9 +149,9 @@ (let ((i 0) x y z (d '(b c))) (values (pushnew (progn (setf x (incf i)) 'a) - d - :test-not (progn (setf z (incf i)) (complement #'eql)) - :key (progn (setf y (incf i)) #'identity)) + d + :test-not (progn (setf z (incf i)) (complement #'eql)) + :key (progn (setf y (incf i)) #'identity)) d i x y z)) (a b c) (a b c) 3 1 3 2) @@ -237,15 +237,15 @@ (defharmless pushnew.test-and-test-not.1 (let ((x '(b c))) (pushnew 'a x :test #'eql :test-not #'eql))) - + (defharmless pushnew.test-and-test-not.2 (let ((x '(b c))) (pushnew 'a x :test-not #'eql :test #'eql))) - + (deftest pushnew.order.1 (let ((x (vector nil nil nil nil)) - (y (vector 'a 'b 'c 'd)) - (i 1)) + (y (vector 'a 'b 'c 'd)) + (i 1)) (pushnew (aref y (incf i)) (aref x (incf i))) (values x y i)) #(nil nil nil (c)) @@ -254,10 +254,10 @@ (deftest pushnew.order.2 (let ((x (vector nil nil nil nil nil)) - (y (vector 'a 'b 'c 'd 'e)) - (i 1)) + (y (vector 'a 'b 'c 'd 'e)) + (i 1)) (pushnew (aref y (incf i)) (aref x (incf i)) - :test (progn (incf i) #'eql)) + :test (progn (incf i) #'eql)) (values x y i)) #(nil nil nil (c) nil) #(a b c d e) diff --git a/ansi-tests/random-aux.lsp b/ansi-tests/random-aux.lsp index 297accea..7e079a2b 100644 --- a/ansi-tests/random-aux.lsp +++ b/ansi-tests/random-aux.lsp @@ -29,38 +29,38 @@ progn." (assert cases) (let* ((weights (mapcar #'car cases)) - (cumulative-weights (let ((sum 0)) - (loop for w in weights collect (incf sum w)))) - (total (car (last cumulative-weights))) - (r (gensym))) + (cumulative-weights (let ((sum 0)) + (loop for w in weights collect (incf sum w)))) + (total (car (last cumulative-weights))) + (r (gensym))) (assert (every #'plusp weights)) (when (typep total 'ratio) (setf total (coerce total 'double-float))) `(let ((,r (random ,total))) (cond - ,@(loop for case in (butlast cases) - for cw in cumulative-weights - collect `((< ,r ,cw) ,@(cdr case))) - (t ,@(cdar (last cases))))))) + ,@(loop for case in (butlast cases) + for cw in cumulative-weights + collect `((< ,r ,cw) ,@(cdr case))) + (t ,@(cdar (last cases))))))) (defmacro rselect (cumulative-frequency-array &rest cases) (let ((len (length cases)) - (a (gensym "A")) - (max (gensym "MAX")) - (r (gensym "R")) - (p (gensym "P")) - (done (gensym "DONE"))) + (a (gensym "A")) + (max (gensym "MAX")) + (r (gensym "R")) + (p (gensym "P")) + (done (gensym "DONE"))) (assert (> len 0)) `(let ((,a ,cumulative-frequency-array)) (assert (eql ,len (length ,a))) (let* ((,max (aref ,a ,(1- len))) - (,r (random ,max))) - (block ,done - ,@(loop for i from 0 - for c in cases - collect - `(let ((,p (aref ,a ,i))) - (when (< ,r ,p) (return-from ,done ,c)))) - (error "Should not happen!")))))) + (,r (random ,max))) + (block ,done + ,@(loop for i from 0 + for c in cases + collect + `(let ((,p (aref ,a ,i))) + (when (< ,r ,p) (return-from ,done ,c)))) + (error "Should not happen!")))))) (defun make-random-integer-range (&optional var) "Generate a list (LO HI) of integers, LO <= HI. This is used @@ -68,15 +68,15 @@ (declare (ignore var)) (rcase (1 (flet ((%r () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*))))) - (- (random r) (floor (/ r 2)))))) - (let ((x (%r)) - (y (%r))) - (list (min x y) (max x y))))) + (- (random r) (floor (/ r 2)))))) + (let ((x (%r)) + (y (%r))) + (list (min x y) (max x y))))) (1 (let* ((b (ash 1 (1+ (random *maximum-random-int-bits*)))) - (b2 (floor (/ b 2)))) - (let ((x (- (random b) b2)) - (y (- (random b) b2))) - (list (min x y) (max x y))))))) + (b2 (floor (/ b 2)))) + (let ((x (- (random b) b2)) + (y (- (random b) b2))) + (list (min x y) (max x y))))))) (defun random-nonnegative-real () (if (coin 3) @@ -86,14 +86,14 @@ (/ (random 100000000) (1+ (random 10000000))) (/ (random 1000000000000) (1+ (random 10000000)))) (random (random-case - 1000 - 100000 - 10000000 - 1000000000 - (expt 2.0s0 (random 15)) - (expt 2.0f0 (random 32)) - (expt 2.0d0 (random 32)) - (expt 2.0l0 (random 32)))))) + 1000 + 100000 + 10000000 + 1000000000 + (expt 2.0s0 (random 15)) + (expt 2.0f0 (random 32)) + (expt 2.0d0 (random 32)) + (expt 2.0l0 (random 32)))))) (defun make-random-integer () (let ((r (ash 1 (1+ (random *maximum-random-int-bits*))))) @@ -104,21 +104,21 @@ (defun make-random-rational () (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) - (n (random r))) + (n (random r))) (assert (>= r 2)) (let ((d (loop for x = (random r) unless (zerop x) do (return x)))) (if (coin) (/ n d) (- (/ n d)))))) (defun make-random-nonnegative-rational () (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) - (n (random r))) + (n (random r))) (assert (>= r 2)) (let ((d (loop for x = (random r) unless (zerop x) do (return x)))) (/ n d)))) (defun make-random-positive-rational () (let* ((r (ash 1 (1+ (random *maximum-random-int-bits*)))) - (n (1+ (random r)))) + (n (1+ (random r)))) (assert (>= r 2)) (let ((d (loop for x = (random r) unless (zerop x) do (return x)))) (/ n d)))) @@ -138,9 +138,9 @@ (assert (< 1/1000000 upper-limit 1000000)) (let ((x 0)) (loop do (setq x (* upper-limit (rational (random 1.0)))) - while (or (and (not lower-inclusive) (zerop x)) - (and (not upper-inclusive) (= x upper-limit))) - finally (return x)))))) + while (or (and (not lower-inclusive) (zerop x)) + (and (not upper-inclusive) (= x upper-limit))) + finally (return x)))))) (defun make-random-float () (rcase @@ -169,7 +169,7 @@ (rcase (1 (apply #'cons (mapcar #'random-thing (random-partition (1- n) 2)))) (1 (apply #'vector (mapcar #'random-thing - (random-partition (1- n) (max 10 (1- n)))))) + (random-partition (1- n) (max 10 (1- n)))))) ))) (defparameter *use-random-byte* t) @@ -181,47 +181,47 @@ (use-random-byte nil) (etype 'character) (s (random-case - (progn - (setf use-random-byte *use-random-byte*) - (make-string size :element-type 'character)) - (progn - (setf use-random-byte *use-random-byte*) - (make-array size :element-type 'character - :initial-element #\a)) - (make-array size :element-type (setf etype (if *random-readable* 'character 'standard-char)) - :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t))) - :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size))))) - :initial-element #\a) - (make-array size :element-type (setf etype (if *random-readable* 'character 'base-char)) - :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t))) - :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size))))) - :initial-element #\a)))) + (progn + (setf use-random-byte *use-random-byte*) + (make-string size :element-type 'character)) + (progn + (setf use-random-byte *use-random-byte*) + (make-array size :element-type 'character + :initial-element #\a)) + (make-array size :element-type (setf etype (if *random-readable* 'character 'standard-char)) + :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t))) + :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size))))) + :initial-element #\a) + (make-array size :element-type (setf etype (if *random-readable* 'character 'base-char)) + :adjustable (and (not simple) (not *random-readable*) (rcase (3 nil) (1 t))) + :fill-pointer (and (not simple) (not *random-readable*) (rcase (3 nil) (1 (random (1+ size))))) + :initial-element #\a)))) (if (coin) - (dotimes (i size) - (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4)))) + (dotimes (i size) + (setf (char s i) (elt #(#\a #\b #\A #\B) (random 4)))) (dotimes (i size) - (setf (char s i) - (or (and (eql etype 'character) - use-random-byte - (or (code-char (random (min char-code-limit (ash 1 16)))) - (code-char (random 256)))) - (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" - (random 62)))))) + (setf (char s i) + (or (and (eql etype 'character) + use-random-byte + (or (code-char (random (min char-code-limit (ash 1 16)))) + (code-char (random 256)))) + (elt "abcdefghijklmnopqrstuvwyxzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" + (random 62)))))) (when (and (not simple) (not *random-readable*) (coin 5)) (let ((len (+ (random (1+ size)) size))) - (setq s (make-random-string len)) - (setq etype (array-element-type s)) - (setq s (make-array size - :element-type etype - :displaced-to s - :displaced-index-offset (random (1+ (- len size))))))) - + (setq s (make-random-string len)) + (setq etype (array-element-type s)) + (setq s (make-array size + :element-type etype + :displaced-to s + :displaced-index-offset (random (1+ (- len size))))))) + s)) (defun random-leaf () (rcase (1 (let ((k (ash 1 (1+ (random 40))))) - (random-from-interval k (- k)))) + (random-from-interval k (- k)))) (1 (random-from-seq +standard-chars+)) (1 (random-real)) (1 (make-random-string (random 20))) @@ -241,18 +241,18 @@ (setq seq (copy-seq seq)) (let ((len (length seq))) (loop for i from len downto 2 - do (let ((r (random i))) - (rotatef (elt seq r) (elt seq (1- i)))))) + do (let ((r (random i))) + (rotatef (elt seq r) (elt seq (1- i)))))) seq) (defun binomial-distribution-test (n fn) (let* ((count (loop repeat n count (funcall fn))) - (sigma (/ (sqrt n) 2.0)) - (bound (* sigma 6)) - (expected (/ n 2.0))) + (sigma (/ (sqrt n) 2.0)) + (bound (* sigma 6)) + (expected (/ n 2.0))) (<= (- expected bound) - count - (+ expected bound)))) + count + (+ expected bound)))) (defun random-partition* (n p) "Partition n into p numbers, each >= 0. Return list of numbers." @@ -261,18 +261,18 @@ ((= p 1) (list n)) ((= n 0) (make-list p :initial-element 0)) (t (let* ((r (random p)) - (n1 (random (1+ n)))) - (cond - ((= r 0) - (cons n1 (random-partition* (- n n1) (1- p)))) - ((= r (1- p)) - (append (random-partition* (- n n1) (1- p)) (list n1))) - (t - (let* ((n2 (random (1+ (- n n1)))) - (n3 (- n n1 n2))) - (append (random-partition* n2 r) - (list n1) - (random-partition* n3 (- p 1 r)))))))))) + (n1 (random (1+ n)))) + (cond + ((= r 0) + (cons n1 (random-partition* (- n n1) (1- p)))) + ((= r (1- p)) + (append (random-partition* (- n n1) (1- p)) (list n1))) + (t + (let* ((n2 (random (1+ (- n n1)))) + (n3 (- n n1 n2))) + (append (random-partition* n2 r) + (list n1) + (random-partition* n3 (- p 1 r)))))))))) (defun random-partition (n p) "Partition n into p numbers, each >= 1 (if possible.)" @@ -298,10 +298,10 @@ (define-method-combination randomized nil ((method-list positive-integer-qualifier-p)) (assert method-list) (let ((clauses (mapcar #'(lambda (method) - (let ((weight (car (method-qualifiers method)))) - `(,weight (call-method ,method)))) - method-list))) + (let ((weight (car (method-qualifiers method)))) + `(,weight (call-method ,method)))) + method-list))) `(loop (catch 'fail (return (rcase ,@clauses)))))) #+armedbear -(warn "ABCL doesn't support the long form of DEFINE-METHOD-COMBINATION; randomized testing disabled.") \ No newline at end of file +(warn "ABCL doesn't support the long form of DEFINE-METHOD-COMBINATION; randomized testing disabled.") diff --git a/ansi-tests/random-class-aux.lsp b/ansi-tests/random-class-aux.lsp index 83e8b3f8..292e3977 100644 --- a/ansi-tests/random-class-aux.lsp +++ b/ansi-tests/random-class-aux.lsp @@ -10,27 +10,27 @@ (assert (typep n '(integer 1)) (n) "N is ~A" n) (assert (typep rep 'unsigned-byte) (rep) "REP is ~A" rep) (let ((class-names (make-array n - :initial-contents - (loop for i from 1 to n - collect (make-symbol - (format nil "CLASS-NAME-~D" i)))))) + :initial-contents + (loop for i from 1 to n + collect (make-symbol + (format nil "CLASS-NAME-~D" i)))))) (unwind-protect - (let ((parents (make-array n :initial-element nil))) - ;; Create classes - (loop for name across class-names - do (eval `(defclass ,name () nil))) - (loop for i = (1+ (random (1- n))) - for name = (elt class-names i) - for parent = (elt parents i) - repeat rep - do (if parent - (progn - (setf (elt parents i) nil) - (eval `(defclass ,name () nil))) - (eval `(defclass ,name - (,(setf (elt parents i) (elt class-names (1- i)))) - nil - ))))) + (let ((parents (make-array n :initial-element nil))) + ;; Create classes + (loop for name across class-names + do (eval `(defclass ,name () nil))) + (loop for i = (1+ (random (1- n))) + for name = (elt class-names i) + for parent = (elt parents i) + repeat rep + do (if parent + (progn + (setf (elt parents i) nil) + (eval `(defclass ,name () nil))) + (eval `(defclass ,name + (,(setf (elt parents i) (elt class-names (1- i)))) + nil + ))))) (loop for name across class-names - do (setf (find-class name) nil))))) + do (setf (find-class name) nil))))) diff --git a/ansi-tests/random-int-form.lsp b/ansi-tests/random-int-form.lsp index 5edef21b..7c18b164 100644 --- a/ansi-tests/random-int-form.lsp +++ b/ansi-tests/random-int-form.lsp @@ -112,8 +112,8 @@ `(let* ((,len (length *default-make-random-integer-form-cdf*)) (,vec (make-array ,len))) (loop for i from 0 below ,len do (setf (aref ,vec i) - (1+ (min (random 100) - (random 100))))) + (1+ (min (random 100) + (random 100))))) (setq ,vec (cumulate ,vec)) (let ((*make-random-integer-form-cdf* ,vec)) ,@forms))))) @@ -241,7 +241,7 @@ (print '(load "c.lsp") s) (finish-output s)) ;; (cl-user::gc) - ;; (make-list 1000000) + ;; (make-list 1000000) ) (test-int-form form vars var-types vals-list opt-decls-1 opt-decls-2))) @@ -275,7 +275,7 @@ (intern (concatenate 'string (subseq (symbol-name fn-name) 1) (format nil "-~D" arg-index)) - (symbol-package fn-name))) + (symbol-package fn-name))) (declaim (special *flet-names*)) (defparameter *flet-names* nil) @@ -371,11 +371,11 @@ (sizes (random-partition (1- size) (+ nforms 2))) (args (mapcar #'make-random-integer-form sizes))) `(prog2 ,@args)) - + `(isqrt (abs ,(make-random-integer-form (- size 2)))) `(the integer ,(make-random-integer-form (1- size))) - + `(cl:handler-bind nil ,(make-random-integer-form (1- size))) `(restart-bind nil ,(make-random-integer-form (1- size))) #-armedbear @@ -415,14 +415,14 @@ ;; eval (make-random-integer-eval-form size) - + #-(or cmu allegro poplog) (destructuring-bind (s1 s2) (random-partition (- size 2) 2) `(ash ,(make-random-integer-form s1) (min ,(random 100) ,(make-random-integer-form s2)))) - + ;; binary floor, ceiling, truncate, round (let ((op (random-from-seq #(floor ceiling truncate round mod rem))) (op2 (random-from-seq #(max min)))) @@ -433,7 +433,7 @@ (1+ (random 100)) (- (1+ (random 100)))) ,(make-random-integer-form s2))))) - + ;; Binary op (let* ((op (random-from-seq '(+ - * logand min max gcd @@ -477,7 +477,7 @@ ;; coerce `(coerce ,(make-random-integer-form (1- size)) 'integer) - + ;; complex (degenerate case) `(complex ,(make-random-integer-form (1- size)) 0) @@ -513,7 +513,7 @@ ;; progv (make-random-integer-progv-form size) - + `(let () ,(make-random-integer-form (1- size))) (let* ((name (random-from-seq #(b1 b2 b3 b4 b5 b6 b7 b8))) @@ -523,7 +523,7 @@ (let* ((tag (list 'quote (random-from-seq #(ct1 ct2 ct2 ct4 ct5 ct6 ct7 ct8)))) (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) `(catch ,tag ,(make-random-integer-form (1- size)))) - + ;; setq and similar (make-random-integer-setq-form size) @@ -783,7 +783,7 @@ ,@(mapcar #'make-random-integer-form sizes)) ,@keyargs))) #-(or armedbear) - (1 + (1 (destructuring-bind (size1 size2) (random-partition (1- size) 2) (let* ((vars '(lmv1 lmv2 lmv3 lmv4 lmv5 lmv6)) (var1 (random-from-seq vars)) @@ -1039,7 +1039,7 @@ (2 nil) (1 (list :test `(quote ,test))) (1 (list :test-not `(quote ,test))))))))) - + (1 (let ((index (random (1+ (random *maximum-random-int-bits*)))) (form (make-random-integer-form (1- size)))) `(logbitp ,index ,form))) @@ -1084,246 +1084,246 @@ (defgeneric make-random-element-of-compound-type (type-op type-args) (:documentation "Create a random element of type `(,TYPE-OP ,@TYPE-ARGS)") (:method ((type-op (eql 'or)) type-args) - (assert type-args) - (make-random-element-of-type (random-from-seq type-args))) + (assert type-args) + (make-random-element-of-type (random-from-seq type-args))) (:method ((type-op (eql 'and)) type-args) - (assert type-args) - (loop for x = (make-random-element-of-type (car type-args)) - repeat 100 - when (typep x (cons 'and (cdr type-args))) - return x - finally (error "Cannot generate random element of ~A" - (cons type-op type-args)))) + (assert type-args) + (loop for x = (make-random-element-of-type (car type-args)) + repeat 100 + when (typep x (cons 'and (cdr type-args))) + return x + finally (error "Cannot generate random element of ~A" + (cons type-op type-args)))) (:method ((type-op (eql 'not)) type-args) - (assert (eql (length type-args) 1)) - (make-random-element-of-type `(and t (not ,(car type-args))))) + (assert (eql (length type-args) 1)) + (make-random-element-of-type `(and t (not ,(car type-args))))) (:method ((type-op (eql 'integer)) type-args) - (let ((lo (let ((lo (car type-args))) - (cond - ((consp lo) (1+ (car lo))) - ((eq lo nil) '*) - (t lo)))) - (hi (let ((hi (cadr type-args))) - (cond - ((consp hi) (1- (car hi))) - ((eq hi nil) '*) - (t hi))))) - (if (eq lo '*) - (if (eq hi '*) - (let ((x (ash 1 (random *maximum-random-int-bits*)))) - (random-from-interval x (- x))) - (random-from-interval (1+ hi) - (- hi (random (ash 1 *maximum-random-int-bits*))))) - - (if (eq hi '*) - (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) - lo) - ;; May generalize the next case to increase odds - ;; of certain integers (near 0, near endpoints, near - ;; powers of 2...) - (random-from-interval (1+ hi) lo))))) + (let ((lo (let ((lo (car type-args))) + (cond + ((consp lo) (1+ (car lo))) + ((eq lo nil) '*) + (t lo)))) + (hi (let ((hi (cadr type-args))) + (cond + ((consp hi) (1- (car hi))) + ((eq hi nil) '*) + (t hi))))) + (if (eq lo '*) + (if (eq hi '*) + (let ((x (ash 1 (random *maximum-random-int-bits*)))) + (random-from-interval x (- x))) + (random-from-interval (1+ hi) + (- hi (random (ash 1 *maximum-random-int-bits*))))) + + (if (eq hi '*) + (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) + lo) + ;; May generalize the next case to increase odds + ;; of certain integers (near 0, near endpoints, near + ;; powers of 2...) + (random-from-interval (1+ hi) lo))))) (:method ((type-op (eql 'rational)) type-args) - (let ((type (cons type-op type-args))) - (or - (let ((r (make-random-element-of-type 'rational))) - (and (typep r type) r)) - (let ((lo (car type-args)) - (hi (cadr type-args)) - lo= hi=) - (cond - ((consp lo) nil) - ((member lo '(* nil)) - (setq lo nil) - (setq lo= nil)) - (t - (assert (typep lo 'rational)) - (setq lo= t))) - (cond - ((consp hi) nil) - ((member hi '(* nil)) - (setq hi nil) - (setq hi= nil)) - (t - (assert (typep hi 'rational)) - (setq hi= t))) - (assert (or (null lo) (null hi) (<= lo hi))) - (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) - (cond - ((null lo) - (cond - ((null hi) (make-random-rational)) - (hi= (- hi (make-random-nonnegative-rational))) - (t (- hi (make-random-positive-rational))))) - ((null hi) - (cond - (lo= (+ lo (make-random-nonnegative-rational))) - (t (+ lo (make-random-positive-rational))))) - (t - (+ lo (make-random-bounded-rational (- hi lo) lo= hi=)))))))) - + (let ((type (cons type-op type-args))) + (or + (let ((r (make-random-element-of-type 'rational))) + (and (typep r type) r)) + (let ((lo (car type-args)) + (hi (cadr type-args)) + lo= hi=) + (cond + ((consp lo) nil) + ((member lo '(* nil)) + (setq lo nil) + (setq lo= nil)) + (t + (assert (typep lo 'rational)) + (setq lo= t))) + (cond + ((consp hi) nil) + ((member hi '(* nil)) + (setq hi nil) + (setq hi= nil)) + (t + (assert (typep hi 'rational)) + (setq hi= t))) + (assert (or (null lo) (null hi) (<= lo hi))) + (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) + (cond + ((null lo) + (cond + ((null hi) (make-random-rational)) + (hi= (- hi (make-random-nonnegative-rational))) + (t (- hi (make-random-positive-rational))))) + ((null hi) + (cond + (lo= (+ lo (make-random-nonnegative-rational))) + (t (+ lo (make-random-positive-rational))))) + (t + (+ lo (make-random-bounded-rational (- hi lo) lo= hi=)))))))) + (:method ((type-op (eql 'ratio)) type-args) - (let ((r 0)) - (loop - do (setq r (make-random-element-of-compound-type 'rational type-args)) - while (integerp r)) - r)) - + (let ((r 0)) + (loop + do (setq r (make-random-element-of-compound-type 'rational type-args)) + while (integerp r)) + r)) + (:method ((type-op (eql 'real)) type-args) - (rcase - (1 (let ((lo (and (numberp (car type-args)) - (rational (car type-args)))) - (hi (and (numberp (cadr type-args)) - (rational (cadr type-args))))) - (make-random-element-of-compound-type 'rational - `(,(or lo '*) - ,(or hi '*))))) - (1 (make-random-element-of-compound-type 'float - `(,(or (car type-args) '*) - ,(or (cadr type-args) '*)))))) - + (rcase + (1 (let ((lo (and (numberp (car type-args)) + (rational (car type-args)))) + (hi (and (numberp (cadr type-args)) + (rational (cadr type-args))))) + (make-random-element-of-compound-type 'rational + `(,(or lo '*) + ,(or hi '*))))) + (1 (make-random-element-of-compound-type 'float + `(,(or (car type-args) '*) + ,(or (cadr type-args) '*)))))) + (:method ((type-op (eql 'float)) type-args) - (let* ((new-type-op (random-from-seq #(single-float double-float long-float short-float))) - (lo (car type-args)) - (hi (cadr type-args)) - (most-neg (most-negative-float new-type-op)) - (most-pos (most-positive-float new-type-op))) - (cond - ((or (and (realp lo) (< lo most-neg)) - (and (realp hi) (> hi most-pos))) - ;; try again - (make-random-element-of-compound-type type-op type-args)) - (t - (when (and (realp lo) (not (typep lo new-type-op))) - (cond - ((< lo most-neg) (setq lo '*)) - (t (setq lo (coerce lo new-type-op))))) - (when (and (realp hi) (not (typep hi new-type-op))) - (cond - ((> hi most-pos) (setq hi '*)) - (t (setq hi (coerce hi new-type-op))))) - (make-random-element-of-compound-type new-type-op `(,(or lo '*) ,(or hi '*))))))) - + (let* ((new-type-op (random-from-seq #(single-float double-float long-float short-float))) + (lo (car type-args)) + (hi (cadr type-args)) + (most-neg (most-negative-float new-type-op)) + (most-pos (most-positive-float new-type-op))) + (cond + ((or (and (realp lo) (< lo most-neg)) + (and (realp hi) (> hi most-pos))) + ;; try again + (make-random-element-of-compound-type type-op type-args)) + (t + (when (and (realp lo) (not (typep lo new-type-op))) + (cond + ((< lo most-neg) (setq lo '*)) + (t (setq lo (coerce lo new-type-op))))) + (when (and (realp hi) (not (typep hi new-type-op))) + (cond + ((> hi most-pos) (setq hi '*)) + (t (setq hi (coerce hi new-type-op))))) + (make-random-element-of-compound-type new-type-op `(,(or lo '*) ,(or hi '*))))))) + (:method ((type-op (eql 'short-float)) type-args) - (assert (<= (length type-args) 2)) - (apply #'make-random-element-of-float-type type-op type-args)) + (assert (<= (length type-args) 2)) + (apply #'make-random-element-of-float-type type-op type-args)) (:method ((type-op (eql 'single-float)) type-args) - (assert (<= (length type-args) 2)) - (apply #'make-random-element-of-float-type type-op type-args)) + (assert (<= (length type-args) 2)) + (apply #'make-random-element-of-float-type type-op type-args)) (:method ((type-op (eql 'double-float)) type-args) - (assert (<= (length type-args) 2)) - (apply #'make-random-element-of-float-type type-op type-args)) + (assert (<= (length type-args) 2)) + (apply #'make-random-element-of-float-type type-op type-args)) (:method ((type-op (eql 'long-float)) type-args) - (assert (<= (length type-args) 2)) - (apply #'make-random-element-of-float-type type-op type-args)) - + (assert (<= (length type-args) 2)) + (apply #'make-random-element-of-float-type type-op type-args)) + (:method ((type-op (eql 'mod)) type-args) - (let ((modulus (second type-args))) - (assert (integerp modulus)) - (assert (plusp modulus)) - (make-random-element-of-compound-type 'integer `(0 (,modulus))))) - + (let ((modulus (second type-args))) + (assert (integerp modulus)) + (assert (plusp modulus)) + (make-random-element-of-compound-type 'integer `(0 (,modulus))))) + (:method ((type-op (eql 'unsigned-byte)) type-args) - (assert (<= (length type-args) 1)) - (if (null type-args) - (make-random-element-of-type '(integer 0 *)) - (let ((bits (first type-args))) - (if (eq bits '*) - (make-random-element-of-type '(integer 0 *)) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of-type - `(integer 0 ,(1- (ash 1 bits))))))))) - + (assert (<= (length type-args) 1)) + (if (null type-args) + (make-random-element-of-type '(integer 0 *)) + (let ((bits (first type-args))) + (if (eq bits '*) + (make-random-element-of-type '(integer 0 *)) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of-type + `(integer 0 ,(1- (ash 1 bits))))))))) + (:method ((type-op (eql 'signed-byte)) type-args) - (assert (<= (length type-args) 1)) - (if (null type-args) - (make-random-element-of-type 'integer) - (let ((bits (car type-args))) - (if (eq bits'*) - (make-random-element-of-type 'integer) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of-type - `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) + (assert (<= (length type-args) 1)) + (if (null type-args) + (make-random-element-of-type 'integer) + (let ((bits (car type-args))) + (if (eq bits'*) + (make-random-element-of-type 'integer) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of-type + `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) (:method ((type-op (eql 'eql)) type-args) - (assert (= (length type-args) 1)) - (car type-args)) + (assert (= (length type-args) 1)) + (car type-args)) (:method ((type-op (eql 'member)) type-args) - (assert type-args) - (random-from-seq type-args)) - + (assert type-args) + (random-from-seq type-args)) + (:method ((type-op (eql 'vector)) type-args) - (assert (<= (length type-args) 2)) - (let ((etype-spec (if type-args (car type-args) '*)) - (size-spec (if (cdr type-args) (cadr type-args) '*))) - (make-random-vector etype-spec size-spec))) - + (assert (<= (length type-args) 2)) + (let ((etype-spec (if type-args (car type-args) '*)) + (size-spec (if (cdr type-args) (cadr type-args) '*))) + (make-random-vector etype-spec size-spec))) + (:method ((type-op (eql 'aimple-vector)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-vector t size-spec :simple t))) - + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-vector t size-spec :simple t))) + (:method ((type-op (eql 'array)) type-args) - (assert (<= (length type-args) 2)) - (let ((etype-spec (if type-args (car type-args) '*)) - (size-spec (if (cdr type-args) (cadr type-args) '*))) - (make-random-array etype-spec size-spec))) - + (assert (<= (length type-args) 2)) + (let ((etype-spec (if type-args (car type-args) '*)) + (size-spec (if (cdr type-args) (cadr type-args) '*))) + (make-random-array etype-spec size-spec))) + (:method ((type-op (eql 'simple-array)) type-args) - (assert (<= (length type-args) 2)) - (let ((etype-spec (if type-args (car type-args) '*)) - (size-spec (if (cdr type-args) (cadr type-args) '*))) - (make-random-array etype-spec size-spec :simple t))) + (assert (<= (length type-args) 2)) + (let ((etype-spec (if type-args (car type-args) '*)) + (size-spec (if (cdr type-args) (cadr type-args) '*))) + (make-random-array etype-spec size-spec :simple t))) (:method ((type-op (eql 'string)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-string size-spec))) + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-string size-spec))) (:method ((type-op (eql 'simple-string)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-string size-spec :simple t))) - + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-string size-spec :simple t))) + (:method ((type-op (eql 'base-string)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-vector 'base-char size-spec))) - + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-vector 'base-char size-spec))) + (:method ((type-op (eql 'simple-base-string)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-vector 'base-char size-spec :simple t))) - + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-vector 'base-char size-spec :simple t))) + (:method ((type-op (eql 'bit-vector)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-vector 'bit size-spec))) - + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-vector 'bit size-spec))) + (:method ((type-op (eql 'simple-bit-vector)) type-args) - (assert (<= (length type-args) 1)) - (let ((size-spec (if type-args (car type-args) '*))) - (make-random-vector 'bit size-spec :simple t))) - + (assert (<= (length type-args) 1)) + (let ((size-spec (if type-args (car type-args) '*))) + (make-random-vector 'bit size-spec :simple t))) + (:method ((type-op (eql 'cons)) type-args) - (assert (<= (length type-args) 2)) - (cons (make-random-element-of-type (if type-args (car type-args) t)) - (make-random-element-of-type (if (cdr type-args) (cadr type-args) t)))) - + (assert (<= (length type-args) 2)) + (cons (make-random-element-of-type (if type-args (car type-args) t)) + (make-random-element-of-type (if (cdr type-args) (cadr type-args) t)))) + (:method ((type-op (eql 'complex)) type-args) - (cond - ((null type-args) - (make-random-element-of-type 'complex)) - (t - (assert (null (cdr type-args))) - (let ((etype (car type-args))) - (loop for v1 = (make-random-element-of-type etype) - for v2 = (make-random-element-of-type etype) - for c = (complex v1 v2) - when (typep c (cons 'complex type-args)) - return c))))) + (cond + ((null type-args) + (make-random-element-of-type 'complex)) + (t + (assert (null (cdr type-args))) + (let ((etype (car type-args))) + (loop for v1 = (make-random-element-of-type etype) + for v2 = (make-random-element-of-type etype) + for c = (complex v1 v2) + when (typep c (cons 'complex type-args)) + return c))))) ) (defmethod make-random-element-of-type ((type cons)) @@ -1352,15 +1352,15 @@ (let ((limit 100000)) (cond ((or (<= hi 0) - (>= lo 0) - (and (<= (- limit) hi limit) (<= (- limit) lo limit))) - (loop for x = (+ (random (- hi lo)) lo) - do (when (or lo= (/= x lo)) (return x)))) + (>= lo 0) + (and (<= (- limit) hi limit) (<= (- limit) lo limit))) + (loop for x = (+ (random (- hi lo)) lo) + do (when (or lo= (/= x lo)) (return x)))) (t - (rcase - (1 (random (min hi (float limit hi)))) - (1 (- (random (min (float limit lo) (- lo))))))))))) - + (rcase + (1 (random (min hi (float limit hi)))) + (1 (- (random (min (float limit lo) (- lo))))))))))) + #| (defmethod make-random-element-of-type ((type cons)) (let ((type-op (first type))) @@ -1371,32 +1371,32 @@ (and (assert (cdr type)) (loop for x = (make-random-element-of-type (cadr type)) - repeat 100 - when (typep x (cons 'and (cddr type))) - return x - finally (error "Cannot generate random element of ~A" type))) + repeat 100 + when (typep x (cons 'and (cddr type))) + return x + finally (error "Cannot generate random element of ~A" type))) (not (assert (cdr type)) (assert (not (cddr type))) (make-random-element-of-type `(and t ,type))) (integer (let ((lo (let ((lo (cadr type))) - (cond - ((consp lo) (1+ (car lo))) - ((eq lo nil) '*) - (t lo)))) - (hi (let ((hi (caddr type))) - (cond - ((consp hi) (1- (car hi))) - ((eq hi nil) '*) - (t hi))))) + (cond + ((consp lo) (1+ (car lo))) + ((eq lo nil) '*) + (t lo)))) + (hi (let ((hi (caddr type))) + (cond + ((consp hi) (1- (car hi))) + ((eq hi nil) '*) + (t hi))))) (if (eq lo '*) (if (eq hi '*) (let ((x (ash 1 (random *maximum-random-int-bits*)))) (random-from-interval x (- x))) (random-from-interval (1+ hi) (- hi (random (ash 1 *maximum-random-int-bits*))))) - + (if (eq hi '*) (random-from-interval (+ lo (random (ash 1 *maximum-random-int-bits*)) 1) lo) @@ -1404,146 +1404,146 @@ ;; of certain integers (near 0, near endpoints, near ;; powers of 2...) (random-from-interval (1+ hi) lo))))) - + (rational (or - (let ((r (make-random-element-of-type 'rational))) - (and (typep r type) r)) - (let ((lo (cadr type)) - (hi (caddr type)) - lo= hi=) - (cond - ((consp lo) nil) - ((member lo '(* nil)) - (setq lo nil) - (setq lo= nil)) - (t - (assert (typep lo 'rational)) - (setq lo= t))) - (cond - ((consp hi) nil) - ((member hi '(* nil)) - (setq hi nil) - (setq hi= nil)) - (t - (assert (typep hi 'rational)) - (setq hi= t))) - (assert (or (null lo) (null hi) (<= lo hi))) - (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) - (cond - ((null lo) - (cond - ((null hi) (make-random-rational)) - (hi= (- hi (make-random-nonnegative-rational))) - (t (- hi (make-random-positive-rational))))) - ((null hi) - (cond - (lo= (+ lo (make-random-nonnegative-rational))) - (t (+ lo (make-random-positive-rational))))) - (t - (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))) - + (let ((r (make-random-element-of-type 'rational))) + (and (typep r type) r)) + (let ((lo (cadr type)) + (hi (caddr type)) + lo= hi=) + (cond + ((consp lo) nil) + ((member lo '(* nil)) + (setq lo nil) + (setq lo= nil)) + (t + (assert (typep lo 'rational)) + (setq lo= t))) + (cond + ((consp hi) nil) + ((member hi '(* nil)) + (setq hi nil) + (setq hi= nil)) + (t + (assert (typep hi 'rational)) + (setq hi= t))) + (assert (or (null lo) (null hi) (<= lo hi))) + (assert (or (null lo) (null hi) (< lo hi) (and lo= hi=))) + (cond + ((null lo) + (cond + ((null hi) (make-random-rational)) + (hi= (- hi (make-random-nonnegative-rational))) + (t (- hi (make-random-positive-rational))))) + ((null hi) + (cond + (lo= (+ lo (make-random-nonnegative-rational))) + (t (+ lo (make-random-positive-rational))))) + (t + (+ lo (make-random-bounded-rational (- hi lo) lo= hi=))))))) + (ratio (let ((r 0)) - (loop - do (setq r (make-random-element-of-type `(rational ,@(cdr type)))) - while (integerp r)) - r)) - + (loop + do (setq r (make-random-element-of-type `(rational ,@(cdr type)))) + while (integerp r)) + r)) + (real (rcase - (1 (let ((lo (and (numberp (cadr type)) - (rational (cadr type)))) - (hi (and (numberp (caddr type)) - (rational (caddr type))))) - (make-random-element-of-type `(rational ,(or lo '*) - ,(or hi '*))))) - (1 (make-random-element-of-type `(float ,(or (cadr type) '*) - ,(or (caddr type) '*)))))) - + (1 (let ((lo (and (numberp (cadr type)) + (rational (cadr type)))) + (hi (and (numberp (caddr type)) + (rational (caddr type))))) + (make-random-element-of-type `(rational ,(or lo '*) + ,(or hi '*))))) + (1 (make-random-element-of-type `(float ,(or (cadr type) '*) + ,(or (caddr type) '*)))))) + ((float) (let* ((new-type-op (random-from-seq #(single-float double-float - long-float short-float))) - (lo (cadr type)) - (hi (caddr type)) - (most-neg (most-negative-float new-type-op)) - (most-pos (most-positive-float new-type-op))) - (cond - ((or (and (realp lo) (< lo most-neg)) - (and (realp hi) (> hi most-pos))) - ;; try again - (make-random-element-of-type type)) - (t - (when (and (realp lo) (not (typep lo new-type-op))) - (cond - ((< lo most-neg) (setq lo '*)) - (t (setq lo (coerce lo new-type-op))))) - (when (and (realp hi) (not (typep hi new-type-op))) - (cond - ((> hi most-pos) (setq hi '*)) - (t (setq hi (coerce hi new-type-op))))) - (make-random-element-of-type - `(,new-type-op ,(or lo '*) ,(or hi '*))))))) - + long-float short-float))) + (lo (cadr type)) + (hi (caddr type)) + (most-neg (most-negative-float new-type-op)) + (most-pos (most-positive-float new-type-op))) + (cond + ((or (and (realp lo) (< lo most-neg)) + (and (realp hi) (> hi most-pos))) + ;; try again + (make-random-element-of-type type)) + (t + (when (and (realp lo) (not (typep lo new-type-op))) + (cond + ((< lo most-neg) (setq lo '*)) + (t (setq lo (coerce lo new-type-op))))) + (when (and (realp hi) (not (typep hi new-type-op))) + (cond + ((> hi most-pos) (setq hi '*)) + (t (setq hi (coerce hi new-type-op))))) + (make-random-element-of-type + `(,new-type-op ,(or lo '*) ,(or hi '*))))))) + ((single-float double-float long-float short-float) (let ((lo (cadr type)) - (hi (caddr type)) - lo= hi=) - (cond - ((consp lo) nil) - ((member lo '(* nil)) - (setq lo (most-negative-float type-op)) - (setq lo= t)) - (t - (assert (typep lo type-op)) - (setq lo= t))) - (cond - ((consp hi) nil) - ((member hi '(* nil)) - (setq hi (most-positive-float type-op)) - (setq hi= t)) - (t - (assert (typep hi type-op)) - (setq hi= t))) - (assert (<= lo hi)) - (assert (or (< lo hi) (and lo= hi=))) - (let ((limit 100000)) - (cond - ((or (<= hi 0) - (>= lo 0) - (and (<= (- limit) hi limit) (<= (- limit) lo limit))) - (loop for x = (+ (random (- hi lo)) lo) - do (when (or lo= (/= x lo)) (return x)))) - (t - (rcase - (1 (random (min hi (float limit hi)))) - (1 (- (random (min (float limit lo) (- lo))))))))))) - + (hi (caddr type)) + lo= hi=) + (cond + ((consp lo) nil) + ((member lo '(* nil)) + (setq lo (most-negative-float type-op)) + (setq lo= t)) + (t + (assert (typep lo type-op)) + (setq lo= t))) + (cond + ((consp hi) nil) + ((member hi '(* nil)) + (setq hi (most-positive-float type-op)) + (setq hi= t)) + (t + (assert (typep hi type-op)) + (setq hi= t))) + (assert (<= lo hi)) + (assert (or (< lo hi) (and lo= hi=))) + (let ((limit 100000)) + (cond + ((or (<= hi 0) + (>= lo 0) + (and (<= (- limit) hi limit) (<= (- limit) lo limit))) + (loop for x = (+ (random (- hi lo)) lo) + do (when (or lo= (/= x lo)) (return x)))) + (t + (rcase + (1 (random (min hi (float limit hi)))) + (1 (- (random (min (float limit lo) (- lo))))))))))) + (mod (let ((modulus (second type))) - (assert (and (integerp modulus) - (plusp modulus))) - (make-random-element-of-type `(integer 0 (,modulus))))) + (assert (and (integerp modulus) + (plusp modulus))) + (make-random-element-of-type `(integer 0 (,modulus))))) (unsigned-byte (if (null (cdr type)) (make-random-element-of-type '(integer 0 *)) - (let ((bits (second type))) - (if (eq bits'*) - (make-random-element-of-type '(integer 0 *)) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of-type - `(integer 0 ,(1- (ash 1 bits))))))))) + (let ((bits (second type))) + (if (eq bits'*) + (make-random-element-of-type '(integer 0 *)) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of-type + `(integer 0 ,(1- (ash 1 bits))))))))) (signed-byte (if (null (cdr type)) (make-random-element-of-type 'integer) - (let ((bits (second type))) - (if (eq bits'*) - (make-random-element-of-type 'integer) - (progn - (assert (and (integerp bits) (>= bits 1))) - (make-random-element-of-type - `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) + (let ((bits (second type))) + (if (eq bits'*) + (make-random-element-of-type 'integer) + (progn + (assert (and (integerp bits) (>= bits 1))) + (make-random-element-of-type + `(integer ,(- (ash 1 (1- bits))) ,(1- (ash 1 (1- bits)))))))))) (eql (assert (= (length type) 2)) (cadr type)) @@ -1552,39 +1552,39 @@ (random-from-seq (cdr type))) ((vector) (let ((etype-spec (if (cdr type) (cadr type) '*)) - (size-spec (if (cddr type) (caddr type) '*))) - (make-random-vector etype-spec size-spec))) + (size-spec (if (cddr type) (caddr type) '*))) + (make-random-vector etype-spec size-spec))) ((simple-vector) (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-vector t size-spec :simple t))) + (make-random-vector t size-spec :simple t))) ((array simple-array) (let ((etype-spec (if (cdr type) (cadr type) '*)) - (size-spec (if (cddr type) (caddr type) '*))) - (make-random-array etype-spec size-spec :simple (eql (car type) 'simple-array)))) + (size-spec (if (cddr type) (caddr type) '*))) + (make-random-array etype-spec size-spec :simple (eql (car type) 'simple-array)))) ((string simple-string) (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-string size-spec :simple (eql (car type) 'simple-string)))) + (make-random-string size-spec :simple (eql (car type) 'simple-string)))) ((base-string simple-base-string) (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-vector 'base-char size-spec :simple (eql (car type) 'simple-base-string)))) + (make-random-vector 'base-char size-spec :simple (eql (car type) 'simple-base-string)))) ((bit-vector simple-bit-vector) (let ((size-spec (if (cdr type) (cadr type) '*))) - (make-random-vector 'bit size-spec :simple (eql (car type) 'simple-bit-vector)))) + (make-random-vector 'bit size-spec :simple (eql (car type) 'simple-bit-vector)))) ((cons) (cons (make-random-element-of-type (if (cdr type) (cadr type) t)) - (make-random-element-of-type (if (cddr type) (caddr type) t)))) + (make-random-element-of-type (if (cddr type) (caddr type) t)))) ((complex) (cond - ((null (cdr type)) - (make-random-element-of-type 'complex)) - (t - (assert (null (cddr type))) - (let ((etype (cadr type))) - (loop for v1 = (make-random-element-of-type etype) - for v2 = (make-random-element-of-type etype) - for c = (complex v1 v2) - when (typep c type) - return c))))) + ((null (cdr type)) + (make-random-element-of-type 'complex)) + (t + (assert (null (cddr type))) + (let ((etype (cadr type))) + (loop for v1 = (make-random-element-of-type etype) + for v2 = (make-random-element-of-type etype) + for c = (complex v1 v2) + when (typep c type) + return c))))) ))) |# @@ -1609,7 +1609,7 @@ (defmethod make-random-element-of-type ((type (eql 'ratio))) (let ((r 0)) (loop do (setq r (make-random-element-of-type 'rational)) - while (integerp r)) + while (integerp r)) r)) (defmethod make-random-element-of-type ((type (eql 'integer))) (let ((x (ash 1 (random *maximum-random-int-bits*)))) @@ -1645,7 +1645,7 @@ (make-random-character)) (defmethod make-random-element-of-type ((type (eql 'extended-char))) (loop for x = (make-random-character) - when (typep x 'extended-char) return x)) + when (typep x 'extended-char) return x)) (defmethod make-random-element-of-type ((type (eql 'null))) nil) (defmethod make-random-element-of-type ((type (eql 'fixnum))) (random-from-interval (1+ most-positive-fixnum) most-negative-fixnum)) @@ -1674,9 +1674,9 @@ (random-from-seq +standard-chars+)) ;; Default ((atom t *) (make-random-element-of-type - (random-from-seq #(real symbol boolean integer unsigned-byte - #-ecl complex character - (string 1) (bit-vector 1))))) + (random-from-seq #(real symbol boolean integer unsigned-byte + #-ecl complex character + (string 1) (bit-vector 1))))) (t (call-next-method type)) )) @@ -1885,7 +1885,7 @@ :optimized-lambda-form optimized-fn-src :unoptimized-lambda-form unoptimized-fn-src :kind kind))))) - + (let ((unopt-result (cl-handler-case (cl-handler-bind @@ -1994,7 +1994,7 @@ ((go) (try 0)) - + ((signum integer-length logcount logandc1 logandc2 lognand lognor logorc1 logorc2 realpart imagpart) @@ -2032,7 +2032,7 @@ #'(lambda (form) (when (consp form) (try `(dotimes (,var ,count-form ,result) ,form)))))))) - + ((abs 1+ 1-) (try 0) (mapc try-fn args) @@ -2119,7 +2119,7 @@ (assert (= (length args) 2)) (try (second args)) (prune (second args) try-fn)) - + ((not eq eql equal) (when (every #'constantp args) (try (eval form))) @@ -2137,7 +2137,7 @@ (mapc try-fn args) (prune-nary-fn form try-fn) (prune-fn form try-fn)) - + ((- + * min max logand logior logxor logeqv gcd lcm values) (when (every #'constantp args) (try (eval form))) @@ -2158,12 +2158,12 @@ (try 0) (mapc try-fn args) (prune-fn form try-fn)) - + ((coerce) (try 0) (try (car args)) (prune (car args) #'(lambda (form) (try `(coerce ,form ,(cadr args)))))) - + ((multiple-value-call) ;; Simplify usual case @@ -2311,7 +2311,7 @@ ;; Try removing the block entirely if it is not in use (when (not (find-in-tree name body)) (try form1)) - + ;; Try removing the block if its only use is an immediately ;; enclosed return-from: (block <n> (return-from <n> <e>)) (when (and (consp form1) @@ -2319,7 +2319,7 @@ (eq (second form1) name) (not (find-in-tree name (third form1)))) (try (third form1))) - + ;; Otherwise, try to simplify the subexpression (prune form1 #'(lambda (x) @@ -2338,7 +2338,7 @@ (when (or (not (find-in-tree 'throw body)) (not (find-in-tree name body))) (try form1)) - + ;; Try removing the block if its only use is an immediately ;; enclosed return-from: (block <n> (return-from <n> <e>)) (when (and (consp form1) @@ -2346,7 +2346,7 @@ (equal (second form1) name) (not (find-in-tree name (third form1)))) (try (third form1))) - + ;; Otherwise, try to simplify the subexpression (prune form1 #'(lambda (x) @@ -2550,7 +2550,7 @@ (otherwise (try 0) (prune-fn form try-fn)) - + ))))) (setf (gethash form *prune-table*) t) nil) @@ -2581,25 +2581,25 @@ (let* ((op (first form)) (expr (second form)) (cases (cddr form))) - + ;; Try just the top expression (try expr) - + ;; Try simplifying the expr (prune expr #'(lambda (form) (try `(,op ,form ,@cases)))) - + ;; Try individual cases (loop for case in cases do (try (first (last (rest case))))) - + ;; Try deleting individual cases (loop for i from 0 below (1- (length cases)) do (try `(,op ,expr ,@(subseq cases 0 i) ,@(subseq cases (1+ i))))) - + ;; Try simplifying the cases ;; Assume each case has a single form (prune-list cases @@ -2860,13 +2860,13 @@ ,@body)))))))) #'(lambda (bindings) (funcall try-fn `(,op ,bindings ,@body)))) - - + + ;; Try to simplify the forms in the RHS of the bindings (prune-list binding-list #'(lambda (binding try-fn) (declare (type function try-fn)) - + ;; Prune body of a binding (prune (third binding) #'(lambda (form) @@ -2933,11 +2933,11 @@ (dolist (clause (cddr form)) (walk-implicit-progn (cdr clause) fn))) ((flet labels) - - - - -|# + + + + +|# ;;;;;;;;;;;;;;;;;;;;;; ;;; Convert pruned results to test cases diff --git a/ansi-tests/random-intern.lsp b/ansi-tests/random-intern.lsp index 80bda183..5041b984 100644 --- a/ansi-tests/random-intern.lsp +++ b/ansi-tests/random-intern.lsp @@ -11,18 +11,18 @@ (declare (optimize (speed 3) (safety 3))) (loop (let* ((len (random (1+ +max-len-random-symbol+))) - (str (make-string len))) + (str (make-string len))) (declare (type (integer 0 #.+max-len-random-symbol+) len)) (loop for i from 0 to (1- len) do (setf (schar str i) - (schar +base-chars+ - (random +num-base-chars+)))) + (schar +base-chars+ + (random +num-base-chars+)))) (multiple-value-bind (symbol status) (intern (copy-seq str) package) (unless (equal str (symbol-name symbol)) - (error "Intern gave bad symbol: ~A, ~A~%" str symbol)) + (error "Intern gave bad symbol: ~A, ~A~%" str symbol)) (unless status (return symbol)))))) (defun queue-insert (q x) @@ -32,10 +32,10 @@ (defun queue-remove (q) (declare (type cons q)) (when (null (car q)) - (when (null (cdr q)) - (error "Attempty to remove from empty queue.~%")) - (setf (car q) (nreverse (cdr q))) - (setf (cdr q) nil)) + (when (null (cdr q)) + (error "Attempty to remove from empty queue.~%")) + (setf (car q) (nreverse (cdr q))) + (setf (cdr q) nil)) (pop (car q))) (defun queue-empty (q) @@ -45,14 +45,14 @@ (defun random-intern (n) (declare (fixnum n)) (let ((q (list nil)) - (xp (defpackage "X" (:use)))) + (xp (defpackage "X" (:use)))) (declare (type cons q)) (loop for i from 1 to n do (if (and - (= (random 2) 0) - (not (queue-empty q))) - (unintern (queue-remove q) xp) + (= (random 2) 0) + (not (queue-empty q))) + (unintern (queue-remove q) xp) (queue-insert q (make-random-symbol xp)))))) (defun fill-intern (n) @@ -62,7 +62,7 @@ for i from 1 to n do (make-random-symbol xp)))) - + diff --git a/ansi-tests/random-type-prop-tests-01.lsp b/ansi-tests/random-type-prop-tests-01.lsp index 36717020..da3a53e4 100644 --- a/ansi-tests/random-type-prop-tests-01.lsp +++ b/ansi-tests/random-type-prop-tests-01.lsp @@ -10,8 +10,8 @@ (def-type-prop-test typep.1 '(lambda (x y) (typep x (type-of y))) '(t t) 2) (def-type-prop-test typep.2 'typep (list t #'(lambda (x) - (let ((type (make-random-type-containing x))) - `(eql ,type)))) + (let ((type (make-random-type-containing x))) + `(eql ,type)))) 2) (def-type-prop-test subtypep '(lambda (x y) (subtypep (type-of x) (type-of y))) '(t t) 2) @@ -21,10 +21,10 @@ (def-type-prop-test compiled-function-p 'compiled-function-p '(t) 1) (def-type-prop-test not 'not '(t) 1) (def-type-prop-test eq 'eq (list - '(and t (not number) (not character)) - #'(lambda (x) (rcase - (1 `(eql ,x)) - (1 '(and t (not number) (not character)))))) + '(and t (not number) (not character)) + #'(lambda (x) (rcase + (1 `(eql ,x)) + (1 '(and t (not number) (not character)))))) 2) (def-type-prop-test eql.1 'eql '(t t) 2) (def-type-prop-test eql.2 'eql (list t #'(lambda (x) `(eql ,x))) 2) diff --git a/ansi-tests/random-type-prop-tests-02.lsp b/ansi-tests/random-type-prop-tests-02.lsp index d73fa5de..458aa8fc 100644 --- a/ansi-tests/random-type-prop-tests-02.lsp +++ b/ansi-tests/random-type-prop-tests-02.lsp @@ -10,24 +10,24 @@ (def-type-prop-test =.3 '= nil 4 :maxargs 10 :rest-type 'number) (def-type-prop-test =.4 '= '(integer integer) 2) (def-type-prop-test =.5 '= (list 'number #'(lambda (x) (if (coin) 'number - `(eql ,x)))) 2) + `(eql ,x)))) 2) (def-type-prop-test =.6 '= (list 'number 'number - #'(lambda (x y) (rcase - (2 'number) - (1 `(eql ,x)) - (1 `(eql ,y))))) + #'(lambda (x y) (rcase + (2 'number) + (1 `(eql ,x)) + (1 `(eql ,y))))) 3) (def-type-prop-test /=.1 '/= '(number number) 2) (def-type-prop-test /=.2 '/= '(number number number) 3) (def-type-prop-test /=.3 '/= nil 4 :maxargs 10 :rest-type 'number) (def-type-prop-test /=.4 '/= '(integer integer) 2) (def-type-prop-test /=.5 '/= (list 'number #'(lambda (x) (if (coin) 'number - `(eql ,x)))) 2) + `(eql ,x)))) 2) (def-type-prop-test /=.6 '/= (list 'number 'number - #'(lambda (x y) (rcase - (2 'number) - (1 `(eql ,x)) - (1 `(eql ,y))))) + #'(lambda (x y) (rcase + (2 'number) + (1 `(eql ,x)) + (1 `(eql ,y))))) 3) (def-type-prop-test <.1 '< '(real real) 2) (def-type-prop-test <.2 '< '(real real real) 3) @@ -58,24 +58,24 @@ (def-type-prop-test <=.3 '<= nil 4 :maxargs 10 :rest-type 'real) (def-type-prop-test <=.4 '<= '(integer integer) 2) (def-type-prop-test <=.5 '<= (list 'real #'(lambda (x) (if (coin) 'real - `(eql ,x)))) 2) + `(eql ,x)))) 2) (def-type-prop-test <=.6 '<= (list 'real 'real - #'(lambda (x y) (rcase - (2 'real) - (1 `(eql ,x)) - (1 `(eql ,y))))) + #'(lambda (x y) (rcase + (2 'real) + (1 `(eql ,x)) + (1 `(eql ,y))))) 3) (def-type-prop-test >=.1 '>= '(real real) 2) (def-type-prop-test >=.2 '>= '(real real real) 3) (def-type-prop-test >=.3 '>= nil 4 :maxargs 10 :rest-type 'real) (def-type-prop-test >=.4 '>= '(integer integer) 2) (def-type-prop-test >=.5 '>= (list 'real #'(lambda (x) (if (coin) 'real - `(eql ,x)))) 2) + `(eql ,x)))) 2) (def-type-prop-test >=.6 '>= (list 'real 'real - #'(lambda (x y) (rcase - (2 'real) - (1 `(eql ,x)) - (1 `(eql ,y))))) + #'(lambda (x y) (rcase + (2 'real) + (1 `(eql ,x)) + (1 `(eql ,y))))) 3) (def-type-prop-test min.1 'min nil 2 :maxargs 6 :rest-type 'integer) diff --git a/ansi-tests/random-type-prop-tests-03.lsp b/ansi-tests/random-type-prop-tests-03.lsp index dfc9a2e3..a564c214 100644 --- a/ansi-tests/random-type-prop-tests-03.lsp +++ b/ansi-tests/random-type-prop-tests-03.lsp @@ -172,15 +172,15 @@ (def-type-prop-test parse-integer.1 'parse-integer '((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - (satisfies has-nonzero-length))) + (satisfies has-nonzero-length))) 1) (def-type-prop-test parse-integer.2 'parse-integer `((and (vector (member #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - (satisfies has-nonzero-length)) + (satisfies has-nonzero-length)) (eql :start) ,#'(lambda (x &rest rest) (declare (ignore rest)) - `(integer 0 (,(length x))))) + `(integer 0 (,(length x))))) 3) (def-type-prop-test sxhash 'sxhash '(t) 1) diff --git a/ansi-tests/random-type-prop-tests-05.lsp b/ansi-tests/random-type-prop-tests-05.lsp index f4fa41bf..5ef8ee93 100644 --- a/ansi-tests/random-type-prop-tests-05.lsp +++ b/ansi-tests/random-type-prop-tests-05.lsp @@ -86,8 +86,8 @@ (def-type-prop-test sublis.2 'sublis '((cons (cons (integer 0 7) t) null) list) 2) (def-type-prop-test sublis.3 'sublis '(null list) 2) (def-type-prop-test sublis.4 'sublis `((cons (cons boolean t) null) list - (eql :key) - (or null (eql not) (eql ,#'not))) 4) + (eql :key) + (or null (eql not) (eql ,#'not))) 4) (def-type-prop-test sublis.5 'sublis `((cons (cons t t) null) list (eql :test) (or (eql equal) (eql ,#'equal))) 4) (def-type-prop-test sublis.6 'sublis `((cons (cons t t) null) list (eql :test-not) (or (eql eql) (eql ,#'eql))) 4) @@ -96,65 +96,65 @@ (def-type-prop-test subst.3 'subst '(t t list) 3) (def-type-prop-test subst.4 'subst '(t t (cons (cons t t) (cons t t))) 3) (def-type-prop-test subst.5 'subst `(boolean t (cons (cons t t) (cons t t)) - (eql :key) - (or null (eql not) (eql ,#'not))) 5) + (eql :key) + (or null (eql not) (eql ,#'not))) 5) (def-type-prop-test subst.6 'subst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5) (def-type-prop-test subst.7 'subst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5) (def-type-prop-test subst.8 'subst `(t t (cons (cons t t) (cons t t)) - (eql :key) (or null (eql not) (eql ,#'not)) - (eql :test) (or (eql equal) (eql ,#'equal))) 7) + (eql :key) (or null (eql not) (eql ,#'not)) + (eql :test) (or (eql equal) (eql ,#'equal))) 7) (def-type-prop-test nsubst.1 'nsubst '(t t t) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst.2 'nsubst '(t t (cons t t)) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst.3 'nsubst '(t t list) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst.4 'nsubst '(t t (cons (cons t t) (cons t t))) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst.5 'nsubst `(boolean t (cons (cons t t) (cons t t)) - (eql :key) - (or null (eql not) (eql ,#'not))) 5 - :replicate '(nil nil t nil nil)) + (eql :key) + (or null (eql not) (eql ,#'not))) 5 + :replicate '(nil nil t nil nil)) (def-type-prop-test nsubst.6 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test) (or (eql equal) (eql ,#'equal))) 5 :replicate '(nil nil t nil nil)) (def-type-prop-test nsubst.7 'nsubst `(t t (cons (cons t t) (cons t t)) (eql :test-not) (or (eql equal) (eql ,#'equal))) 5 :replicate '(nil nil t nil nil)) (def-type-prop-test nsubst.8 'nsubst `(t t (cons (cons t t) (cons t t)) - (eql :key) (or null (eql not) (eql ,#'not)) - (eql :test) (or (eql equal) (eql ,#'equal))) 7 - :replicate '(nil nil t nil nil nil nil)) + (eql :key) (or null (eql not) (eql ,#'not)) + (eql :test) (or (eql equal) (eql ,#'equal))) 7 + :replicate '(nil nil t nil nil nil nil)) (def-type-prop-test subst-if.1 'subst-if `(t (or (eql not) (eql ,#'not)) list) 3) (def-type-prop-test subst-if.2 'subst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3) (def-type-prop-test subst-if.3 'subst-if `(t (eql identity) - (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) - (eql :key) (or null (eql not) (eql ,#'not))) 5) + (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) + (eql :key) (or null (eql not) (eql ,#'not))) 5) (def-type-prop-test nsubst-if.1 'nsubst-if `(t (or (eql not) (eql ,#'not)) list) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst-if.2 'nsubst-if `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst-if.3 'nsubst-if `(t (eql identity) - (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) - (eql :key) (or null (eql not) (eql ,#'not))) 5 - :replicate '(nil nil t nil nil)) + (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) + (eql :key) (or null (eql not) (eql ,#'not))) 5 + :replicate '(nil nil t nil nil)) (def-type-prop-test subst-if-not.1 'subst-if-not `(t (or (eql not) (eql ,#'not)) list) 3) (def-type-prop-test subst-if-not.2 'subst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3) (def-type-prop-test subst-if-not.3 'subst-if-not `(t (eql identity) - (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) - (eql :key) (or null (eql not) (eql ,#'not))) 5) + (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) + (eql :key) (or null (eql not) (eql ,#'not))) 5) (def-type-prop-test nsubst-if-not.1 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) list) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst-if-not.2 'nsubst-if-not `(t (or (eql not) (eql ,#'not)) (cons (or null t) (or null t))) 3 :replicate '(nil nil t)) (def-type-prop-test nsubst-if-not.3 'nsubst-if-not `(t (eql identity) - (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) - (eql :key) (or null (eql not) (eql ,#'not))) 5 - :replicate '(nil nil t nil nil)) + (cons (cons (cons t t) (cons t t)) (cons (cons t t) (cons t t))) + (eql :key) (or null (eql not) (eql ,#'not))) 5 + :replicate '(nil nil t nil nil)) (def-type-prop-test tree-equal.1 'tree-equal (list t #'(lambda (x) `(or t (eql ,(copy-tree x))))) 2) (def-type-prop-test tree-equal.2 'tree-equal (list 'list #'(lambda (x) `(or list (eql ,(copy-tree t))))) 2) (def-type-prop-test tree-equal.3 'tree-equal (list '(cons t t) - #'(lambda (x) `(or (cons t t) (eql ,(copy-tree x)))) - '(eql :test) - `(or (eql equal) (eql ,#'equal))) + #'(lambda (x) `(or (cons t t) (eql ,(copy-tree x)))) + '(eql :test) + `(or (eql equal) (eql ,#'equal))) 4) (def-type-prop-test tree-equal.4 'tree-equal (list t #'(lambda (x) `(or t (eql ,(copy-tree x)))) - '(eql :test-not) '(eql eql)) + '(eql :test-not) '(eql eql)) 4) (def-type-prop-test copy-list.1 'copy-list '(list) 1) @@ -200,10 +200,10 @@ (def-type-prop-test ldiff.1 'ldiff '(list t) 2) (def-type-prop-test ldiff.2 'ldiff (list 'list - #'(lambda (x) - (if (consp x) - `(or t (eql ,(nthcdr (random (length x)) x))) - t))) + #'(lambda (x) + (if (consp x) + `(or t (eql ,(nthcdr (random (length x)) x))) + t))) 2) (def-type-prop-test tailp.1 'tailp '(t list) 2) @@ -226,7 +226,7 @@ 2) (def-type-prop-test member-if.3 'member-if (list '(eql zerop) #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))) - '(eql :key)`(or (eql 1-) (eql ,#'1-))) + '(eql :key)`(or (eql 1-) (eql ,#'1-))) 4) (def-type-prop-test member-if-not.1 'member-if-not `((or (eql symbolp) (eql ,#'symbolp)) list) 2) @@ -235,9 +235,9 @@ 2) (def-type-prop-test member-if-not.3 'member-if-not (list '(eql plusp) - #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))) - '(eql :key) - `(or (eql 1-) (eql ,#'1-))) + #'(lambda (x) (make-list-type (random 10) 'null '(integer 0 10))) + '(eql :key) + `(or (eql 1-) (eql ,#'1-))) 4) (def-type-prop-test member-if-not.4 'member-if-not `((eql identity) list @@ -261,7 +261,7 @@ (def-type-prop-test mapcon.1 'mapcon '((eql copy-list) list) 2) -(def-type-prop-test acons 'acons +(def-type-prop-test acons 'acons (list t t #'(lambda (x y) (make-list-type (random 5) 'null '(or null (cons t t))))) 3) @@ -271,32 +271,32 @@ 2) (def-type-prop-test assoc.3 'assoc (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons (eql ,x) t)))) - '(eql :key) `(or (eql not) (eql ,#'not))) + '(eql :key) `(or (eql not) (eql ,#'not))) 4) (def-type-prop-test assoc.4 'assoc (list 'real - #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons real t) (cons (eql ,x) t)))) - `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=)) + #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons real t) (cons (eql ,x) t)))) + `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=)) 4) (def-type-prop-test assoc-if.1 'assoc-if (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) - (make-list-type (random 8) 'null '(or null (cons t t)))) + (make-list-type (random 8) 'null '(or null (cons t t)))) 2) (def-type-prop-test assoc-if.2 'assoc-if (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) - (make-list-type (random 8) 'null '(or null (cons real t))) - '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) + (make-list-type (random 8) 'null '(or null (cons real t))) + '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) 2) (def-type-prop-test assoc-if-not.1 'assoc-if-not (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) - (make-list-type (random 8) 'null '(or null (cons t t)))) + (make-list-type (random 8) 'null '(or null (cons t t)))) 2) (def-type-prop-test assoc-if-not.2 'assoc-if-not (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) - (make-list-type (random 8) 'null '(or null (cons real t))) - '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) + (make-list-type (random 8) 'null '(or null (cons real t))) + '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) 2) (def-type-prop-test copy-alist 'copy-alist @@ -309,7 +309,7 @@ (def-type-prop-test pairlis.2 'pairlis (list 'list #'(lambda (x) (make-list-type (length x) 'null t)) - #'(lambda (x y) (make-list-type (random 6) 'null '(or null (cons t t))))) + #'(lambda (x y) (make-list-type (random 6) 'null '(or null (cons t t))))) 3) (def-type-prop-test rassoc.1 'rassoc (list t #'(lambda (x) (make-list-type (random 6) 'null '(or null (cons t t))))) 2) @@ -318,32 +318,32 @@ 2) (def-type-prop-test rassoc.3 'rassoc (list t #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t t) (cons t (eql ,x))))) - '(eql :key) `(or (eql not) (eql ,#'not))) + '(eql :key) `(or (eql not) (eql ,#'not))) 4) (def-type-prop-test rassoc.4 'rassoc (list 'real - #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t real) (cons t (eql ,x))))) - `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=)) + #'(lambda (x) (make-list-type (random 6) 'null `(or null (cons t real) (cons t (eql ,x))))) + `(member :test :test-not) `(member <= < = /= > >= ,#'<= ,#'< ,#'= ,#'/= ,#'> ,#'>=)) 4) (def-type-prop-test rassoc-if.1 'rassoc-if (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) - (make-list-type (random 8) 'null '(or null (cons t t)))) + (make-list-type (random 8) 'null '(or null (cons t t)))) 2) (def-type-prop-test rassoc-if.2 'rassoc-if (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) - (make-list-type (random 8) 'null '(or null (cons t real))) - '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) + (make-list-type (random 8) 'null '(or null (cons t real))) + '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) 2) (def-type-prop-test rassoc-if-not.1 'rassoc-if-not (list `(member identity not symbolp numberp arrayp ,#'identity ,#'not ,#'symbolp ,#'numberp ,#'arrayp) - (make-list-type (random 8) 'null '(or null (cons t t)))) + (make-list-type (random 8) 'null '(or null (cons t t)))) 2) (def-type-prop-test rassoc-if-not.2 'rassoc-if-not (list `(member plusp minusp zerop ,#'plusp ,#'minusp ,#'zerop) - (make-list-type (random 8) 'null '(or null (cons t real))) - '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) + (make-list-type (random 8) 'null '(or null (cons t real))) + '(eql :key) `(member 1+ 1- - abs signum ,#'1+ ,#'1- ,#'- ,#'abs ,#'signum)) 2) ;;; We don't use numbers or characters as indicators, since the test is EQ, @@ -354,10 +354,10 @@ 2) (def-type-prop-test get-properties.2 'get-properties (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) - #'(lambda (plist) (let ((len (length plist))) - (if (= len 0) '(cons t null) - (let ((ind (elt plist (* 2 (random (floor len 2)))))) - `(cons (eql ,ind) null)))))) + #'(lambda (plist) (let ((len (length plist))) + (if (= len 0) '(cons t null) + (let ((ind (elt plist (* 2 (random (floor len 2)))))) + `(cons (eql ,ind) null)))))) 2) (def-type-prop-test getf.1 'getf @@ -365,37 +365,37 @@ 2) (def-type-prop-test getf.2 'getf (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) - #'(lambda (plist) (let ((len (length plist))) - (if (= len 0) t - (let ((ind (elt plist (* 2 (random (floor len 2)))))) - `(eql ,ind)))))) + #'(lambda (plist) (let ((len (length plist))) + (if (= len 0) t + (let ((ind (elt plist (* 2 (random (floor len 2)))))) + `(eql ,ind)))))) 2) (def-type-prop-test getf.3 'getf (list #'(lambda () (make-list-type (* 2 (random 5)) 'null '(not (or number character)))) - t t) + t t) 3) (def-type-prop-test intersection.1 'intersection '(list list) 2 :test #'same-set-p) (def-type-prop-test intersection.2 'intersection '(list list (eql :key) (eql identity)) 4 :test #'same-set-p) (def-type-prop-test intersection.3 'intersection (list #'(lambda () (make-list-type (random 10) 'null 'integer)) - #'(lambda (x) (make-list-type (random 10) 'null 'integer)) - '(eql :key) - `(member 1+ ,#'1+)) + #'(lambda (x) (make-list-type (random 10) 'null 'integer)) + '(eql :key) + `(member 1+ ,#'1+)) 4 :test #'same-set-p) (def-type-prop-test intersection.4 'intersection (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) - #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) - '(eql :key) - `(member car ,#'car)) + #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) + '(eql :key) + `(member car ,#'car)) 4 :test #'(lambda (x y) (same-set-p x y :key #'car))) (def-type-prop-test intersection.5 'intersection (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) - #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) - '(eql :test) - `(member equal ,#'equal)) + #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) + '(eql :test) + `(member equal ,#'equal)) 4 :test #'(lambda (x y) (same-set-p x y :key #'car))) @@ -403,25 +403,25 @@ (def-type-prop-test nintersection.2 'nintersection '(list list (eql :key) (eql identity)) 4 :test #'same-set-p :replicate '(t t nil nil)) (def-type-prop-test nintersection.3 'nintersection (list #'(lambda () (make-list-type (random 10) 'null 'integer)) - #'(lambda (x) (make-list-type (random 10) 'null 'integer)) - '(eql :key) - `(member 1+ ,#'1+)) + #'(lambda (x) (make-list-type (random 10) 'null 'integer)) + '(eql :key) + `(member 1+ ,#'1+)) 4 :test #'same-set-p :replicate '(t t nil nil)) (def-type-prop-test nintersection.4 'nintersection (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) - #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) - '(eql :key) - `(member car ,#'car)) + #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) + '(eql :key) + `(member car ,#'car)) 4 :test #'(lambda (x y) (same-set-p x y :key #'car)) :replicate '(t t nil nil)) (def-type-prop-test nintersection.5 'nintersection (list #'(lambda () (make-list-type (random 10) 'null '(cons integer null))) - #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) - '(eql :test) - `(member equal ,#'equal)) + #'(lambda (x) (make-list-type (random 10) 'null '(cons integer null))) + '(eql :test) + `(member equal ,#'equal)) 4 :test #'(lambda (x y) (same-set-p x y :key #'car)) :replicate '(t t nil nil)) @@ -430,15 +430,15 @@ (def-type-prop-test adjoin.1 'adjoin '(t list) 2) (def-type-prop-test adjoin.2 'adjoin '((integer 0 1) list) 2) (def-type-prop-test adjoin.3 'adjoin `((integer 0 10) (cons number (cons number (cons number null))) - (eql :test) (or (eql =) (eql ,#'=))) + (eql :test) (or (eql =) (eql ,#'=))) 4) (def-type-prop-test adjoin.4 'adjoin `(number - (cons number (cons number (cons number (cons number null)))) - (eql :test-not) (or (eql /=) (eql ,#'/=))) + (cons number (cons number (cons number (cons number null)))) + (eql :test-not) (or (eql /=) (eql ,#'/=))) 4) (def-type-prop-test adjoin.5 'adjoin `(number - (cons number (cons number (cons number (cons number null)))) - (eql :key) (or (member 1+ 1- ,#'1+ ,#'1-))) + (cons number (cons number (cons number (cons number null)))) + (eql :key) (or (member 1+ 1- ,#'1+ ,#'1-))) 4) (def-type-prop-test pushnew.1 '(lambda (x y) (list (pushnew x y) y)) '(t list) 2) @@ -455,74 +455,74 @@ (def-type-prop-test set-difference.1 'set-difference '(list list) 2) (def-type-prop-test set-difference.2 'set-difference '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) 2) (def-type-prop-test set-difference.3 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test) (member = ,#'=)) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) + (eql :test) (member = ,#'=)) 4) (def-type-prop-test set-difference.4 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test-not) (member /= ,#'/=)) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) + (eql :test-not) (member /= ,#'/=)) 4) (def-type-prop-test set-difference.5 'set-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) + (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) 4) (def-type-prop-test nset-difference.1 'nset-difference '(list list) 2 :replicate '(t t)) (def-type-prop-test nset-difference.2 'nset-difference '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) 2 :replicate '(t t)) (def-type-prop-test nset-difference.3 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test) (member = ,#'=)) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) + (eql :test) (member = ,#'=)) 4 :replicate '(t t nil nil)) (def-type-prop-test nset-difference.4 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test-not) (member /= ,#'/=)) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) + (eql :test-not) (member /= ,#'/=)) 4 :replicate '(t t nil nil)) (def-type-prop-test nset-difference.5 'nset-difference `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) + (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) 4 :replicate '(t t nil nil)) (def-type-prop-test set-exclusive-or.1 'set-exclusive-or '(list list) 2) (def-type-prop-test set-exclusive-or.2 'set-exclusive-or '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) 2) (def-type-prop-test set-exclusive-or.3 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test) (member = ,#'=)) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) + (eql :test) (member = ,#'=)) 4) (def-type-prop-test set-exclusive-or.4 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test-not) (member /= ,#'/=)) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) + (eql :test-not) (member /= ,#'/=)) 4) (def-type-prop-test set-exclusive-or.5 'set-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) + (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) 4) (def-type-prop-test nset-exclusive-or.1 'nset-exclusive-or '(list list) 2 :replicate '(t t)) (def-type-prop-test nset-exclusive-or.2 'nset-exclusive-or '((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)))) 2 :replicate '(t t)) (def-type-prop-test nset-exclusive-or.3 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test) (member = ,#'=)) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) + (eql :test) (member = ,#'=)) 4 :replicate '(t t nil nil)) (def-type-prop-test nset-exclusive-or.4 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) - (eql :test-not) (member /= ,#'/=)) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) (cons (unsigned-byte 3) null))) + (eql :test-not) (member /= ,#'/=)) 4 :replicate '(t t nil nil)) (def-type-prop-test nset-exclusive-or.5 'nset-exclusive-or `((cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) - (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) + (cons (unsigned-byte 3) (cons (unsigned-byte 3) null)) + (eql :key) (member evenp oddp ,#'evenp ,#'oddp)) 4 :replicate '(t t nil nil)) (def-type-prop-test subsetp.1 'subsetp '(list list) 2) (def-type-prop-test subsetp.2 'subsetp '((cons integer null) - (cons integer (cons integer (cons integer (cons integer null))))) + (cons integer (cons integer (cons integer (cons integer null))))) 2) diff --git a/ansi-tests/random-type-prop-tests-06.lsp b/ansi-tests/random-type-prop-tests-06.lsp index ddc9f75d..b90f9d05 100644 --- a/ansi-tests/random-type-prop-tests-06.lsp +++ b/ansi-tests/random-type-prop-tests-06.lsp @@ -11,7 +11,7 @@ (def-type-prop-test aref.1 'aref (list '(array * (*)) (index-type-for-dim 0)) 2) (def-type-prop-test aref.2 'aref (list '(array * (* *)) (index-type-for-dim 0) (index-type-for-dim 1)) 3) (def-type-prop-test aref.3 'aref (list '(array * (* * *)) - (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) + (index-type-for-dim 0) (index-type-for-dim 1) (index-type-for-dim 2)) 4) (def-type-prop-test array-dimension 'array-dimension @@ -55,7 +55,7 @@ (def-type-prop-test upgraded-array-element-type 'upgraded-array-element-type (list #'(lambda () (let ((x (make-random-element-of-type t))) - `(eql ,(make-random-type-containing x))))) + `(eql ,(make-random-type-containing x))))) 1) (def-type-prop-test simple-vector-p.1 'simple-vector-p '(t) 1) @@ -80,61 +80,61 @@ (def-type-prop-test bit-and.1 'bit-and (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) + `(array bit ,dims)))) 2) (def-type-prop-test bit-and.2 'bit-and (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-andc1.1 'bit-andc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) + `(array bit ,dims)))) 2) (def-type-prop-test bit-andc1.2 'bit-andc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-andc2.1 'bit-andc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) + `(array bit ,dims)))) 2) (def-type-prop-test bit-andc2.2 'bit-andc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-ior.1 'bit-ior (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) + `(array bit ,dims)))) 2) (def-type-prop-test bit-ior.2 'bit-ior (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-orc1.1 'bit-orc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) + `(array bit ,dims)))) 2) (def-type-prop-test bit-orc1.2 'bit-orc1 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-orc2.1 'bit-orc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) + `(array bit ,dims)))) 2) (def-type-prop-test bit-orc2.2 'bit-orc2 (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-eqv.1 'bit-eqv (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) + `(array bit ,dims)))) 2) (def-type-prop-test bit-eqv.2 'bit-eqv (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-xor.1 'bit-xor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) + `(array bit ,dims)))) 2) (def-type-prop-test bit-xor.2 'bit-xor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-nand.1 'bit-nand (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) + `(array bit ,dims)))) 2) (def-type-prop-test bit-nand.2 'bit-nand (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) 3) (def-type-prop-test bit-nor.1 'bit-nor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) - `(array bit ,dims)))) + `(array bit ,dims)))) 2) (def-type-prop-test bit-nor.2 'bit-nor (list '(array bit) #'(lambda (a) (let ((dims (array-dimensions a))) `(array bit ,dims))) 'null) diff --git a/ansi-tests/random-type-prop-tests-07.lsp b/ansi-tests/random-type-prop-tests-07.lsp index 78516f3d..efe6f59b 100644 --- a/ansi-tests/random-type-prop-tests-07.lsp +++ b/ansi-tests/random-type-prop-tests-07.lsp @@ -16,11 +16,11 @@ (def-type-prop-test string-trim.1 'string-trim '(string string) 2) (def-type-prop-test string-trim.2 'string-trim (list #'(lambda () (make-list-type (random 10) 'null 'character)) - 'string) + 'string) 2) (def-type-prop-test string-left-trim.1 'string-left-trim '(string string) 2) (def-type-prop-test string-left-trim.2 'string-left-trim (list #'(lambda () (make-list-type (random 10) 'null 'character)) - 'string) + 'string) 2) (def-type-prop-test string-right-trim.1 'string-right-trim '(string string) 2) (def-type-prop-test string-right-trim.2 'string-right-trim @@ -31,71 +31,71 @@ (flet ((%makename (n) (intern (format nil "~A.~A" op n) :cl-test))) `(progn (def-type-prop-test ,(%makename 1) ',op '(string string) 2) - (def-type-prop-test ,(%makename 2) ',op - `(string string (eql :start1) ,#'index-type-for-v1) - 4) - (def-type-prop-test ,(%makename 3) ',op - `(string string (eql :start2) ,#'index-type-for-v2) - 4) - (def-type-prop-test ,(%makename 4) ',op - `(string string (eql :end1) ,#'end-type-for-v1) - 4) - (def-type-prop-test ,(%makename 5) ',op - `(string string (eql :end2) ,#'end-type-for-v2) - 4) - (def-type-prop-test ,(%makename 6) ',op - `(string string - (eql :start1) ,#'index-type-for-v1 - (eql :end1) ,#'end-type-for-v1) - 6) - (def-type-prop-test ,(%makename 7) ',op - `(string string - (eql :start1) ,#'index-type-for-v1 - (eql :end2) ,#'end-type-for-v2) - 6) - (def-type-prop-test ,(%makename 8) ',op - `(string string - (eql :start2) ,#'index-type-for-v2 - (eql :end1) ,#'end-type-for-v1) - 6) - (def-type-prop-test ,(%makename 9) ',op - `(string string - (eql :start2) ,#'index-type-for-v2 - (eql :end2) ,#'end-type-for-v2) - 6) - (def-type-prop-test ,(%makename 10) ',op - `(string string - (eql :start1) ,#'index-type-for-v1 - (eql :start2) ,#'index-type-for-v2 - (eql :end1) ,#'end-type-for-v1) - 8) - (def-type-prop-test ,(%makename 11) ',op - `(string string - (eql :start1) ,#'index-type-for-v1 - (eql :start2) ,#'index-type-for-v2 - (eql :end2) ,#'end-type-for-v2) - 8) - (def-type-prop-test ,(%makename 12) ',op - `(string string - (eql :start1) ,#'index-type-for-v1 - (eql :end2) ,#'end-type-for-v2 - (eql :end1) ,#'end-type-for-v1) - 8) - (def-type-prop-test ,(%makename 13) ',op - `(string string - (eql :start2) ,#'index-type-for-v2 - (eql :end2) ,#'end-type-for-v2 - (eql :end1) ,#'end-type-for-v1) - 8) - (def-type-prop-test ,(%makename 14) ',op - `(string string - (eql :start1) ,#'index-type-for-v1 - (eql :start2) ,#'index-type-for-v2 - (eql :end2) ,#'end-type-for-v2 - (eql :end1) ,#'end-type-for-v1) - 10) + (def-type-prop-test ,(%makename 2) ',op + `(string string (eql :start1) ,#'index-type-for-v1) + 4) + (def-type-prop-test ,(%makename 3) ',op + `(string string (eql :start2) ,#'index-type-for-v2) + 4) + (def-type-prop-test ,(%makename 4) ',op + `(string string (eql :end1) ,#'end-type-for-v1) + 4) + (def-type-prop-test ,(%makename 5) ',op + `(string string (eql :end2) ,#'end-type-for-v2) + 4) + (def-type-prop-test ,(%makename 6) ',op + `(string string + (eql :start1) ,#'index-type-for-v1 + (eql :end1) ,#'end-type-for-v1) + 6) + (def-type-prop-test ,(%makename 7) ',op + `(string string + (eql :start1) ,#'index-type-for-v1 + (eql :end2) ,#'end-type-for-v2) + 6) + (def-type-prop-test ,(%makename 8) ',op + `(string string + (eql :start2) ,#'index-type-for-v2 + (eql :end1) ,#'end-type-for-v1) + 6) + (def-type-prop-test ,(%makename 9) ',op + `(string string + (eql :start2) ,#'index-type-for-v2 + (eql :end2) ,#'end-type-for-v2) + 6) + (def-type-prop-test ,(%makename 10) ',op + `(string string + (eql :start1) ,#'index-type-for-v1 + (eql :start2) ,#'index-type-for-v2 + (eql :end1) ,#'end-type-for-v1) + 8) + (def-type-prop-test ,(%makename 11) ',op + `(string string + (eql :start1) ,#'index-type-for-v1 + (eql :start2) ,#'index-type-for-v2 + (eql :end2) ,#'end-type-for-v2) + 8) + (def-type-prop-test ,(%makename 12) ',op + `(string string + (eql :start1) ,#'index-type-for-v1 + (eql :end2) ,#'end-type-for-v2 + (eql :end1) ,#'end-type-for-v1) + 8) + (def-type-prop-test ,(%makename 13) ',op + `(string string + (eql :start2) ,#'index-type-for-v2 + (eql :end2) ,#'end-type-for-v2 + (eql :end1) ,#'end-type-for-v1) + 8) + (def-type-prop-test ,(%makename 14) ',op + `(string string + (eql :start1) ,#'index-type-for-v1 + (eql :start2) ,#'index-type-for-v2 + (eql :end2) ,#'end-type-for-v2 + (eql :end1) ,#'end-type-for-v1) + 10) ))) - + (def-string-comparison-type-prop-test string=) (def-string-comparison-type-prop-test string/=) (def-string-comparison-type-prop-test string<) @@ -114,8 +114,8 @@ (def-type-prop-test make-string.1 'make-string '((integer 0 100) (eql :initial-element) character) 3) (def-type-prop-test make-string.2 'make-string `((integer 0 100) (eql :initial-element) character - (eql :element-type) - ,#'(lambda (&rest args) - `(eql (and character - ,(make-random-type-containing (third args)))))) + (eql :element-type) + ,#'(lambda (&rest args) + `(eql (and character + ,(make-random-type-containing (third args)))))) 5) diff --git a/ansi-tests/random-type-prop-tests-08.lsp b/ansi-tests/random-type-prop-tests-08.lsp index da448649..9f8c938c 100644 --- a/ansi-tests/random-type-prop-tests-08.lsp +++ b/ansi-tests/random-type-prop-tests-08.lsp @@ -8,8 +8,8 @@ (def-type-prop-test copy-seq 'copy-seq '((or vector list)) 1) (def-type-prop-test elt 'elt (list '(or vector list) - #'(lambda (x) (let ((len (length x))) - (and (> len 0) `(integer 0 (,len)))))) + #'(lambda (x) (let ((len (length x))) + (and (> len 0) `(integer 0 (,len)))))) 2) (defmacro rfill (x y &rest other-args) @@ -29,31 +29,31 @@ (def-type-prop-test fill.4 'rfill (list t #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len)))) + '(eql :start) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len)))) 4 :replicate '(nil t nil nil)) (def-type-prop-test fill.5 'rfill (list t #'make-random-sequence-type-containing - '(eql :end) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len)))) + '(eql :end) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len)))) 4 :replicate '(nil t nil nil)) (def-type-prop-test fill.6 'rfill (list t #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :end) - #'(lambda (v s k1 start k2) - (declare (ignore v k1 k2)) - (let ((len (length s))) - `(integer ,start ,len)))) + '(eql :start) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :end) + #'(lambda (v s k1 start k2) + (declare (ignore v k1 k2)) + (let ((len (length s))) + `(integer ,start ,len)))) 6 :replicate '(nil t nil nil nil nil)) ;;; make-sequence tests here @@ -64,45 +64,45 @@ (def-type-prop-test subseq.2 'subseq (list 'sequence #'(lambda (s) `(integer 0 ,(length s))) - #'(lambda (s start) `(integer ,start ,(length s)))) + #'(lambda (s start) `(integer ,start ,(length s)))) 3) ;;; map tests here (def-type-prop-test map.1 'map (list '(member list vector) - '(member list #.#'list) - '(or list vector)) + '(member list #.#'list) + '(or list vector)) 3) (def-type-prop-test map.2 'map (list '(member list vector) - '(member list #.#'list) - '(or list vector) - '(or list vector)) + '(member list #.#'list) + '(or list vector) + '(or list vector)) 4) (def-type-prop-test map.3 'map (list '(member list vector) - '(member list #.#'list) - '(or list vector) - '(or list vector) - '(or list vector)) + '(member list #.#'list) + '(or list vector) + '(or list vector) + '(or list vector)) 5) (def-type-prop-test map.4 'map (list '(member list vector (vector (unsigned-byte 32))) - '(member 1+ #.#'1+) - `(or ,@(loop for i from 1 to 31 collect `(vector (unsigned-byte ,i))))) + '(member 1+ #.#'1+) + `(or ,@(loop for i from 1 to 31 collect `(vector (unsigned-byte ,i))))) 3) (def-type-prop-test map.5 'map (list `(member ,@(loop for i from 1 to 32 collect `(vector (unsigned-byte ,i)))) - '(member 1+ #.#'1+) - #'(lambda (type fun) - (declare (ignore fun)) - (let ((i (cadadr type))) - `(or ,@(loop for j from i to 32 collect `(vector (integer 0 ,(- (ash 1 i) 2)))))))) + '(member 1+ #.#'1+) + #'(lambda (type fun) + (declare (ignore fun)) + (let ((i (cadadr type))) + `(or ,@(loop for j from i to 32 collect `(vector (integer 0 ,(- (ash 1 i) 2)))))))) 3) @@ -111,15 +111,15 @@ (def-type-prop-test map-into.1 'map-into (list '(or list (vector t)) - '(member list #.#'list) - '(or list vector)) + '(member list #.#'list) + '(or list vector)) 3 :replicate '(t nil nil)) (def-type-prop-test map-into.2 'map-into (list '(or list (vector t)) - '(member list #.#'list) - '(or list vector) - '(or list vector)) + '(member list #.#'list) + '(or list vector) + '(or list vector)) 4 :replicate '(t nil nil nil)) ;;; reduce tests here @@ -130,71 +130,71 @@ 2) (def-type-prop-test count.3 'count (list t #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (x s k1) (declare (ignore x k1)) - `(integer 0 ,(length s)))) + '(eql :start) + #'(lambda (x s k1) (declare (ignore x k1)) + `(integer 0 ,(length s)))) 4) (def-type-prop-test count.4 'count (list t #'make-random-sequence-type-containing - '(eql :end) - #'(lambda (x s k1) (declare (ignore x k1)) - `(integer 0 ,(length s)))) + '(eql :end) + #'(lambda (x s k1) (declare (ignore x k1)) + `(integer 0 ,(length s)))) 4) (def-type-prop-test count.5 'count (list t #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (x s k1) (declare (ignore x k1)) - `(integer 0 ,(length s))) - '(eql :end) - #'(lambda (x s k1 start k2) (declare (ignore x k1 k2)) - `(integer ,start ,(length s)))) + '(eql :start) + #'(lambda (x s k1) (declare (ignore x k1)) + `(integer 0 ,(length s))) + '(eql :end) + #'(lambda (x s k1 start k2) (declare (ignore x k1 k2)) + `(integer ,start ,(length s)))) 6) (def-type-prop-test count.6 'count (list '(or short-float single-float double-float long-float) - #'(lambda (f) `(vector (or ,(typecase f - (short-float 'short-float) - (single-float 'single-float) - (double-float 'double-float) - (long-float 'long-float) - (t 'float)) - (eql ,f))))) + #'(lambda (f) `(vector (or ,(typecase f + (short-float 'short-float) + (single-float 'single-float) + (double-float 'double-float) + (long-float 'long-float) + (t 'float)) + (eql ,f))))) 2) (def-type-prop-test count.7 'count '(bit (vector bit)) 2) (def-type-prop-test count.8 'count '((unsigned-byte 2) (vector (unsigned-byte 2))) 2) (def-type-prop-test count.9 'count '((unsigned-byte 4) (vector (unsigned-byte 4))) 2) (def-type-prop-test count.10 'count '((unsigned-byte 8) (vector (unsigned-byte 8))) 2) - + ;;; count-if tests (def-type-prop-test count-if.1 'count-if (list (let ((funs '(numberp rationalp realp floatp complexp - symbolp identity null functionp listp consp + symbolp identity null functionp listp consp arrayp vectorp simple-vector-p - stringp simple-string-p - bit-vector-p simple-bit-vector-p))) - `(member ,@funs ,@(mapcar #'symbol-function funs))) - '(or list vector)) + stringp simple-string-p + bit-vector-p simple-bit-vector-p))) + `(member ,@funs ,@(mapcar #'symbol-function funs))) + '(or list vector)) 2) (def-type-prop-test count-if.2 'count-if (list (let ((funs '(numberp rationalp realp floatp complexp - symbolp identity null functionp listp consp + symbolp identity null functionp listp consp arrayp vectorp simple-vector-p - stringp simple-string-p - bit-vector-p simple-bit-vector-p))) - `(member ,@funs ,@(mapcar #'symbol-function funs))) - '(or list vector) - '(eql :key) - (let ((key-funs '(identity not null))) - `(member ,@key-funs ,@(mapcar #'symbol-function key-funs)))) + stringp simple-string-p + bit-vector-p simple-bit-vector-p))) + `(member ,@funs ,@(mapcar #'symbol-function funs))) + '(or list vector) + '(eql :key) + (let ((key-funs '(identity not null))) + `(member ,@key-funs ,@(mapcar #'symbol-function key-funs)))) 4) ;;; Put count-if-not tests here - + (def-type-prop-test length.1 'length '(sequence) 1) @@ -207,65 +207,65 @@ (def-type-prop-test sort.2 'sort `((or (vector (unsigned-byte 2)) - (vector (unsigned-byte 3)) - (vector (unsigned-byte 4)) - (vector (unsigned-byte 5)) - (vector (unsigned-byte 6)) - (vector (unsigned-byte 7)) - (vector (unsigned-byte 8))) + (vector (unsigned-byte 3)) + (vector (unsigned-byte 4)) + (vector (unsigned-byte 5)) + (vector (unsigned-byte 6)) + (vector (unsigned-byte 7)) + (vector (unsigned-byte 8))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) - + (def-type-prop-test sort.3 'sort `((or (vector (unsigned-byte 10)) - (vector (unsigned-byte 13)) - (vector (unsigned-byte 15)) - (vector (unsigned-byte 16))) + (vector (unsigned-byte 13)) + (vector (unsigned-byte 15)) + (vector (unsigned-byte 16))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.4 'sort `((or (vector (unsigned-byte 20)) - (vector (unsigned-byte 24)) - (vector (unsigned-byte 28)) - (vector (unsigned-byte 31)) - (vector (unsigned-byte 32))) + (vector (unsigned-byte 24)) + (vector (unsigned-byte 28)) + (vector (unsigned-byte 31)) + (vector (unsigned-byte 32))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.5 'sort `((or (vector (signed-byte 2)) - (vector (signed-byte 3)) - (vector (signed-byte 4)) - (vector (signed-byte 5)) - (vector (signed-byte 6)) - (vector (signed-byte 7)) - (vector (signed-byte 8))) + (vector (signed-byte 3)) + (vector (signed-byte 4)) + (vector (signed-byte 5)) + (vector (signed-byte 6)) + (vector (signed-byte 7)) + (vector (signed-byte 8))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.6 'sort `((or (vector (signed-byte 10)) - (vector (signed-byte 13)) - (vector (signed-byte 15)) - (vector (signed-byte 16))) + (vector (signed-byte 13)) + (vector (signed-byte 15)) + (vector (signed-byte 16))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.7 'sort `((or (vector (signed-byte 20)) - (vector (signed-byte 24)) - (vector (signed-byte 28)) - (vector (signed-byte 31)) - (vector (signed-byte 32))) + (vector (signed-byte 24)) + (vector (signed-byte 28)) + (vector (signed-byte 31)) + (vector (signed-byte 32))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test sort.8 'sort `((or (vector short-float) - (vector single-float) - (vector double-float) - (vector long-float)) + (vector single-float) + (vector double-float) + (vector long-float)) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) @@ -277,65 +277,65 @@ (def-type-prop-test stable-sort.2 'stable-sort `((or (vector (unsigned-byte 2)) - (vector (unsigned-byte 3)) - (vector (unsigned-byte 4)) - (vector (unsigned-byte 5)) - (vector (unsigned-byte 6)) - (vector (unsigned-byte 7)) - (vector (unsigned-byte 8))) + (vector (unsigned-byte 3)) + (vector (unsigned-byte 4)) + (vector (unsigned-byte 5)) + (vector (unsigned-byte 6)) + (vector (unsigned-byte 7)) + (vector (unsigned-byte 8))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) - + (def-type-prop-test stable-sort.3 'stable-sort `((or (vector (unsigned-byte 10)) - (vector (unsigned-byte 13)) - (vector (unsigned-byte 15)) - (vector (unsigned-byte 16))) + (vector (unsigned-byte 13)) + (vector (unsigned-byte 15)) + (vector (unsigned-byte 16))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.4 'stable-sort `((or (vector (unsigned-byte 20)) - (vector (unsigned-byte 24)) - (vector (unsigned-byte 28)) - (vector (unsigned-byte 31)) - (vector (unsigned-byte 32))) + (vector (unsigned-byte 24)) + (vector (unsigned-byte 28)) + (vector (unsigned-byte 31)) + (vector (unsigned-byte 32))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.5 'stable-sort `((or (vector (signed-byte 2)) - (vector (signed-byte 3)) - (vector (signed-byte 4)) - (vector (signed-byte 5)) - (vector (signed-byte 6)) - (vector (signed-byte 7)) - (vector (signed-byte 8))) + (vector (signed-byte 3)) + (vector (signed-byte 4)) + (vector (signed-byte 5)) + (vector (signed-byte 6)) + (vector (signed-byte 7)) + (vector (signed-byte 8))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.6 'stable-sort `((or (vector (signed-byte 10)) - (vector (signed-byte 13)) - (vector (signed-byte 15)) - (vector (signed-byte 16))) + (vector (signed-byte 13)) + (vector (signed-byte 15)) + (vector (signed-byte 16))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.7 'stable-sort `((or (vector (signed-byte 20)) - (vector (signed-byte 24)) - (vector (signed-byte 28)) - (vector (signed-byte 31)) - (vector (signed-byte 32))) + (vector (signed-byte 24)) + (vector (signed-byte 28)) + (vector (signed-byte 31)) + (vector (signed-byte 32))) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) (def-type-prop-test stable-sort.8 'stable-sort `((or (vector short-float) - (vector single-float) - (vector double-float) - (vector long-float)) + (vector single-float) + (vector double-float) + (vector long-float)) (member < <= > >= ,#'< ,#'<= ,#'> ,#'>=)) 2 :replicate '(t nil)) diff --git a/ansi-tests/random-type-prop-tests-09.lsp b/ansi-tests/random-type-prop-tests-09.lsp index 07839d34..46270c31 100644 --- a/ansi-tests/random-type-prop-tests-09.lsp +++ b/ansi-tests/random-type-prop-tests-09.lsp @@ -20,78 +20,78 @@ (def-type-prop-test find.4 'find (list t - #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len)))) + #'make-random-sequence-type-containing + '(eql :start) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len)))) 4) (def-type-prop-test find.5 'find (list t - #'make-random-sequence-type-containing - '(eql :end) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len)))) + #'make-random-sequence-type-containing + '(eql :end) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len)))) 4) (def-type-prop-test find.6 'find (list t #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :end) - #'(lambda (v s k1 start k2) - (declare (ignore v k1 k2)) - (let ((len (length s))) - `(integer ,start ,len)))) + '(eql :start) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :end) + #'(lambda (v s k1 start k2) + (declare (ignore v k1 k2)) + (let ((len (length s))) + `(integer ,start ,len)))) 6) (def-type-prop-test find.7 'find (list 'integer #'(lambda (x) (declare (ignore x)) - (make-sequence-type - (random 10) - (random-from-seq #(bit integer float rational real number)))) - '(eql :key) - '(member 1+ #.#'1+ 1- #.#'1- - #.#'-)) + (make-sequence-type + (random 10) + (random-from-seq #(bit integer float rational real number)))) + '(eql :key) + '(member 1+ #.#'1+ 1- #.#'1- - #.#'-)) 4) (def-type-prop-test find.8 'find (list 'character - #'(lambda (x) (declare (ignore x)) - (make-sequence-type - (random 10) - (random-from-seq #(character base-char standard-char)))) - '(eql :key) - '(member char-upcase #.#'char-upcase - char-downcase #.#'char-downcase - upper-case-p #.#'upper-case-p - lower-case-p #.#'lower-case-p - both-case-p #.#'both-case-p - char-code #.#'char-code - char-int #.#'char-int - alpha-char-p #.#'alpha-char-p - digit-char-p #.#'digit-char-p - alphanumericp #.#'alphanumericp)) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type + (random 10) + (random-from-seq #(character base-char standard-char)))) + '(eql :key) + '(member char-upcase #.#'char-upcase + char-downcase #.#'char-downcase + upper-case-p #.#'upper-case-p + lower-case-p #.#'lower-case-p + both-case-p #.#'both-case-p + char-code #.#'char-code + char-int #.#'char-int + alpha-char-p #.#'alpha-char-p + digit-char-p #.#'digit-char-p + alphanumericp #.#'alphanumericp)) 4) (def-type-prop-test find.9 'find (list t #'make-random-sequence-type-containing - '(eql :from-end) - '(or null t)) + '(eql :from-end) + '(or null t)) 4) (def-type-prop-test find.10 'find (list 'real #'(lambda (x) (make-sequence-type - (random 10) - (random-from-seq #(bit integer float rational real)))) - '(eql :from-end) - '(or null t) - '(member :test :test-not) - (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/= - 'equal #'equal 'eql #'eql)) + (random 10) + (random-from-seq #(bit integer float rational real)))) + '(eql :from-end) + '(or null t) + '(member :test :test-not) + (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/= + 'equal #'equal 'eql #'eql)) 6) ;;; FIND-IF @@ -99,104 +99,104 @@ (def-type-prop-test find-if.1 'find-if (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence) 2) (def-type-prop-test find-if.2 'find-if (list (let ((char-predicates - '(alpha-char-p digit-char-p upper-case-p lower-case-p - both-case-p alphanumericp graphic-char-p - standard-char-p))) + '(alpha-char-p digit-char-p upper-case-p lower-case-p + both-case-p alphanumericp graphic-char-p + standard-char-p))) (append '(member) char-predicates - (mapcar #'symbol-function char-predicates))) + (mapcar #'symbol-function char-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - '(or standard-char base-char character)))) + '(or standard-char base-char character)))) 2) (def-type-prop-test find-if.3 'find-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) + (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x)))))) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x)))))) 2) (def-type-prop-test find-if.4 'find-if (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len)))) + `(integer 0 ,len)))) 4) (def-type-prop-test find-if.5 'find-if (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len)))) + `(integer 0 ,len)))) 4) (def-type-prop-test find-if.6 'find-if (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len))) + `(integer 0 ,len))) '(eql :end) #'(lambda (f s k1 start k2) (declare (ignore f k1 k2)) (let ((len (length s))) - `(integer ,start ,len)))) + `(integer ,start ,len)))) 6) (def-type-prop-test find-if.7 'find-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) + (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) '(eql :key) (list 'member '1+ '1- 'identity '- - #'1+ #'1- #'identity #'-)) + #'1+ #'1- #'identity #'-)) 4) (def-type-prop-test find-if.8 'find-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) + (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) '(eql :from-end) '(or null t)) 4) @@ -204,12 +204,12 @@ (def-type-prop-test find-if.9 'find-if (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len))) + `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) @@ -217,12 +217,12 @@ (def-type-prop-test find-if.10 'find-if (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len))) + `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) @@ -232,104 +232,104 @@ (def-type-prop-test find-if-not.1 'find-if-not (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence) 2) (def-type-prop-test find-if-not.2 'find-if-not (list (let ((char-predicates - '(alpha-char-p digit-char-p upper-case-p lower-case-p - both-case-p alphanumericp graphic-char-p - standard-char-p))) + '(alpha-char-p digit-char-p upper-case-p lower-case-p + both-case-p alphanumericp graphic-char-p + standard-char-p))) (append '(member) char-predicates - (mapcar #'symbol-function char-predicates))) + (mapcar #'symbol-function char-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - '(or standard-char base-char character)))) + '(or standard-char base-char character)))) 2) (def-type-prop-test find-if-not.3 'find-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) + (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x)))))) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x)))))) 2) (def-type-prop-test find-if-not.4 'find-if-not (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len)))) + `(integer 0 ,len)))) 4) (def-type-prop-test find-if-not.5 'find-if-not (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len)))) + `(integer 0 ,len)))) 4) (def-type-prop-test find-if-not.6 'find-if-not (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len))) + `(integer 0 ,len))) '(eql :end) #'(lambda (f s k1 start k2) (declare (ignore f k1 k2)) (let ((len (length s))) - `(integer ,start ,len)))) + `(integer ,start ,len)))) 6) (def-type-prop-test find-if-not.7 'find-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) + (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) '(eql :key) (list 'member '1+ '1- 'identity '- - #'1+ #'1- #'identity #'-)) + #'1+ #'1- #'identity #'-)) 4) (def-type-prop-test find-if-not.8 'find-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) + (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) '(eql :from-end) '(or null t)) 4) @@ -337,12 +337,12 @@ (def-type-prop-test find-if-not.9 'find-if-not (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len))) + `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) @@ -350,12 +350,12 @@ (def-type-prop-test find-if-not.10 'find-if-not (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len))) + `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) @@ -376,78 +376,78 @@ (def-type-prop-test position.4 'position (list t - #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len)))) + #'make-random-sequence-type-containing + '(eql :start) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len)))) 4) (def-type-prop-test position.5 'position (list t - #'make-random-sequence-type-containing - '(eql :end) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len)))) + #'make-random-sequence-type-containing + '(eql :end) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len)))) 4) (def-type-prop-test position.6 'position (list t #'make-random-sequence-type-containing - '(eql :start) - #'(lambda (v s k1) (declare (ignore v k1)) - (let ((len (length s))) - `(integer 0 ,len))) - '(eql :end) - #'(lambda (v s k1 start k2) - (declare (ignore v k1 k2)) - (let ((len (length s))) - `(integer ,start ,len)))) + '(eql :start) + #'(lambda (v s k1) (declare (ignore v k1)) + (let ((len (length s))) + `(integer 0 ,len))) + '(eql :end) + #'(lambda (v s k1 start k2) + (declare (ignore v k1 k2)) + (let ((len (length s))) + `(integer ,start ,len)))) 6) (def-type-prop-test position.7 'position (list 'integer #'(lambda (x) (declare (ignore x)) - (make-sequence-type - (random 10) - (random-from-seq #(bit integer float rational real number)))) - '(eql :key) - '(member 1+ #.#'1+ 1- #.#'1- - #.#'-)) + (make-sequence-type + (random 10) + (random-from-seq #(bit integer float rational real number)))) + '(eql :key) + '(member 1+ #.#'1+ 1- #.#'1- - #.#'-)) 4) (def-type-prop-test position.8 'position (list 'character - #'(lambda (x) (declare (ignore x)) - (make-sequence-type - (random 10) - (random-from-seq #(character base-char standard-char)))) - '(eql :key) - '(member char-upcase #.#'char-upcase - char-downcase #.#'char-downcase - upper-case-p #.#'upper-case-p - lower-case-p #.#'lower-case-p - both-case-p #.#'both-case-p - char-code #.#'char-code - char-int #.#'char-int - alpha-char-p #.#'alpha-char-p - digit-char-p #.#'digit-char-p - alphanumericp #.#'alphanumericp)) + #'(lambda (x) (declare (ignore x)) + (make-sequence-type + (random 10) + (random-from-seq #(character base-char standard-char)))) + '(eql :key) + '(member char-upcase #.#'char-upcase + char-downcase #.#'char-downcase + upper-case-p #.#'upper-case-p + lower-case-p #.#'lower-case-p + both-case-p #.#'both-case-p + char-code #.#'char-code + char-int #.#'char-int + alpha-char-p #.#'alpha-char-p + digit-char-p #.#'digit-char-p + alphanumericp #.#'alphanumericp)) 4) (def-type-prop-test position.9 'position (list t #'make-random-sequence-type-containing - '(eql :from-end) - '(or null t)) + '(eql :from-end) + '(or null t)) 4) (def-type-prop-test position.10 'position (list 'real #'(lambda (x) (make-sequence-type - (random 10) - (random-from-seq #(bit integer float rational real)))) - '(eql :from-end) - '(or null t) - '(member :test :test-not) - (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/= - 'equal #'equal 'eql #'eql)) + (random 10) + (random-from-seq #(bit integer float rational real)))) + '(eql :from-end) + '(or null t) + '(member :test :test-not) + (list 'member '< #'< '> #'> '<= #'<= '>= #'>= '= #'= '/= #'/= + 'equal #'equal 'eql #'eql)) 6) ;;; POSITION-IF @@ -455,104 +455,104 @@ (def-type-prop-test position-if.1 'position-if (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence) 2) (def-type-prop-test position-if.2 'position-if (list (let ((char-predicates - '(alpha-char-p digit-char-p upper-case-p lower-case-p - both-case-p alphanumericp graphic-char-p - standard-char-p))) + '(alpha-char-p digit-char-p upper-case-p lower-case-p + both-case-p alphanumericp graphic-char-p + standard-char-p))) (append '(member) char-predicates - (mapcar #'symbol-function char-predicates))) + (mapcar #'symbol-function char-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - '(or standard-char base-char character)))) + '(or standard-char base-char character)))) 2) (def-type-prop-test position-if.3 'position-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) + (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x)))))) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x)))))) 2) (def-type-prop-test position-if.4 'position-if (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len)))) + `(integer 0 ,len)))) 4) (def-type-prop-test position-if.5 'position-if (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len)))) + `(integer 0 ,len)))) 4) (def-type-prop-test position-if.6 'position-if (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len))) + `(integer 0 ,len))) '(eql :end) #'(lambda (f s k1 start k2) (declare (ignore f k1 k2)) (let ((len (length s))) - `(integer ,start ,len)))) + `(integer ,start ,len)))) 6) (def-type-prop-test position-if.7 'position-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) + (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) '(eql :key) (list 'member '1+ '1- 'identity '- - #'1+ #'1- #'identity #'-)) + #'1+ #'1- #'identity #'-)) 4) (def-type-prop-test position-if.8 'position-if (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) + (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) '(eql :from-end) '(or null t)) 4) @@ -560,12 +560,12 @@ (def-type-prop-test position-if.9 'position-if (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len))) + `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) @@ -573,12 +573,12 @@ (def-type-prop-test position-if.10 'position-if (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len))) + `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) @@ -588,104 +588,104 @@ (def-type-prop-test position-if-not.1 'position-if-not (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence) 2) (def-type-prop-test position-if-not.2 'position-if-not (list (let ((char-predicates - '(alpha-char-p digit-char-p upper-case-p lower-case-p - both-case-p alphanumericp graphic-char-p - standard-char-p))) + '(alpha-char-p digit-char-p upper-case-p lower-case-p + both-case-p alphanumericp graphic-char-p + standard-char-p))) (append '(member) char-predicates - (mapcar #'symbol-function char-predicates))) + (mapcar #'symbol-function char-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - '(or standard-char base-char character)))) + '(or standard-char base-char character)))) 2) (def-type-prop-test position-if-not.3 'position-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) + (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x)))))) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x)))))) 2) (def-type-prop-test position-if-not.4 'position-if-not (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len)))) + `(integer 0 ,len)))) 4) (def-type-prop-test position-if-not.5 'position-if-not (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len)))) + `(integer 0 ,len)))) 4) (def-type-prop-test position-if-not.6 'position-if-not (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len))) + `(integer 0 ,len))) '(eql :end) #'(lambda (f s k1 start k2) (declare (ignore f k1 k2)) (let ((len (length s))) - `(integer ,start ,len)))) + `(integer ,start ,len)))) 6) (def-type-prop-test position-if-not.7 'position-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) + (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) '(eql :key) (list 'member '1+ '1- 'identity '- - #'1+ #'1- #'identity #'-)) + #'1+ #'1- #'identity #'-)) 4) (def-type-prop-test position-if-not.8 'position-if-not (list (let ((integer-predicates '(zerop plusp minusp evenp oddp))) (append '(member) integer-predicates - (mapcar #'symbol-function integer-predicates))) + (mapcar #'symbol-function integer-predicates))) #'(lambda (x) (declare (ignore x)) (make-sequence-type (random 10) - `(or bit bit bit bit bit bit bit - ,@(loop for x from 2 to 32 - collect `(unsigned-byte ,x)) - ,@(loop for x from 2 to 32 - collect `(signed-byte ,x))))) + `(or bit bit bit bit bit bit bit + ,@(loop for x from 2 to 32 + collect `(unsigned-byte ,x)) + ,@(loop for x from 2 to 32 + collect `(signed-byte ,x))))) '(eql :from-end) '(or null t)) 4) @@ -693,12 +693,12 @@ (def-type-prop-test position-if-not.9 'position-if-not (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :start) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len))) + `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) @@ -706,12 +706,12 @@ (def-type-prop-test position-if-not.10 'position-if-not (list (append '(member) *cl-safe-predicates* - (mapcar 'symbol-function *cl-safe-predicates*)) + (mapcar 'symbol-function *cl-safe-predicates*)) 'sequence '(eql :end) #'(lambda (f s k1) (declare (ignore f k1)) (let ((len (length s))) - `(integer 0 ,len))) + `(integer 0 ,len))) '(eql :from-end) '(or null t)) 6) diff --git a/ansi-tests/random-type-prop-tests-10.lsp b/ansi-tests/random-type-prop-tests-10.lsp index 495fcb94..71d23474 100644 --- a/ansi-tests/random-type-prop-tests-10.lsp +++ b/ansi-tests/random-type-prop-tests-10.lsp @@ -24,91 +24,91 @@ (def-type-prop-test search.5 'search (list 'sequence 'sequence '(eql :key) - (list 'member 'identity nil #'identity 'not #'not)) + (list 'member 'identity nil #'identity 'not #'not)) 4) (def-type-prop-test search.6 'search (list #'(lambda () (make-sequence-type - (random 10) - (let ((i1 (make-random-integer)) - (i2 (make-random-integer))) - `(integer ,(min i1 i2) ,(max i1 i2))))) - #'(lambda (s) - (declare (ignore s)) - (make-sequence-type - (random 10) - (let ((i1 (make-random-integer)) - (i2 (make-random-integer))) - `(integer ,(min i1 i2) ,(max i1 i2)))))) + (random 10) + (let ((i1 (make-random-integer)) + (i2 (make-random-integer))) + `(integer ,(min i1 i2) ,(max i1 i2))))) + #'(lambda (s) + (declare (ignore s)) + (make-sequence-type + (random 10) + (let ((i1 (make-random-integer)) + (i2 (make-random-integer))) + `(integer ,(min i1 i2) ,(max i1 i2)))))) 2) (def-type-prop-test search.7 'search (list #'(lambda () (make-sequence-type - (random 10) - (let ((i1 (make-random-integer)) - (i2 (make-random-integer))) - `(integer ,(min i1 i2) ,(max i1 i2))))) - #'(lambda (s) - (declare (ignore s)) - (make-sequence-type - (random 10) - (let ((i1 (make-random-integer)) - (i2 (make-random-integer))) - `(integer ,(min i1 i2) ,(max i1 i2))))) - '(eql :test) - (list 'member 'eql #'eql 'equal #'equal '= #'= - '/= #'/= #'(lambda (x y) (= (logand x 1) (logand y 1))))) + (random 10) + (let ((i1 (make-random-integer)) + (i2 (make-random-integer))) + `(integer ,(min i1 i2) ,(max i1 i2))))) + #'(lambda (s) + (declare (ignore s)) + (make-sequence-type + (random 10) + (let ((i1 (make-random-integer)) + (i2 (make-random-integer))) + `(integer ,(min i1 i2) ,(max i1 i2))))) + '(eql :test) + (list 'member 'eql #'eql 'equal #'equal '= #'= + '/= #'/= #'(lambda (x y) (= (logand x 1) (logand y 1))))) 4) (def-type-prop-test search.8 'search (labels ((%random-char-type () (random-from-seq #(base-char standard-char character))) - (%random-char-sequence-type (&rest ignored) - (declare (ignore ignored)) - (make-sequence-type (random 10) (%random-char-type)))) - - (list #'%random-char-sequence-type - #'%random-char-sequence-type - '(member :test :test-not) - (let ((char-compare-funs - '(char= char/= char< char> char<= char>= - char-equal char-not-equal char-lessp char-greaterp - char-not-lessp char-not-greaterp))) - `(member ,@char-compare-funs - ,@(mapcar #'symbol-function char-compare-funs))))) + (%random-char-sequence-type (&rest ignored) + (declare (ignore ignored)) + (make-sequence-type (random 10) (%random-char-type)))) + + (list #'%random-char-sequence-type + #'%random-char-sequence-type + '(member :test :test-not) + (let ((char-compare-funs + '(char= char/= char< char> char<= char>= + char-equal char-not-equal char-lessp char-greaterp + char-not-lessp char-not-greaterp))) + `(member ,@char-compare-funs + ,@(mapcar #'symbol-function char-compare-funs))))) 4) (def-type-prop-test search.9 'search (list 'sequence 'sequence - '(eql :start1) - #'(lambda (s1 s2 k) - (declare (ignore s2 k)) - (let ((len (length s1))) - `(integer 0 ,len)))) + '(eql :start1) + #'(lambda (s1 s2 k) + (declare (ignore s2 k)) + (let ((len (length s1))) + `(integer 0 ,len)))) 4) (def-type-prop-test search.10 'search (list 'sequence 'sequence - '(eql :end1) - #'(lambda (s1 s2 k) - (declare (ignore s2 k)) - (let ((len (length s1))) - `(integer 0 ,len)))) + '(eql :end1) + #'(lambda (s1 s2 k) + (declare (ignore s2 k)) + (let ((len (length s1))) + `(integer 0 ,len)))) 4) (def-type-prop-test search.11 'search (list 'sequence 'sequence - '(eql :start2) - #'(lambda (s1 s2 k) - (declare (ignore s1 k)) - (let ((len (length s2))) - `(integer 0 ,len)))) + '(eql :start2) + #'(lambda (s1 s2 k) + (declare (ignore s1 k)) + (let ((len (length s2))) + `(integer 0 ,len)))) 4) (def-type-prop-test search.12 'search (list 'sequence 'sequence - '(eql :end2) - #'(lambda (s1 s2 k) - (declare (ignore s1 k)) - (let ((len (length s2))) - `(integer 0 ,len)))) + '(eql :end2) + #'(lambda (s1 s2 k) + (declare (ignore s1 k)) + (let ((len (length s2))) + `(integer 0 ,len)))) 4) diff --git a/ansi-tests/random-type-prop-tests-structs.lsp b/ansi-tests/random-type-prop-tests-structs.lsp index 2e3124a1..9a4423ad 100644 --- a/ansi-tests/random-type-prop-tests-structs.lsp +++ b/ansi-tests/random-type-prop-tests-structs.lsp @@ -8,15 +8,15 @@ (defmethod make-random-element-of-type ((type (eql 'rtpt-1))) (make-rtpt-1 :a (make-random-element-of-type t) - :b (make-random-element-of-type t))) + :b (make-random-element-of-type t))) (defmethod replicate ((obj rtpt-1)) (or (gethash obj *replicate-table*) (let ((x (make-rtpt-1))) - (setf (gethash obj *replicate-table*) x) - (setf (rtpt-1-a x) (replicate (rtpt-1-a obj))) - (setf (rtpt-1-b x) (replicate (rtpt-1-b obj))) - x))) + (setf (gethash obj *replicate-table*) x) + (setf (rtpt-1-a x) (replicate (rtpt-1-a obj))) + (setf (rtpt-1-b x) (replicate (rtpt-1-b obj))) + x))) (defmethods make-random-type-containing* (1 ((val rtpt-1)) 'rtpt-1)) @@ -39,29 +39,29 @@ (defmethod make-random-element-of-type ((type (eql 'rtpt-2.1))) (make-rtpt-2.1 :a (make-random-element-of-type t) - :c (make-random-element-of-type t) - :d (make-random-element-of-type t))) + :c (make-random-element-of-type t) + :d (make-random-element-of-type t))) (defmethod make-random-element-of-type ((type (eql 'rtpt-2.2))) (make-rtpt-2.2 :a (make-random-element-of-type t) - :d (make-random-element-of-type t) - :e (make-random-element-of-type t))) + :d (make-random-element-of-type t) + :e (make-random-element-of-type t))) (defmethod replicate ((obj rtpt-2)) (replicate-with (obj x (make-rtpt-2)) - (setf (rtpt-2-a x) (replicate (rtpt-2-a obj))))) + (setf (rtpt-2-a x) (replicate (rtpt-2-a obj))))) (defmethod replicate ((obj rtpt-2.1)) (replicate-with (obj x (make-rtpt-2.1)) - (setf (rtpt-2.1-a x) (replicate (rtpt-2.1-a obj))) - (setf (rtpt-2.1-c x) (replicate (rtpt-2.1-c obj))) - (setf (rtpt-2.1-d x) (replicate (rtpt-2.1-d obj))))) + (setf (rtpt-2.1-a x) (replicate (rtpt-2.1-a obj))) + (setf (rtpt-2.1-c x) (replicate (rtpt-2.1-c obj))) + (setf (rtpt-2.1-d x) (replicate (rtpt-2.1-d obj))))) (defmethod replicate ((obj rtpt-2.2)) (replicate-with (obj x (make-rtpt-2.2)) - (setf (rtpt-2.2-a x) (replicate (rtpt-2.2-a obj))) - (setf (rtpt-2.2-d x) (replicate (rtpt-2.2-d obj))) - (setf (rtpt-2.2-e x) (replicate (rtpt-2.2-e obj))))) + (setf (rtpt-2.2-a x) (replicate (rtpt-2.2-a obj))) + (setf (rtpt-2.2-d x) (replicate (rtpt-2.2-d obj))) + (setf (rtpt-2.2-e x) (replicate (rtpt-2.2-e obj))))) (defmethods make-random-type-containing* (1 ((val rtpt-2)) 'rtpt-2) diff --git a/ansi-tests/random-type-prop.lsp b/ansi-tests/random-type-prop.lsp index aed1e0c1..bacb02cf 100644 --- a/ansi-tests/random-type-prop.lsp +++ b/ansi-tests/random-type-prop.lsp @@ -90,19 +90,19 @@ ;;; destructive operators. ;;; ;;; - + (defun do-random-type-prop-tests (operator arg-types minargs - &key - (maxargs minargs) - (rest-type t) - (reps *default-reps*) - (enclosing-the nil) - (arg-the *default-arg-the*) - (cell *default-cell*) - (ignore *default-ignore*) - (test #'regression-test::equalp-with-case) - (replicate nil replicate-p)) + &key + (maxargs minargs) + (rest-type t) + (reps *default-reps*) + (enclosing-the nil) + (arg-the *default-arg-the*) + (cell *default-cell*) + (ignore *default-ignore*) + (test #'regression-test::equalp-with-case) + (replicate nil replicate-p)) (assert (<= 1 minargs maxargs 20)) (prog1 (dotimes (i reps) @@ -111,133 +111,133 @@ #-lispworks ((error #'(lambda (c) (when (typep c ignore) (go again))))) #+lispworks () (let* ((param-names - '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 - p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)) - (nargs (+ minargs (random (- maxargs minargs -1)))) - (types (subseq - (append arg-types - (make-list (max 0 (- nargs (length arg-types))) - :initial-element rest-type)) - 0 nargs)) - (replicate (if replicate-p replicate - (mapcar (constantly nil) types))) - ; (vals (mapcar #'make-random-element-of-type types)) - (vals (setq *params* - (or (make-random-arguments types) (go again)))) - (vals - (if replicate - (mapcar #'replicate vals) - vals)) - (is-var? (if (consp replicate) - (progn - (assert (= (length replicate) (length vals))) - (loop for x in replicate collect (or x (coin)))) - (loop repeat (length vals) collect (coin)))) - (*is-var?* is-var?) - (params (loop for x in is-var? - for p in param-names - when x collect p)) - (param-types (mapcar #'make-random-type-containing vals replicate)) - (*param-types* param-types) - (type-decls (loop for x in is-var? - for p in param-names - for tp in param-types - when x - collect `(type ,tp ,p))) - (rval (cl:handler-bind - (#+sbcl (sb-ext::compiler-note #'muffle-warning) - (warning #'muffle-warning)) - (let* ((vals (if replicate (mapcar #'replicate vals) vals)) - (eval-form (cons operator (loop for v in vals - collect `(quote ,v))))) - ;; (print eval-form) (terpri) - ;; (dotimes (i 100) (eval eval-form)) - (eval eval-form)))) - (result-type (if (and enclosing-the (integerp rval)) - (make-random-type-containing rval) - t)) - (expr `(,operator ,@(loop for x in is-var? - for v in vals - for r in replicate - for p in param-names - collect (if x - (if (and arg-the (coin)) - (let ((tp (make-random-type-containing v r))) - `(the ,tp ,p)) - p) - (if (or (consp v) - (and (symbolp v) (not (or (keywordp v) - (member v '(nil t)))))) - `(quote ,v) - v))))) - (speed (random 4)) - (space (random 4)) - (safety #-allegro (random 4) - #+allegro (1+ (random 3))) - (debug (random 4)) - (store-into-cell? (and cell (coin))) - (upgraded-result-type (and store-into-cell? - (upgraded-array-element-type `(eql ,rval)))) - (form - (setq *form* - `(lambda (,@(when store-into-cell? '(r)) ,@params) - (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space)) - ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r))) - ,@ type-decls) - ,(let ((result-form - (if enclosing-the `(the ,result-type ,expr) expr))) - (if store-into-cell? - `(setf (aref r) ,result-form) - result-form))))) - ) + '(p1 p2 p3 p4 p5 p6 p7 p8 p9 p10 + p11 p12 p13 p14 p15 p16 p17 p18 p19 p20)) + (nargs (+ minargs (random (- maxargs minargs -1)))) + (types (subseq + (append arg-types + (make-list (max 0 (- nargs (length arg-types))) + :initial-element rest-type)) + 0 nargs)) + (replicate (if replicate-p replicate + (mapcar (constantly nil) types))) + ; (vals (mapcar #'make-random-element-of-type types)) + (vals (setq *params* + (or (make-random-arguments types) (go again)))) + (vals + (if replicate + (mapcar #'replicate vals) + vals)) + (is-var? (if (consp replicate) + (progn + (assert (= (length replicate) (length vals))) + (loop for x in replicate collect (or x (coin)))) + (loop repeat (length vals) collect (coin)))) + (*is-var?* is-var?) + (params (loop for x in is-var? + for p in param-names + when x collect p)) + (param-types (mapcar #'make-random-type-containing vals replicate)) + (*param-types* param-types) + (type-decls (loop for x in is-var? + for p in param-names + for tp in param-types + when x + collect `(type ,tp ,p))) + (rval (cl:handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning)) + (let* ((vals (if replicate (mapcar #'replicate vals) vals)) + (eval-form (cons operator (loop for v in vals + collect `(quote ,v))))) + ;; (print eval-form) (terpri) + ;; (dotimes (i 100) (eval eval-form)) + (eval eval-form)))) + (result-type (if (and enclosing-the (integerp rval)) + (make-random-type-containing rval) + t)) + (expr `(,operator ,@(loop for x in is-var? + for v in vals + for r in replicate + for p in param-names + collect (if x + (if (and arg-the (coin)) + (let ((tp (make-random-type-containing v r))) + `(the ,tp ,p)) + p) + (if (or (consp v) + (and (symbolp v) (not (or (keywordp v) + (member v '(nil t)))))) + `(quote ,v) + v))))) + (speed (random 4)) + (space (random 4)) + (safety #-allegro (random 4) + #+allegro (1+ (random 3))) + (debug (random 4)) + (store-into-cell? (and cell (coin))) + (upgraded-result-type (and store-into-cell? + (upgraded-array-element-type `(eql ,rval)))) + (form + (setq *form* + `(lambda (,@(when store-into-cell? '(r)) ,@params) + (declare (optimize (speed ,speed) (safety ,safety) (debug ,debug) (space ,space)) + ,@(when store-into-cell? `((type (simple-array ,upgraded-result-type nil) r))) + ,@ type-decls) + ,(let ((result-form + (if enclosing-the `(the ,result-type ,expr) expr))) + (if store-into-cell? + `(setf (aref r) ,result-form) + result-form))))) + ) (when *print-random-type-prop-input* (let ((*print-pretty* t) - (*print-case* :downcase)) - (print (list :form form :vals vals)))) + (*print-case* :downcase)) + (print (list :form form :vals vals)))) (finish-output) (let* ((param-vals (loop for x in is-var? - for v in vals - when x collect v)) - (fn (cl:handler-bind - (#+sbcl (sb-ext::compiler-note #'muffle-warning) - (warning #'muffle-warning)) - (compile nil form))) - (result - (if store-into-cell? - (let ((r (make-array nil :element-type upgraded-result-type))) - (apply fn r param-vals) - (aref r)) - (apply fn param-vals)))) + for v in vals + when x collect v)) + (fn (cl:handler-bind + (#+sbcl (sb-ext::compiler-note #'muffle-warning) + (warning #'muffle-warning)) + (compile nil form))) + (result + (if store-into-cell? + (let ((r (make-array nil :element-type upgraded-result-type))) + (apply fn r param-vals) + (aref r)) + (apply fn param-vals)))) (setq *random-type-prop-result* - (list :upgraded-result-type upgraded-result-type - :form form - :vals vals - :result result - :rval rval)) + (list :upgraded-result-type upgraded-result-type + :form form + :vals vals + :result result + :rval rval)) (unless (funcall test result rval) - (return *random-type-prop-result*)))) + (return *random-type-prop-result*)))) ;; #+allegro (excl::gc t) )))) (defun make-random-arguments (types-or-funs) (let ((vals nil)) (loop for type-or-fun in types-or-funs - for type = (or (typecase type-or-fun - ((and function (not symbol)) - (apply type-or-fun vals)) - (t type-or-fun)) - (return-from make-random-arguments nil) ;; null type - ) - for val = (make-random-element-of-type type) - do (setf vals (nconc vals (list val)))) + for type = (or (typecase type-or-fun + ((and function (not symbol)) + (apply type-or-fun vals)) + (t type-or-fun)) + (return-from make-random-arguments nil) ;; null type + ) + for val = (make-random-element-of-type type) + do (setf vals (nconc vals (list val)))) ;; (dolist (v vals) (describe v)) vals)) (defmacro defmethods (name &rest bodies) `(progn ,@(mapcar - #'(lambda (body) `(defmethod ,name ,@body)) - bodies))) + #'(lambda (body) `(defmethod ,name ,@body)) + bodies))) (defgeneric make-random-type-containing* (val) (:method-combination randomized) @@ -256,16 +256,16 @@ use the value in MEMBER or EQL type specifiers.")) (1 t) (1 (if (consp val) 'cons 'atom)) (1 (if *replicate-type* (make-random-type-containing* val) - `(eql ,val))) - (1 + `(eql ,val))) + (1 (if *replicate-type* (make-random-type-containing* val) - (let* ((n1 (random 4)) - (n2 (random 4)) - ;; Replace these calls with (make-random-element-of-type t) - ;; at some point - (l1 (loop repeat n1 collect (random-leaf))) - (l2 (loop repeat n2 collect (random-leaf)))) - `(member ,@l1 ,val ,@l2)))))) + (let* ((n1 (random 4)) + (n2 (random 4)) + ;; Replace these calls with (make-random-element-of-type t) + ;; at some point + (l1 (loop repeat n1 collect (random-leaf))) + (l2 (loop repeat n2 collect (random-leaf)))) + `(member ,@l1 ,val ,@l2)))))) (1 ((val standard-object)) 'standard-object) (1 ((val structure-object)) 'structure-object) @@ -281,34 +281,34 @@ use the value in MEMBER or EQL type specifiers.")) (1 'integer) (1 'signed-byte) (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (make-random-integer))) - (l2 (loop repeat n2 collect (make-random-integer)))) - `(member ,@l1 ,val ,@l2))) + (n2 (random 4)) + (l1 (loop repeat n1 collect (make-random-integer))) + (l2 (loop repeat n2 collect (make-random-integer)))) + `(member ,@l1 ,val ,@l2))) (1 (let ((lo (abs (make-random-integer)))) - `(integer ,(- val lo)))) + `(integer ,(- val lo)))) (2 (let ((lo (abs (make-random-integer)))) - `(integer ,(- val lo) *))) + `(integer ,(- val lo) *))) (2 (let ((hi (abs (make-random-integer)))) - `(integer * ,(+ val hi)))) + `(integer * ,(+ val hi)))) (4 (let ((lo (abs (make-random-integer))) - (hi (abs (make-random-integer)))) - `(integer ,(- val lo) ,(+ val hi)))) + (hi (abs (make-random-integer)))) + `(integer ,(- val lo) ,(+ val hi)))) (1 (if (>= val 0) 'unsigned-byte (throw 'fail nil))))) (2 ((val character)) (rcase (1 'character) (1 (if (typep val 'base-char) 'base-char - #-sbcl 'extended-char - #+sbcl (throw 'fail nil) - )) + #-sbcl 'extended-char + #+sbcl (throw 'fail nil) + )) (1 (if (typep val 'standard-char) 'standard-char (throw 'fail nil))) (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (make-random-character))) - (l2 (loop repeat n2 collect (make-random-character)))) - `(member ,@l1 ,val ,@l2))))) + (n2 (random 4)) + (l1 (loop repeat n1 collect (make-random-character))) + (l2 (loop repeat n2 collect (make-random-character)))) + `(member ,@l1 ,val ,@l2))))) (1 ((val null)) 'null) @@ -317,45 +317,45 @@ use the value in MEMBER or EQL type specifiers.")) (1 'symbol) (1 (typecase val (boolean 'boolean) (keyword 'keyword) (otherwise (throw 'fail nil)))) (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (make-random-symbol))) - (l2 (loop repeat n2 collect (make-random-symbol)))) - `(member ,@l1 ,val ,@l2))))) + (n2 (random 4)) + (l1 (loop repeat n1 collect (make-random-symbol))) + (l2 (loop repeat n2 collect (make-random-symbol)))) + `(member ,@l1 ,val ,@l2))))) (1 ((val rational)) (rcase (1 'rational) (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) - (l2 (loop repeat n2 collect (make-random-element-of-type 'rational)))) - `(member ,@l1 ,val ,@l2))) + (n2 (random 4)) + (l1 (loop repeat n1 collect (make-random-element-of-type 'rational))) + (l2 (loop repeat n2 collect (make-random-element-of-type 'rational)))) + `(member ,@l1 ,val ,@l2))) (1 `(rational ,val)) (1 `(rational * ,val)) (1 (let ((v (make-random-element-of-type 'rational))) - (if (<= v val) - `(rational ,v ,val) - `(rational ,val ,v)))))) - + (if (<= v val) + `(rational ,v ,val) + `(rational ,val ,v)))))) + (1 ((val float)) (rcase (1 (let* ((n1 (random 4)) - (n2 (random 4)) - (l1 (loop repeat n1 collect (- 2 (random (float 1.0 val))))) - (l2 (loop repeat n2 collect (- 2 (random (float 1.0 val)))))) - `(member ,@l1 ,val ,@l2))) + (n2 (random 4)) + (l1 (loop repeat n1 collect (- 2 (random (float 1.0 val))))) + (l2 (loop repeat n2 collect (- 2 (random (float 1.0 val)))))) + `(member ,@l1 ,val ,@l2))) (1 (let ((names (float-types-containing val))) - (random-from-seq names))) + (random-from-seq names))) (1 (let ((name (random-from-seq (float-types-containing val)))) - (if (>= val 0) - `(,name ,(coerce 0 name) ,val) - `(,name ,val ,(coerce 0 name))))))) + (if (>= val 0) + `(,name ,(coerce 0 name) ,val) + `(,name ,val ,(coerce 0 name))))))) ) (defun float-types-containing (val) (loop for n in '(short-float single-float double-float long-float float) - when (typep val n) - collect n)) + when (typep val n) + collect n)) (defun make-random-array-dimension-spec (array dim-index) (assert (<= 0 dim-index)) @@ -367,54 +367,54 @@ use the value in MEMBER or EQL type specifiers.")) (defmethods make-random-type-containing* (3 ((val bit-vector)) (let ((root (if (and (coin) - (typep val 'simple-bit-vector)) - 'simple-bit-vector - 'bit-vector))) + (typep val 'simple-bit-vector)) + 'simple-bit-vector + 'bit-vector))) (rcase (1 root) - (1 `(,root)) - (3 `(,root ,(make-random-array-dimension-spec val 0)))))) + (1 `(,root)) + (3 `(,root ,(make-random-array-dimension-spec val 0)))))) (3 ((val vector)) (let ((root 'vector) - (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector)) - (etype (rcase (1 '*) - (1 (array-element-type val)) - ;; Add rule for creating new element types? - ))) - (rcase (1 alt-root) - (1 `(,alt-root)) - (1 `(,root ,etype)) - (2 (if (and (simple-vector-p val) (coin)) - `(simple-vector ,(make-random-array-dimension-spec val 0)) - `(,root ,etype ,(make-random-array-dimension-spec val 0))))))) + (alt-root (if (and (coin) (simple-vector-p val)) 'simple-vector 'vector)) + (etype (rcase (1 '*) + (1 (array-element-type val)) + ;; Add rule for creating new element types? + ))) + (rcase (1 alt-root) + (1 `(,alt-root)) + (1 `(,root ,etype)) + (2 (if (and (simple-vector-p val) (coin)) + `(simple-vector ,(make-random-array-dimension-spec val 0)) + `(,root ,etype ,(make-random-array-dimension-spec val 0))))))) (3 ((val array)) (let ((root (if (and (coin) (typep val 'simple-array)) 'simple-array 'array)) - (etype (rcase (1 (array-element-type val)) (1 '*))) - (rank (array-rank val))) + (etype (rcase (1 (array-element-type val)) (1 '*))) + (rank (array-rank val))) (rcase - (1 root) - (1 `(,root)) - (1 `(,root ,etype)) - (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) - (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) - #-ecl (1 `(,root ,etype ,rank))))) + (1 root) + (1 `(,root)) + (1 `(,root ,etype)) + (1 `(,root ,etype ,(loop for i below rank collect (make-random-array-dimension-spec val i)))) + (1 `(,root ,etype ,(loop for i below rank collect (array-dimension val i)))) + #-ecl (1 `(,root ,etype ,rank))))) (3 ((val string)) (let ((root (cond - ((and (coin) - (typep val 'base-string)) - (cond - ((and (coin) (typep val 'simple-base-string)) - 'simple-base-string) - (t 'base-string))) - ((and (coin) - (typep val 'simple-string)) - 'simple-string) - (t 'string)))) + ((and (coin) + (typep val 'base-string)) + (cond + ((and (coin) (typep val 'simple-base-string)) + 'simple-base-string) + (t 'base-string))) + ((and (coin) + (typep val 'simple-string)) + 'simple-string) + (t 'string)))) (rcase (1 root) - (1 `(,root)) - (3 `(,root ,(make-random-array-dimension-spec val 0)))))) + (1 `(,root)) + (3 `(,root ,(make-random-array-dimension-spec val 0)))))) (1 ((val list)) 'list) @@ -422,48 +422,48 @@ use the value in MEMBER or EQL type specifiers.")) (rcase (1 'cons) (2 `(cons ,(make-random-type-containing* (car val)) - ,(make-random-type-containing* (cdr val)))) + ,(make-random-type-containing* (cdr val)))) (1 `(cons ,(make-random-type-containing* (car val)) - ,(random-from-seq #(t *)))) + ,(random-from-seq #(t *)))) (1 `(cons ,(make-random-type-containing* (car val)))) (1 `(cons ,(random-from-seq #(t *)) - ,(make-random-type-containing* (cdr val)) - )))) + ,(make-random-type-containing* (cdr val)) + )))) (1 ((val complex)) (rcase (1 'complex) #-gcl (1 (let* ((t1 (type-of (realpart val))) - (t2 (type-of (imagpart val))) - (part-type - (cond - ((subtypep t1 t2) (upgraded-complex-part-type t2)) - ((subtypep t2 t1) (upgraded-complex-part-type t1)) - ((and (subtypep t1 'rational) - (subtypep t2 'rational)) - 'rational) - (t - (upgraded-complex-part-type `(or ,t1 ,t2)))))) - (if (subtypep 'real part-type) - '(complex real) - `(complex ,part-type)))))) + (t2 (type-of (imagpart val))) + (part-type + (cond + ((subtypep t1 t2) (upgraded-complex-part-type t2)) + ((subtypep t2 t1) (upgraded-complex-part-type t1)) + ((and (subtypep t1 'rational) + (subtypep t2 'rational)) + 'rational) + (t + (upgraded-complex-part-type `(or ,t1 ,t2)))))) + (if (subtypep 'real part-type) + '(complex real) + `(complex ,part-type)))))) (1 ((val generic-function)) 'generic-function) (1 ((val function)) (rcase (1 'function) (1 (if (typep val 'compiled-function) - 'compiled-function - 'function)))) + 'compiled-function + 'function)))) ) ;;; Macro for defining random type prop tests (defmacro def-type-prop-test (name &body args) `(deftest ,(intern (concatenate 'string "RANDOM-TYPE-PROP." - (string name)) - (find-package :cl-test)) + (string name)) + (find-package :cl-test)) (do-random-type-prop-tests ,@args) nil)) @@ -472,7 +472,7 @@ use the value in MEMBER or EQL type specifiers.")) (defun make-list-type (length &optional (rest-type 'null) (element-type t)) (let ((result rest-type)) (loop repeat length - do (setq result `(cons ,element-type ,result))) + do (setq result `(cons ,element-type ,result))) result)) (defun make-sequence-type (length &optional (element-type t)) @@ -497,7 +497,7 @@ use the value in MEMBER or EQL type specifiers.")) #'(lambda (array &rest other) (declare (ignore other)) (let ((d (array-dimension array dim))) - (and (> d 0) `(integer 0 (,d)))))) + (and (> d 0) `(integer 0 (,d)))))) (defun index-type-for-v1 (v1 &rest other) "Computes integer type for valid indices for the first of two vectors" @@ -512,13 +512,13 @@ use the value in MEMBER or EQL type specifiers.")) (defun end-type-for-v1 (v1 v2 &rest other) (declare (ignore v2)) (let ((d (length v1)) - (start1 (or (cadr (member :start1 other)) 0))) + (start1 (or (cadr (member :start1 other)) 0))) `(integer ,start1 ,d))) (defun end-type-for-v2 (v1 v2 &rest other) (declare (ignore v1)) (let ((d (length v2)) - (start2 (or (cadr (member :start2 other)) 0))) + (start2 (or (cadr (member :start2 other)) 0))) `(integer ,start2 ,d))) @@ -530,9 +530,9 @@ use the value in MEMBER or EQL type specifiers.")) (defmacro replicate-with ((source-obj dest-obj copy-form) &body body) `(or (gethash ,source-obj *replicate-table*) (let ((,dest-obj ,copy-form)) - (setf (gethash ,source-obj *replicate-table*) ,dest-obj) - ,@body - ,dest-obj))) + (setf (gethash ,source-obj *replicate-table*) ,dest-obj) + ,@body + ,dest-obj))) (declaim (special *replicate-table*)) @@ -546,10 +546,10 @@ use the value in MEMBER or EQL type specifiers.")) (defmethod replicate ((obj cons)) (or (gethash obj *replicate-table*) (let ((x (cons nil nil))) - (setf (gethash obj *replicate-table*) x) - (setf (car x) (replicate (car obj))) - (setf (cdr x) (replicate (cdr obj))) - x))) + (setf (gethash obj *replicate-table*) x) + (setf (car x) (replicate (car obj))) + (setf (cdr x) (replicate (cdr obj))) + x))) ;;; Default method for objects without internal structure (defmethod replicate ((obj t)) obj) @@ -560,8 +560,8 @@ use the value in MEMBER or EQL type specifiers.")) (replicate-displaced-array obj) (when new-leaf (loop for i below (array-total-size new-leaf) - do (setf (row-major-aref new-leaf i) - (row-major-aref old-leaf i)))) + do (setf (row-major-aref new-leaf i) + (row-major-aref old-leaf i)))) new-obj)) (defun replicate-displaced-array (obj) @@ -571,33 +571,33 @@ use the value in MEMBER or EQL type specifiers.")) two are NIL if the leaf did not have to be copied again." (or (gethash obj *replicate-table*) (multiple-value-bind - (displaced-to displaced-index-offset) - (array-displacement obj) - (let ((dims (array-dimensions obj)) - (element-type (array-element-type obj)) - (fill-pointer (and (array-has-fill-pointer-p obj) - (fill-pointer obj))) - (adj (adjustable-array-p obj))) - (if displaced-to - ;; The array is displaced - ;; Copy recursively - (multiple-value-bind - (new-displaced-to old-leaf new-leaf) - (replicate-displaced-array displaced-to) - (let ((new-obj (make-array dims :element-type element-type - :fill-pointer fill-pointer - :adjustable adj - :displaced-to new-displaced-to - :displaced-index-offset displaced-index-offset))) - (setf (gethash obj *replicate-table*) new-obj) - (values new-obj old-leaf new-leaf))) - ;; The array is not displaced - ;; This is the leaf array - (let ((new-obj (make-array dims :element-type element-type - :fill-pointer fill-pointer - :adjustable adj))) - (setf (gethash obj *replicate-table*) new-obj) - (values new-obj obj new-obj))))))) + (displaced-to displaced-index-offset) + (array-displacement obj) + (let ((dims (array-dimensions obj)) + (element-type (array-element-type obj)) + (fill-pointer (and (array-has-fill-pointer-p obj) + (fill-pointer obj))) + (adj (adjustable-array-p obj))) + (if displaced-to + ;; The array is displaced + ;; Copy recursively + (multiple-value-bind + (new-displaced-to old-leaf new-leaf) + (replicate-displaced-array displaced-to) + (let ((new-obj (make-array dims :element-type element-type + :fill-pointer fill-pointer + :adjustable adj + :displaced-to new-displaced-to + :displaced-index-offset displaced-index-offset))) + (setf (gethash obj *replicate-table*) new-obj) + (values new-obj old-leaf new-leaf))) + ;; The array is not displaced + ;; This is the leaf array + (let ((new-obj (make-array dims :element-type element-type + :fill-pointer fill-pointer + :adjustable adj))) + (setf (gethash obj *replicate-table*) new-obj) + (values new-obj obj new-obj))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -627,7 +627,7 @@ use the value in MEMBER or EQL type specifiers.")) (t (setf (gethash obj1 *isomorphism-table*) obj2) (and (isomorphic-p* (car obj1) (car obj2)) - (isomorphic-p* (cdr obj1) (cdr obj2))))))) + (isomorphic-p* (cdr obj1) (cdr obj2))))))) (defmethod isomorphic-p* ((obj1 array) (obj2 array)) (let ((previous (gethash obj1 *isomorphism-table*))) @@ -639,23 +639,23 @@ use the value in MEMBER or EQL type specifiers.")) (t (setf (gethash obj1 *isomorphism-table*) obj2) (and (equal (array-dimensions obj1) (array-dimensions obj2)) - (equal (array-element-type obj1) (array-element-type obj2)) - (if (array-has-fill-pointer-p obj1) - (and (array-has-fill-pointer-p obj2) - (eql (fill-pointer obj1) (fill-pointer obj2))) - (not (array-has-fill-pointer-p obj2))) - (let (to-1 (index-1 0) to-2 (index-2 0)) - (multiple-value-setq (to-1 index-1) (array-displacement obj1)) - (multiple-value-setq (to-2 index-2) (array-displacement obj2)) - (if to-1 - (and to-2 - (eql index-1 index-2) - (isomorphic-p* to-1 to-2)) - ;; Not displaced -- recurse on elements - (let ((total-size (array-total-size obj1))) - (loop for i below total-size - always (isomorphic-p* (row-major-aref obj1 i) - (row-major-aref obj2 i))))))))))) + (equal (array-element-type obj1) (array-element-type obj2)) + (if (array-has-fill-pointer-p obj1) + (and (array-has-fill-pointer-p obj2) + (eql (fill-pointer obj1) (fill-pointer obj2))) + (not (array-has-fill-pointer-p obj2))) + (let (to-1 (index-1 0) to-2 (index-2 0)) + (multiple-value-setq (to-1 index-1) (array-displacement obj1)) + (multiple-value-setq (to-2 index-2) (array-displacement obj2)) + (if to-1 + (and to-2 + (eql index-1 index-2) + (isomorphic-p* to-1 to-2)) + ;; Not displaced -- recurse on elements + (let ((total-size (array-total-size obj1))) + (loop for i below total-size + always (isomorphic-p* (row-major-aref obj1 i) + (row-major-aref obj2 i))))))))))) ;;; Test that sequences have identical elements diff --git a/ansi-tests/random-types.lsp b/ansi-tests/random-types.lsp index d8f25e84..fa9b061d 100644 --- a/ansi-tests/random-types.lsp +++ b/ansi-tests/random-types.lsp @@ -17,28 +17,28 @@ (1 nil) (1 t) (1 `(eql ,(let ((r (ash 1 (random 45)))) - (random-from-interval r (- r))))) + (random-from-interval r (- r))))) (1 (random-from-seq #(integer unsigned-byte ratio rational real float - short-float single-float double-float - long-float complex symbol cons function))) + short-float single-float double-float + long-float complex symbol cons function))) (1 - (let* ((len (random *maximum-random-int-bits*)) - (r1 (ash 1 len)) - (r2 (+ r1 r1)) - (x (- (random r2) r1)) - (y (- (random r2) r1)) - (lo (min x y)) - (hi (max x y))) - `(integer ,lo ,hi))) + (let* ((len (random *maximum-random-int-bits*)) + (r1 (ash 1 len)) + (r2 (+ r1 r1)) + (x (- (random r2) r1)) + (y (- (random r2) r1)) + (lo (min x y)) + (hi (max x y))) + `(integer ,lo ,hi))) (1 (make-random-real-type)) ;; (1 (make-random-complex-type)) ) (rcase (2 (let* ((op (random-from-seq #(cons cons and or))) - (nargs (if (eq op 'cons) 2 - (1+ (random (min size 4))))) - (sizes (random-partition (1- size) nargs))) - `(,op ,@(mapcar #'make-random-type sizes)))) + (nargs (if (eq op 'cons) 2 + (1+ (random (min size 4))))) + (sizes (random-partition (1- size) nargs))) + `(,op ,@(mapcar #'make-random-type sizes)))) (1 `(not ,(make-random-type (1- size)))) ; (1 (make-random-function-type size)) ))) @@ -46,17 +46,17 @@ (defun make-random-real-type () (rcase (1 (random-from-seq '(integer unsigned-byte short-float single-float - double-float long-float rational real))) + double-float long-float rational real))) (1 (destructuring-bind (lo hi) - (make-random-integer-range) - (rcase - (4 `(integer ,lo ,hi)) - (1 `(integer ,lo)) - (1 `(integer ,lo *)) - (2 `(integer * ,hi))))) + (make-random-integer-range) + (rcase + (4 `(integer ,lo ,hi)) + (1 `(integer ,lo)) + (1 `(integer ,lo *)) + (2 `(integer * ,hi))))) (1 (let ((r1 (random-real)) - (r2 (random-real))) - `(real ,(min r1 r2) ,(max r2 r2)))) + (r2 (random-real))) + `(real ,(min r1 r2) ,(max r2 r2)))) ;;; Add more cases here )) @@ -65,137 +65,137 @@ (defun make-random-function-type (size) (let* ((sizes (random-partition (1- size) 2)) - (types (mapcar #'make-random-type sizes))) + (types (mapcar #'make-random-type sizes))) `(function (,(car types)) ,(cadr types)))) (defun size-of-type (type) (if (consp type) (case (car type) - (complex (1+ (size-of-type (cadr type)))) - ((array simple-array) (1+ (size-of-type (cadr type)))) - (vector (1+ (size-of-type (cadr type)))) - (complex (1+ (size-of-type (cadr type)))) - ((cons or and not) (reduce #'+ (cdr type) :initial-value 1 - :key #'size-of-type)) - (t 1)) + (complex (1+ (size-of-type (cadr type)))) + ((array simple-array) (1+ (size-of-type (cadr type)))) + (vector (1+ (size-of-type (cadr type)))) + (complex (1+ (size-of-type (cadr type)))) + ((cons or and not) (reduce #'+ (cdr type) :initial-value 1 + :key #'size-of-type)) + (t 1)) 1)) (defun mutate-type (type) (let* ((size (size-of-type type)) - (r (random size))) + (r (random size))) (flet ((%f () - (rcase - (6 (make-random-type (random (1+ size)))) - (2 `(not ,type)) - (1 `(and ,(make-random-type 1) ,type)) - (1 `(and ,type ,(make-random-type 1))) - (1 `(or ,(make-random-type 1) ,type)) - (1 `(or ,type ,(make-random-type 1))))) - (%random-int () - (let ((bits (1+ (min (random 20) (random 20))))) - (- (ash 1 bits) (random (ash 1 (1+ bits))))))) + (rcase + (6 (make-random-type (random (1+ size)))) + (2 `(not ,type)) + (1 `(and ,(make-random-type 1) ,type)) + (1 `(and ,type ,(make-random-type 1))) + (1 `(or ,(make-random-type 1) ,type)) + (1 `(or ,type ,(make-random-type 1))))) + (%random-int () + (let ((bits (1+ (min (random 20) (random 20))))) + (- (ash 1 bits) (random (ash 1 (1+ bits))))))) (if (or (and (= r 0) (coin)) (not (consp type))) - (%f) - (case (car type) - ((and or not cons complex) - (let ((sizes (mapcar #'size-of-type (cdr type)))) - (loop with sum = 0 - for e on sizes - for ctype in (cdr type) - for i from 0 - do (setf sum (incf (car e) sum)) - when (>= sum r) - return (rcase - (1 ctype) ;; replace with component type - (1 (cons (car type) - (append (subseq (cdr type) 0 i) - (list (mutate-type ctype)) - (subseq (cdr type) (1+ i))))))))) - ((array simple-array vector) - (let ((ctype (if (cdr type) (cadr type) t))) - (rcase - (1 (if (eql ctype *) t ctype)) - (1 (cons (car type) - (cons (mutate-type ctype) - (cddr type))))))) - ((unsigned-byte) - (if (integerp (cadr type)) - (rcase - (1 'unsigned-byte) - (1 `(unsigned-byte (+ (cadr type) (- 10 (random 20)))))) - (%f))) + (%f) + (case (car type) + ((and or not cons complex) + (let ((sizes (mapcar #'size-of-type (cdr type)))) + (loop with sum = 0 + for e on sizes + for ctype in (cdr type) + for i from 0 + do (setf sum (incf (car e) sum)) + when (>= sum r) + return (rcase + (1 ctype) ;; replace with component type + (1 (cons (car type) + (append (subseq (cdr type) 0 i) + (list (mutate-type ctype)) + (subseq (cdr type) (1+ i))))))))) + ((array simple-array vector) + (let ((ctype (if (cdr type) (cadr type) t))) + (rcase + (1 (if (eql ctype *) t ctype)) + (1 (cons (car type) + (cons (mutate-type ctype) + (cddr type))))))) + ((unsigned-byte) + (if (integerp (cadr type)) + (rcase + (1 'unsigned-byte) + (1 `(unsigned-byte (+ (cadr type) (- 10 (random 20)))))) + (%f))) - ((integer) - (let ((lo-delta (%random-int)) - (hi-delta (%random-int)) - (old-lo (or (cadr type) '*)) - (old-hi (or (caddr type) '*))) - (flet ((%inc (old delta) - (if (or (coin) (not (integerp old))) - delta - (+ old delta)))) - (rcase - (1 `(integer ,old-lo *)) - (1 `(integer * ,old-hi)) - (1 (let ((new-lo (%inc old-lo lo-delta))) - (if (or (null (cdr type)) - (null (cddr type)) - (not (integerp old-hi))) - `(integer ,new-lo ,@(cddr type)) - ;; caddr is integer - (if (<= new-lo old-hi) - `(integer ,new-lo ,old-hi) - `(integer ,old-hi ,new-lo))))) - (1 (let ((new-hi (%inc old-hi hi-delta))) - (if (or (null (cdr type)) - (null (cddr type)) - (not (integerp old-lo))) - `(integer ,old-lo ,new-hi) - (if (<= old-lo new-hi) - `(integer ,old-lo ,new-hi) - `(integer ,new-hi ,old-lo))))) - (1 (let ((new-lo (%inc old-lo lo-delta)) - (new-hi (%inc old-hi hi-delta))) - (if (<= new-lo new-hi) - `(integer ,new-lo ,new-hi) - `(integer ,new-hi ,new-lo)))))))) - - (t (%f))))))) + ((integer) + (let ((lo-delta (%random-int)) + (hi-delta (%random-int)) + (old-lo (or (cadr type) '*)) + (old-hi (or (caddr type) '*))) + (flet ((%inc (old delta) + (if (or (coin) (not (integerp old))) + delta + (+ old delta)))) + (rcase + (1 `(integer ,old-lo *)) + (1 `(integer * ,old-hi)) + (1 (let ((new-lo (%inc old-lo lo-delta))) + (if (or (null (cdr type)) + (null (cddr type)) + (not (integerp old-hi))) + `(integer ,new-lo ,@(cddr type)) + ;; caddr is integer + (if (<= new-lo old-hi) + `(integer ,new-lo ,old-hi) + `(integer ,old-hi ,new-lo))))) + (1 (let ((new-hi (%inc old-hi hi-delta))) + (if (or (null (cdr type)) + (null (cddr type)) + (not (integerp old-lo))) + `(integer ,old-lo ,new-hi) + (if (<= old-lo new-hi) + `(integer ,old-lo ,new-hi) + `(integer ,new-hi ,old-lo))))) + (1 (let ((new-lo (%inc old-lo lo-delta)) + (new-hi (%inc old-hi hi-delta))) + (if (<= new-lo new-hi) + `(integer ,new-lo ,new-hi) + `(integer ,new-hi ,new-lo)))))))) + + (t (%f))))))) (defun test-random-types (n size) (loop for t1 = (make-random-type size) - for t2 = (make-random-type size) - for i from 0 below n - ;; do (print (list t1 t2)) + for t2 = (make-random-type size) + for i from 0 below n + ;; do (print (list t1 t2)) do (setf *random-types* (list t1 t2)) - do (when (and (= (mod i 100) 0) (> i 0)) - (format t "~A " i) (finish-output *standard-output*)) - when (test-types t1 t2) - collect (list t1 t2) - finally (terpri))) + do (when (and (= (mod i 100) 0) (> i 0)) + (format t "~A " i) (finish-output *standard-output*)) + when (test-types t1 t2) + collect (list t1 t2) + finally (terpri))) (defun test-random-mutated-types (n size &key (reps 1)) (loop for t1 = (make-random-type size) - for t2 = (let ((x t1)) (loop repeat reps - do (setq x (mutate-type x))) x) - for i from 0 below n - ;; do (print (list t1 t2)) + for t2 = (let ((x t1)) (loop repeat reps + do (setq x (mutate-type x))) x) + for i from 0 below n + ;; do (print (list t1 t2)) do (setf *random-types* (list t1 t2)) - do (when (and (= (mod i 100) 0) (> i 0)) - (format t "~A " i) (finish-output *standard-output*)) - when (test-types t1 t2) - collect (list t1 t2) - finally (terpri))) + do (when (and (= (mod i 100) 0) (> i 0)) + (format t "~A " i) (finish-output *standard-output*)) + when (test-types t1 t2) + collect (list t1 t2) + finally (terpri))) (defun test-types (t1 t2) (multiple-value-bind (sub success) (subtypep t1 t2) (when success (if sub - (check-all-subtypep t1 t2) - (let ((nt1 `(not ,t1)) - (nt2 `(not ,t2))) - (subtypep nt2 nt1)))))) + (check-all-subtypep t1 t2) + (let ((nt1 `(not ,t1)) + (nt2 `(not ,t2))) + (subtypep nt2 nt1)))))) (defun prune-type (tp try-fn) (declare (type function try-fn)) @@ -209,93 +209,93 @@ (try nil) (try t) (let ((op (first tp)) - (args (rest tp))) - (case op - ((cons) - (try 'cons) - (prune-list args - #'prune-type - #'(lambda (args) (try `(cons ,@args))))) - ((integer) - (try op) - (try '(eql 0)) - (when (= (length args) 2) - (let ((arg1 (first args)) - (arg2 (second args))) - (when (and (integerp arg1) (integerp arg2)) - (try `(eql ,arg1)) - (try `(eql ,arg2)) - (when (and (< arg1 0) (<= 0 arg2)) - (try `(integer 0 ,arg2))) - (when (and (<= arg1 0) (< 0 arg2)) - (try `(integer ,arg1 0))) - (when (> (- arg2 arg1) 1) - (try `(integer ,(+ arg1 (floor (- arg2 arg1) 2)) ,arg2)) - (try `(integer ,arg1 ,(- arg2 (floor (- arg2 arg1) 2))))))))) - - ((real float ratio single-float double-float short-float long-float) - (try op)) - - ((or and) - (mapc try-fn args) - (loop for i from 0 below (length args) - do (try `(,op ,@(subseq args 0 i) - ,@(subseq args (1+ i))))) - (prune-list args - #'prune-type - #'(lambda (args) (try (cons op args))))) - ((not) - (let ((arg (first args))) - (try arg) - (when (and (consp arg) - (eq (car arg) 'not)) - (try (second arg))) - (prune-type arg #'(lambda (arg) (try `(not ,arg)))))) - - ((member) - (dolist (arg (cdr tp)) - (try `(eql ,arg))) - (when (cddr tp) - (try `(member ,@(cddr tp))))) + (args (rest tp))) + (case op + ((cons) + (try 'cons) + (prune-list args + #'prune-type + #'(lambda (args) (try `(cons ,@args))))) + ((integer) + (try op) + (try '(eql 0)) + (when (= (length args) 2) + (let ((arg1 (first args)) + (arg2 (second args))) + (when (and (integerp arg1) (integerp arg2)) + (try `(eql ,arg1)) + (try `(eql ,arg2)) + (when (and (< arg1 0) (<= 0 arg2)) + (try `(integer 0 ,arg2))) + (when (and (<= arg1 0) (< 0 arg2)) + (try `(integer ,arg1 0))) + (when (> (- arg2 arg1) 1) + (try `(integer ,(+ arg1 (floor (- arg2 arg1) 2)) ,arg2)) + (try `(integer ,arg1 ,(- arg2 (floor (- arg2 arg1) 2))))))))) + + ((real float ratio single-float double-float short-float long-float) + (try op)) + + ((or and) + (mapc try-fn args) + (loop for i from 0 below (length args) + do (try `(,op ,@(subseq args 0 i) + ,@(subseq args (1+ i))))) + (prune-list args + #'prune-type + #'(lambda (args) (try (cons op args))))) + ((not) + (let ((arg (first args))) + (try arg) + (when (and (consp arg) + (eq (car arg) 'not)) + (try (second arg))) + (prune-type arg #'(lambda (arg) (try `(not ,arg)))))) - ((eql) - (assert (= (length args) 1)) - (let ((arg (first args))) - (unless (= arg 0) - (try `(eql 0)) - (cond - ((< arg -1) - (try `(eql ,(ceiling arg 2)))) - ((> arg 1) - (try `(eql ,(floor arg 2)))))))) - - ))))) + ((member) + (dolist (arg (cdr tp)) + (try `(eql ,arg))) + (when (cddr tp) + (try `(member ,@(cddr tp))))) + + ((eql) + (assert (= (length args) 1)) + (let ((arg (first args))) + (unless (= arg 0) + (try `(eql 0)) + (cond + ((< arg -1) + (try `(eql ,(ceiling arg 2)))) + ((> arg 1) + (try `(eql ,(floor arg 2)))))))) + + ))))) (values)) (defun prune-type-pair (pair &optional (fn #'test-types)) (declare (type function fn)) (let ((t1 (first pair)) - (t2 (second pair)) - changed) + (t2 (second pair)) + changed) (loop do (flet ((%try2 (new-tp) - (when (funcall fn t1 new-tp) - (print "Success in first loop") - (print new-tp) - (setq t2 new-tp - changed t) - (throw 'success nil)))) - (catch 'success - (prune-type t2 #'%try2))) + (when (funcall fn t1 new-tp) + (print "Success in first loop") + (print new-tp) + (setq t2 new-tp + changed t) + (throw 'success nil)))) + (catch 'success + (prune-type t2 #'%try2))) do (flet ((%try1 (new-tp) - (when (funcall fn new-tp t2) - (print "Success in second loop") - (print new-tp) - (setq t1 new-tp - changed t) - (throw 'success nil)))) - (catch 'success - (prune-type t1 #'%try1))) + (when (funcall fn new-tp t2) + (print "Success in second loop") + (print new-tp) + (setq t1 new-tp + changed t) + (throw 'success nil)))) + (catch 'success + (prune-type t1 #'%try1))) while changed do (setq changed nil)) (list t1 t2))) @@ -304,66 +304,66 @@ ;; Returns non-nil if a problem is found (catch 'problem (multiple-value-bind (sub1 success1) - (subtypep t1 t2) + (subtypep t1 t2) (when success1 - (if sub1 - (append - (check-all-subtypep t1 `(or ,t2 ,t3)) - (check-all-subtypep `(and ,t1 ,t3) t2)) - (or (subtypep `(or ,t1 ,t3) t2) - (subtypep t1 `(and ,t2 ,t3)))))))) + (if sub1 + (append + (check-all-subtypep t1 `(or ,t2 ,t3)) + (check-all-subtypep `(and ,t1 ,t3) t2)) + (or (subtypep `(or ,t1 ,t3) t2) + (subtypep t1 `(and ,t2 ,t3)))))))) (defun test-random-types3 (n size) (loop for t1 = (make-random-type (1+ (random size))) - for t2 = (make-random-type (1+ (random size))) - for t3 = (make-random-type (1+ (random size))) - for i from 1 to n - ;; do (print (list t1 t2)) + for t2 = (make-random-type (1+ (random size))) + for t3 = (make-random-type (1+ (random size))) + for i from 1 to n + ;; do (print (list t1 t2)) do (setf *random-types* (list t1 t2 t3)) - do (when (and (= (mod i 100) 0) (> i 0)) - (format t "~A " i) (finish-output *standard-output*)) - when (test-type-triple t1 t2 t3) - collect (list t1 t2 t3) - finally (terpri))) + do (when (and (= (mod i 100) 0) (> i 0)) + (format t "~A " i) (finish-output *standard-output*)) + when (test-type-triple t1 t2 t3) + collect (list t1 t2 t3) + finally (terpri))) (defun prune-type-triple (pair &optional (fn #'test-type-triple)) (declare (type function fn)) (let ((t1 (first pair)) - (t2 (second pair)) - (t3 (third pair)) - changed) + (t2 (second pair)) + (t3 (third pair)) + changed) (loop do (flet ((%try2 (new-tp) - (when (funcall fn t1 new-tp t3) - (print "Success in first loop") - (print new-tp) - (setq t2 new-tp - changed t) - (throw 'success nil)))) - (catch 'success - (prune-type t2 #'%try2))) + (when (funcall fn t1 new-tp t3) + (print "Success in first loop") + (print new-tp) + (setq t2 new-tp + changed t) + (throw 'success nil)))) + (catch 'success + (prune-type t2 #'%try2))) do (flet ((%try1 (new-tp) - (when (funcall fn new-tp t2 t3) - (print "Success in second loop") - (print new-tp) - (setq t1 new-tp - changed t) - (throw 'success nil)))) - (catch 'success - (prune-type t1 #'%try1))) + (when (funcall fn new-tp t2 t3) + (print "Success in second loop") + (print new-tp) + (setq t1 new-tp + changed t) + (throw 'success nil)))) + (catch 'success + (prune-type t1 #'%try1))) do (flet ((%try3 (new-tp) - (when (funcall fn t1 t2 new-tp) - (print "Success in second loop") - (print new-tp) - (setq t3 new-tp - changed t) - (throw 'success nil)))) - (catch 'success - (prune-type t3 #'%try3))) + (when (funcall fn t1 t2 new-tp) + (print "Success in second loop") + (print new-tp) + (setq t3 new-tp + changed t) + (throw 'success nil)))) + (catch 'success + (prune-type t3 #'%try3))) while changed do (setq changed nil)) (list t1 t2 t3))) - \ No newline at end of file + diff --git a/ansi-tests/random.lsp b/ansi-tests/random.lsp index 0496a359..2f5df06e 100644 --- a/ansi-tests/random.lsp +++ b/ansi-tests/random.lsp @@ -22,72 +22,72 @@ (deftest random.1 (loop for i from 2 to 30 - for n = (ash 1 i) - nconc - (loop for j = (1+ (random n)) - repeat 20 - nconc - (loop for r = (random j) - repeat i - unless (and (integerp r) - (<= 0 r) - (< r j)) - collect (list j r)))) + for n = (ash 1 i) + nconc + (loop for j = (1+ (random n)) + repeat 20 + nconc + (loop for r = (random j) + repeat i + unless (and (integerp r) + (<= 0 r) + (< r j)) + collect (list j r)))) nil) (deftest random.2 (loop for i from 2 to 20 - for n = (ash 1 i) - nconc - (loop for j = (random (float n)) - repeat 20 - unless (zerop j) - nconc - (loop for r = (random j) - repeat 20 - unless (and (eql (float r j) r) - (<= 0 r) - (< r j)) - collect (list j r)))) + for n = (ash 1 i) + nconc + (loop for j = (random (float n)) + repeat 20 + unless (zerop j) + nconc + (loop for r = (random j) + repeat 20 + unless (and (eql (float r j) r) + (<= 0 r) + (< r j)) + collect (list j r)))) nil) (deftest random.3 (binomial-distribution-test 10000 - #'(lambda () (eql (random 2) 0))) + #'(lambda () (eql (random 2) 0))) t) (deftest random.4 (binomial-distribution-test 10000 - #'(lambda () (< (random 1.0s0) 0.5s0))) + #'(lambda () (< (random 1.0s0) 0.5s0))) t) (deftest random.5 (binomial-distribution-test 10000 - #'(lambda () (< (random 1.0d0) 0.5d0))) + #'(lambda () (< (random 1.0d0) 0.5d0))) t) (deftest random.6 (binomial-distribution-test 10000 - #'(lambda () (evenp (random 1024)))) + #'(lambda () (evenp (random 1024)))) t) (deftest random.7 (loop for x in '(10.0s0 20.0f0 30.0d0 40.0l0) - for r = (random x) - unless (eql (float r x) r) - collect (list x r)) + for r = (random x) + unless (eql (float r x) r) + collect (list x r)) nil) (deftest random.8 (let* ((f1 '(lambda (x) (random (if x 10 20)))) - (f2 (compile nil f1))) + (f2 (compile nil f1))) (values (loop repeat 100 always (<= 0 (funcall f2 t) 9)) (loop repeat 100 always (<= 0 (funcall f2 nil) 19)))) t t) - + ;;; Do more statistical tests here - \ No newline at end of file + diff --git a/ansi-tests/rassoc-if-not.lsp b/ansi-tests/rassoc-if-not.lsp index 72cd1da9..87266375 100644 --- a/ansi-tests/rassoc-if-not.lsp +++ b/ansi-tests/rassoc-if-not.lsp @@ -9,8 +9,8 @@ (deftest rassoc-if-not.1 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if-not #'oddp x))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) @@ -19,8 +19,8 @@ (deftest rassoc-if-not.2 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if-not #'evenp x :key #'1+))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if-not #'evenp x :key #'1+))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) @@ -29,8 +29,8 @@ (deftest rassoc-if-not.3 (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if-not #'oddp x))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if-not #'oddp x))) (and (check-scaffold-copy x xcopy) (eqt result (fourth x)) @@ -38,8 +38,8 @@ (c . 6)) (deftest rassoc-if-not.4 - (rassoc-if-not #'identity - (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) + (rassoc-if-not #'identity + (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) (e)) ;;; Order of argument evaluation @@ -48,8 +48,8 @@ (let ((i 0) x y) (values (rassoc-if-not (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) - '((1 . a) (2 . b) (17) (4 . d)))) + (progn (setf y (incf i)) + '((1 . a) (2 . b) (17) (4 . d)))) i x y)) (17) 2 1 2) @@ -57,9 +57,9 @@ (let ((i 0) x y z) (values (rassoc-if-not (progn (setf x (incf i)) #'identity) - (progn (setf y (incf i)) - '((1 . a) (2 . b) (17) (4 . d))) - :key (progn (setf z (incf i)) #'null)) + (progn (setf y (incf i)) + '((1 . a) (2 . b) (17) (4 . d))) + :key (progn (setf z (incf i)) #'null)) i x y z)) (1 . a) 3 1 2 3) @@ -75,7 +75,7 @@ (deftest rassoc-if-not.allow-other-keys.3 (rassoc-if-not #'not '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t - :key 'not) + :key 'not) (2)) (deftest rassoc-if-not.allow-other-keys.4 @@ -88,7 +88,7 @@ (deftest rassoc-if-not.allow-other-keys.6 (rassoc-if-not #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t - :allow-other-keys nil :bad t) + :allow-other-keys nil :bad t) (2)) (deftest rassoc-if-not.keywords.7 diff --git a/ansi-tests/rassoc-if.lsp b/ansi-tests/rassoc-if.lsp index 1a25e22b..9a854ee2 100644 --- a/ansi-tests/rassoc-if.lsp +++ b/ansi-tests/rassoc-if.lsp @@ -9,8 +9,8 @@ (deftest rassoc-if.1 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if #'evenp x))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) @@ -19,8 +19,8 @@ (deftest rassoc-if.2 (let* ((x (rev-assoc-list '((1 . a) (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if #'oddp x :key #'1+))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if #'oddp x :key #'1+))) (and (check-scaffold-copy x xcopy) (eqt result (third x)) @@ -29,8 +29,8 @@ (deftest rassoc-if.3 (let* ((x (rev-assoc-list '((1 . a) nil (3 . b) (6 . c) (7 . d)))) - (xcopy (make-scaffold-copy x)) - (result (rassoc-if #'evenp x))) + (xcopy (make-scaffold-copy x)) + (result (rassoc-if #'evenp x))) (and (check-scaffold-copy x xcopy) (eqt result (fourth x)) @@ -39,7 +39,7 @@ (deftest rassoc-if.4 (rassoc-if #'null - (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) + (rev-assoc-list '((a . b) nil (c . d) (nil . e) (f . g)))) (e)) ;;; Order of argument evaluation @@ -48,8 +48,8 @@ (let ((i 0) x y) (values (rassoc-if (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) - '((1 . a) (2 . b) (17) (4 . d)))) + (progn (setf y (incf i)) + '((1 . a) (2 . b) (17) (4 . d)))) i x y)) (17) 2 1 2) @@ -57,9 +57,9 @@ (let ((i 0) x y z) (values (rassoc-if (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) - '((1 . a) (2 . b) (17) (4 . d))) - :key (progn (setf z (incf i)) #'null)) + (progn (setf y (incf i)) + '((1 . a) (2 . b) (17) (4 . d))) + :key (progn (setf z (incf i)) #'null)) i x y z)) (1 . a) 3 1 2 3) @@ -76,7 +76,7 @@ (deftest rassoc-if.allow-other-keys.3 (rassoc-if #'identity '((1 . a) (2) (3 . c)) :allow-other-keys t :bad t - :key 'not) + :key 'not) (2)) (deftest rassoc-if.allow-other-keys.4 diff --git a/ansi-tests/rassoc.lsp b/ansi-tests/rassoc.lsp index 30280838..9b066414 100644 --- a/ansi-tests/rassoc.lsp +++ b/ansi-tests/rassoc.lsp @@ -33,8 +33,8 @@ (deftest rassoc.7 (let* ((x (copy-tree (rev-assoc-list '((a . b) (b . c) (c . d))))) - (xcopy (make-scaffold-copy x)) - (result (rassoc 'b x))) + (xcopy (make-scaffold-copy x)) + (result (rassoc 'b x))) (and (eqt result (second x)) (check-scaffold-copy x xcopy))) @@ -46,117 +46,117 @@ (deftest rassoc.9 (rassoc (copy-seq "abc") - (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) + (rev-assoc-list '((abc . 1) ("abc" . 2) ("abc" . 3)))) nil) (deftest rassoc.10 (rassoc (copy-list '(a)) - (copy-tree (rev-assoc-list '(((a) b) ((a) (c)))))) + (copy-tree (rev-assoc-list '(((a) b) ((a) (c)))))) nil) (deftest rassoc.11 (let ((x (list 'a 'b))) (rassoc x - (rev-assoc-list `(((a b) c) (,x . d) (,x . e) ((a b) 1))))) + (rev-assoc-list `(((a b) c) (,x . d) (,x . e) ((a b) 1))))) (d a b)) (deftest rassoc.12 (rassoc #\e - (copy-tree - (rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)))) - :key #'(lambda (x) (schar x 1))) + (copy-tree + (rev-assoc-list '(("abefd" . 1) ("aevgd" . 2) ("edada" . 3)))) + :key #'(lambda (x) (schar x 1))) (2 . "aevgd")) (deftest rassoc.13 (rassoc nil - (copy-tree - (rev-assoc-list - '(((a) . b) ( nil . c ) ((nil) . d)))) - :key #'car) + (copy-tree + (rev-assoc-list + '(((a) . b) ( nil . c ) ((nil) . d)))) + :key #'car) (c)) (deftest rassoc.14 (rassoc (copy-seq "abc") - (copy-tree - (rev-assoc-list - '((abc . 1) ("abc" . 2) ("abc" . 3)))) - :test #'equal) + (copy-tree + (rev-assoc-list + '((abc . 1) ("abc" . 2) ("abc" . 3)))) + :test #'equal) (2 . "abc")) (deftest rassoc.15 (rassoc (copy-seq "abc") - (copy-tree - (rev-assoc-list - '((abc . 1) ("abc" . 2) ("abc" . 3)))) - :test #'equalp) + (copy-tree + (rev-assoc-list + '((abc . 1) ("abc" . 2) ("abc" . 3)))) + :test #'equalp) (2 . "abc")) (deftest rassoc.16 (rassoc (copy-list '(a)) - (copy-tree - (rev-assoc-list '(((a) b) ((a) (c))))) - :test #'equal) + (copy-tree + (rev-assoc-list '(((a) b) ((a) (c))))) + :test #'equal) ((b) a)) (deftest rassoc.17 (rassoc (copy-seq "abc") - (copy-tree - (rev-assoc-list - '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)))) - :test-not (complement #'equalp)) + (copy-tree + (rev-assoc-list + '((abc . 1) (a . a) (b . b) ("abc" . 2) ("abc" . 3)))) + :test-not (complement #'equalp)) (2 . "abc")) (deftest rassoc.18 - (rassoc 'a - (copy-tree - (rev-assoc-list - '((a . d)(b . c)))) - :test-not #'eq) + (rassoc 'a + (copy-tree + (rev-assoc-list + '((a . d)(b . c)))) + :test-not #'eq) (c . b)) (deftest rassoc.19 (rassoc 'a - (copy-tree - (rev-assoc-list - '((a . d)(b . c)))) - :test (complement #'eq)) + (copy-tree + (rev-assoc-list + '((a . d)(b . c)))) + :test (complement #'eq)) (c . b)) (deftest rassoc.20 (rassoc "a" - (copy-tree - (rev-assoc-list - '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) - :key #'(lambda (x) (and (stringp x) (string-downcase x))) - :test #'equal) + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test #'equal) (6 . "A")) (deftest rassoc.21 (rassoc "a" - (copy-tree - (rev-assoc-list - '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) - :key #'(lambda (x) (and (stringp x) x)) - :test #'equal) + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) x)) + :test #'equal) (3 . "a")) (deftest rassoc.22 (rassoc "a" - (copy-tree - (rev-assoc-list - '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) - :key #'(lambda (x) (and (stringp x) (string-downcase x))) - :test-not (complement #'equal)) + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) (string-downcase x))) + :test-not (complement #'equal)) (6 . "A")) (deftest rassoc.23 (rassoc "a" - (copy-tree - (rev-assoc-list - '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) - :key #'(lambda (x) (and (stringp x) x)) - :test-not (complement #'equal)) + (copy-tree + (rev-assoc-list + '(("" . 1) (a . 2) ("A" . 6) ("a" . 3) ("A" . 5)))) + :key #'(lambda (x) (and (stringp x) x)) + :test-not (complement #'equal)) (3 . "a")) ;; Check that it works when test returns a true value @@ -164,10 +164,10 @@ (deftest rassoc.24 (rassoc 'a - (copy-tree - (rev-assoc-list - '((b . 1) (a . 2) (c . 3)))) - :test #'(lambda (x y) (and (eqt x y) 'matched))) + (copy-tree + (rev-assoc-list + '((b . 1) (a . 2) (c . 3)))) + :test #'(lambda (x y) (and (eqt x y) 'matched))) (2 . a)) ;; Check that the order of the arguments to :test is correct @@ -175,19 +175,19 @@ (deftest rassoc.25 (block fail (rassoc 'a '((1 . b) (2 . c) (3 . a)) - :test #'(lambda (x y) - (unless (eqt x 'a) (return-from fail 'fail)) - (eqt x y)))) + :test #'(lambda (x y) + (unless (eqt x 'a) (return-from fail 'fail)) + (eqt x y)))) (3 . a)) (deftest rassoc.26 (rassoc 10 '((a . 1) (b . 5) (c . 10) (d . 15) (e . 40)) - :test #'<) + :test #'<) (d . 15)) (deftest rassoc.27 (rassoc 10 '((a . 1) (b . 5) (c . 10) (d . 15) (e . 40)) - :test-not #'>=) + :test-not #'>=) (d . 15)) (defharmless rassoc.test-and-test-not.1 @@ -202,7 +202,7 @@ (let ((i 0) x y) (values (rassoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c)))) + (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c)))) i x y)) (3 . c) 2 1 2) @@ -210,8 +210,8 @@ (let ((i 0) x y z) (values (rassoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) - :test (progn (setf z (incf i)) #'eql)) + (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) + :test (progn (setf z (incf i)) #'eql)) i x y z)) (3 . c) 3 1 2 3) @@ -219,8 +219,8 @@ (let ((i 0) x y) (values (rassoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) - :test #'eql) + (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) + :test #'eql) i x y)) (3 . c) 2 1 2) @@ -228,9 +228,9 @@ (let ((i 0) x y z w) (values (rassoc (progn (setf x (incf i)) 'c) - (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) - :key (progn (setf z (incf i)) #'identity) - :key (progn (setf w (incf i)) #'not)) + (progn (setf y (incf i)) '((1 . a) (2 . b) (3 . c) (4 . c))) + :key (progn (setf z (incf i)) #'identity) + :key (progn (setf w (incf i)) #'not)) i x y z w)) (3 . c) 4 1 2 3 4) @@ -246,7 +246,7 @@ (deftest rassoc.allow-other-keys.3 (rassoc 'a '((1 . a) (2 . b) (3 . c)) :allow-other-keys t :bad t - :test-not #'eql) + :test-not #'eql) (2 . b)) (deftest rassoc.allow-other-keys.4 @@ -259,7 +259,7 @@ (deftest rassoc.keywords.6 (rassoc 'b '((1 . a) (2 . b) (3 . c)) - :test #'eql :test (complement #'eql)) + :test #'eql :test (complement #'eql)) (2 . b)) ;;; Error tests diff --git a/ansi-tests/rational.lsp b/ansi-tests/rational.lsp index cafc5468..715ad647 100644 --- a/ansi-tests/rational.lsp +++ b/ansi-tests/rational.lsp @@ -23,34 +23,34 @@ (deftest rational.1 (loop for x in (loop for r in *reals* - when (or (not (floatp r)) - (<= -1000 (nth-value 1 (integer-decode-float r)) 1000)) - collect r) - for r = (rational x) - unless (and (rationalp r) - (if (floatp x) - (= (float r x) x) - (eql x r))) - collect (list x r)) + when (or (not (floatp r)) + (<= -1000 (nth-value 1 (integer-decode-float r)) 1000)) + collect r) + for r = (rational x) + unless (and (rationalp r) + (if (floatp x) + (= (float r x) x) + (eql x r))) + collect (list x r)) nil) (deftest rational.2 (loop for type in '(short-float single-float double-float long-float) - collect - (loop for i from -10000 to 10000 - for x = (coerce i type) - for r = (rational x) - count (not (eql r i)))) + collect + (loop for i from -10000 to 10000 + for x = (coerce i type) + for r = (rational x) + count (not (eql r i)))) (0 0 0 0)) (deftest rational.3 (loop for type in '(short-float single-float double-float long-float) - for bound in '(1.0s5 1.0f10 1.0d20 1.0l30) - nconc - (loop for x = (random-from-interval bound) - for r = (rational x) - for x2 = (float r x) - repeat 1000 - unless (and (rationalp r) (= x x2)) - collect (list x r x2))) - nil) \ No newline at end of file + for bound in '(1.0s5 1.0f10 1.0d20 1.0l30) + nconc + (loop for x = (random-from-interval bound) + for r = (rational x) + for x2 = (float r x) + repeat 1000 + unless (and (rationalp r) (= x x2)) + collect (list x r x2))) + nil) diff --git a/ansi-tests/rationalize.lsp b/ansi-tests/rationalize.lsp index d39aabe0..800f1d79 100644 --- a/ansi-tests/rationalize.lsp +++ b/ansi-tests/rationalize.lsp @@ -23,34 +23,34 @@ (deftest rationalize.1 (loop for x in (loop for r in *reals* - when (or (not (floatp r)) - (<= -1000 (nth-value 1 (integer-decode-float r)) 1000)) - collect r) - for r = (rationalize x) - unless (and (rationalp r) - (if (floatp x) - (= (float r x) x) - (eql x r))) - collect (list x r)) + when (or (not (floatp r)) + (<= -1000 (nth-value 1 (integer-decode-float r)) 1000)) + collect r) + for r = (rationalize x) + unless (and (rationalp r) + (if (floatp x) + (= (float r x) x) + (eql x r))) + collect (list x r)) nil) (deftest rationalize.2 (loop for type in '(short-float single-float double-float long-float) - collect - (loop for i from -10000 to 10000 - for x = (coerce i type) - for r = (rationalize x) - count (not (eql r i)))) + collect + (loop for i from -10000 to 10000 + for x = (coerce i type) + for r = (rationalize x) + count (not (eql r i)))) (0 0 0 0)) (deftest rationalize.3 (loop for type in '(short-float single-float double-float long-float) - for bound in '(1.0s5 1.0f10 1.0d20 1.0l30) - nconc - (loop for x = (random-from-interval bound) - for r = (rationalize x) - for x2 = (float r x) - repeat 1000 - unless (and (rationalp r) (= x x2)) - collect (list x r x2))) + for bound in '(1.0s5 1.0f10 1.0d20 1.0l30) + nconc + (loop for x = (random-from-interval bound) + for r = (rationalize x) + for x2 = (float r x) + repeat 1000 + unless (and (rationalp r) (= x x2)) + collect (list x r x2))) nil) diff --git a/ansi-tests/rationalp.lsp b/ansi-tests/rationalp.lsp index 796a0a86..4524894f 100644 --- a/ansi-tests/rationalp.lsp +++ b/ansi-tests/rationalp.lsp @@ -19,18 +19,18 @@ (deftest rationalp.1 (loop for x in *rationals* - for vals = (multiple-value-list (rationalp x)) - unless (and (= (length vals) 1) - (first vals)) - collect (cons x vals)) + for vals = (multiple-value-list (rationalp x)) + unless (and (= (length vals) 1) + (first vals)) + collect (cons x vals)) nil) (deftest rationalp.2 (loop for x in (set-difference *universe* *rationals*) - for vals = (multiple-value-list (rationalp x)) - unless (and (= (length vals) 1) - (null (first vals))) - collect (cons x vals)) + for vals = (multiple-value-list (rationalp x)) + unless (and (= (length vals) 1) + (null (first vals))) + collect (cons x vals)) nil) (deftest rationalp.3 diff --git a/ansi-tests/read-byte.lsp b/ansi-tests/read-byte.lsp index 5b179725..afbf2e11 100644 --- a/ansi-tests/read-byte.lsp +++ b/ansi-tests/read-byte.lsp @@ -7,76 +7,76 @@ (deftest read-byte.1 (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)))) + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)))) (values (write-byte 17 s) (close s) (progn (setq s (open "foo.txt" - :direction :input - :element-type '(unsigned-byte 8))) + :direction :input + :element-type '(unsigned-byte 8))) (read-byte s)) (close s))) 17 t 17 t) (deftest read-byte.2 (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)))) + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)))) (values (close s) (progn (setq s (open "foo.txt" - :direction :input - :element-type '(unsigned-byte 8))) - (read-byte s nil 'foo)) + :direction :input + :element-type '(unsigned-byte 8))) + (read-byte s nil 'foo)) (read-byte s nil) (close s))) t foo nil t) (deftest read-byte.3 (loop with b1 = 0 - and b2 = 0 - for i from 1 to 32 - do (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type `(unsigned-byte ,i)))) - (write-byte (1- (ash 1 i)) s) - (write-byte 1 s) - (close s)) - unless (let ((s (open "foo.txt" - :direction :input - :element-type `(unsigned-byte ,i)))) - (prog1 - (and (eql (setq b1 (read-byte s)) (1- (ash 1 i))) - (eql (setq b2 (read-byte s)) 1)) - (close s))) - collect (list i b1 b2)) + and b2 = 0 + for i from 1 to 32 + do (let ((s (open "foo.txt" + :direction :output + :if-exists :supersede + :element-type `(unsigned-byte ,i)))) + (write-byte (1- (ash 1 i)) s) + (write-byte 1 s) + (close s)) + unless (let ((s (open "foo.txt" + :direction :input + :element-type `(unsigned-byte ,i)))) + (prog1 + (and (eql (setq b1 (read-byte s)) (1- (ash 1 i))) + (eql (setq b2 (read-byte s)) 1)) + (close s))) + collect (list i b1 b2)) nil) (deftest read-byte.4 (loop with b1 = 0 - and b2 = 0 - for i from 33 to 200 by 7 - do (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type `(unsigned-byte ,i)))) - (write-byte (1- (ash 1 i)) s) - (write-byte 1 s) - (close s)) - unless (let ((s (open "foo.txt" - :direction :input - :element-type `(unsigned-byte ,i)))) - (prog1 - (and (eql (setq b1 (read-byte s)) (1- (ash 1 i))) - (eql (setq b2 (read-byte s)) 1)) - (close s))) - collect (list i b1 b2)) + and b2 = 0 + for i from 33 to 200 by 7 + do (let ((s (open "foo.txt" + :direction :output + :if-exists :supersede + :element-type `(unsigned-byte ,i)))) + (write-byte (1- (ash 1 i)) s) + (write-byte 1 s) + (close s)) + unless (let ((s (open "foo.txt" + :direction :input + :element-type `(unsigned-byte ,i)))) + (prog1 + (and (eql (setq b1 (read-byte s)) (1- (ash 1 i))) + (eql (setq b2 (read-byte s)) 1)) + (close s))) + collect (list i b1 b2)) nil) ;;; Error tests @@ -88,14 +88,14 @@ (deftest read-byte.error.2 (progn (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type `(unsigned-byte 8)))) + :direction :output + :if-exists :supersede + :element-type `(unsigned-byte 8)))) (close s)) (signals-error (let ((s (open "foo.txt" - :direction :input - :element-type '(unsigned-byte 8)))) + :direction :input + :element-type '(unsigned-byte 8)))) (read-byte s)) end-of-file)) t) @@ -103,14 +103,14 @@ (deftest read-byte.error.3 (progn (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede))) + :direction :output + :if-exists :supersede))) (close s)) (signals-error (let ((s (open "foo.txt" :direction :input))) (unwind-protect - (read-byte s) - (close s))) + (read-byte s) + (close s))) error)) t) @@ -118,16 +118,16 @@ (signals-error-always (progn (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)))) + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)))) (close s)) (let ((s (open "foo.txt" - :direction :input - :element-type '(unsigned-byte 8)))) + :direction :input + :element-type '(unsigned-byte 8)))) (unwind-protect - (read-byte s t) - (close s)))) + (read-byte s t) + (close s)))) end-of-file) t t) @@ -138,21 +138,21 @@ (deftest read-byte.error.6 (progn (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)))) + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)))) (close s)) (signals-error (let ((s (open "foo.txt" - :direction :input - :element-type '(unsigned-byte 8)))) + :direction :input + :element-type '(unsigned-byte 8)))) (unwind-protect - (read-byte s t t nil) - (close s))) + (read-byte s t t nil) + (close s))) program-error)) t) - + (deftest write-byte.error.1 (signals-error (write-byte) program-error) t) @@ -164,11 +164,11 @@ (deftest write-byte.error.3 (signals-error (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede - :element-type '(unsigned-byte 8)))) + :direction :output + :if-exists :supersede + :element-type '(unsigned-byte 8)))) (unwind-protect - (write 1 s nil) + (write 1 s nil) (close s))) program-error) t) @@ -180,15 +180,15 @@ (deftest write-byte.error.5 (signals-error (let ((s (open "foo.txt" - :direction :output - :if-exists :supersede))) + :direction :output + :if-exists :supersede))) (unwind-protect - (write 1 s) - (close s))) + (write 1 s) + (close s))) error) t) - - + + diff --git a/ansi-tests/read-char-no-hang.lsp b/ansi-tests/read-char-no-hang.lsp index 9a6e168f..cea82c0a 100644 --- a/ansi-tests/read-char-no-hang.lsp +++ b/ansi-tests/read-char-no-hang.lsp @@ -24,9 +24,9 @@ (deftest read-char-no-hang.3 (with-input-from-string (*standard-input* (concatenate 'string - "a" - (string (code-char 0)) - "b")) + "a" + (string (code-char 0)) + "b")) (values (read-char-no-hang) (read-char-no-hang) diff --git a/ansi-tests/read-char.lsp b/ansi-tests/read-char.lsp index 0b635404..85a37759 100644 --- a/ansi-tests/read-char.lsp +++ b/ansi-tests/read-char.lsp @@ -24,9 +24,9 @@ (deftest read-char.3 (with-input-from-string (*standard-input* (concatenate 'string - "a" - (string (code-char 0)) - "b")) + "a" + (string (code-char 0)) + "b")) (values (read-char) (read-char) diff --git a/ansi-tests/read-from-string.lsp b/ansi-tests/read-from-string.lsp index bbf3b5e4..ccfc98b0 100644 --- a/ansi-tests/read-from-string.lsp +++ b/ansi-tests/read-from-string.lsp @@ -45,7 +45,7 @@ (do-special-strings (s "71235") (let ((vals (multiple-value-list - (read-from-string s t nil :start 1 :end 4)))) + (read-from-string s t nil :start 1 :end 4)))) (assert (equal vals '(123 4)))))) nil) @@ -54,7 +54,7 @@ (do-special-strings (s "7123 ") (let ((vals (multiple-value-list - (read-from-string s t nil :start 1)))) + (read-from-string s t nil :start 1)))) (assert (equal vals '(123 5)))))) nil) @@ -64,7 +64,7 @@ (do-special-strings (s "7123 ") (let ((vals (multiple-value-list - (read-from-string s t nil :end 4)))) + (read-from-string s t nil :end 4)))) (assert (equal vals '(7123 4)))))) nil) @@ -73,7 +73,7 @@ (do-special-strings (s "7123") (let ((vals (multiple-value-list - (read-from-string s nil 'foo :start 2 :end 2)))) + (read-from-string s nil 'foo :start 2 :end 2)))) (assert (equal vals '(foo 2)))))) nil) @@ -82,7 +82,7 @@ (do-special-strings (s "123 ") (let ((vals (multiple-value-list - (read-from-string s t nil :preserve-whitespace t)))) + (read-from-string s t nil :preserve-whitespace t)))) (assert (equal vals '(123 3)))))) nil) @@ -91,7 +91,7 @@ (do-special-strings (s (concatenate 'string "( )" (string #\Newline))) (let ((vals (multiple-value-list - (read-from-string s t nil :preserve-whitespace t)))) + (read-from-string s t nil :preserve-whitespace t)))) (assert (equal vals '(nil 3)))))) nil) @@ -102,7 +102,7 @@ (do-special-strings (s "7123 ") (let ((vals (multiple-value-list - (read-from-string s t nil :start 1 :start 2)))) + (read-from-string s t nil :start 1 :start 2)))) (assert (equal vals '(123 5)))))) nil) @@ -111,7 +111,7 @@ (do-special-strings (s "7123 ") (let ((vals (multiple-value-list - (read-from-string s t nil :end 4 :end 2)))) + (read-from-string s t nil :end 4 :end 2)))) (assert (equal vals '(7123 4)))))) nil) @@ -120,8 +120,8 @@ (do-special-strings (s (concatenate 'string "( )" (string #\Newline))) (let ((vals (multiple-value-list - (read-from-string s t nil :preserve-whitespace t - :preserve-whitespace nil)))) + (read-from-string s t nil :preserve-whitespace t + :preserve-whitespace nil)))) (assert (equal vals '(nil 3)))))) nil) @@ -133,8 +133,8 @@ (do-special-strings (s "abc ") (let ((vals (multiple-value-list - (read-from-string s t nil :allow-other-keys nil)))) - (assert (equal vals '(|ABC| 4)) (vals) "VALS is ~A" vals))))) + (read-from-string s t nil :allow-other-keys nil)))) + (assert (equal vals '(|ABC| 4)) (vals) "VALS is ~A" vals))))) nil) (deftest read-from-string.15 @@ -142,7 +142,7 @@ (do-special-strings (s "123 ") (let ((vals (multiple-value-list - (read-from-string s t nil :foo 'bar :allow-other-keys t)))) + (read-from-string s t nil :foo 'bar :allow-other-keys t)))) (assert (equal vals '(123 4)) (vals) "VALS is ~A" vals)))) nil) @@ -151,8 +151,8 @@ (do-special-strings (s "123 ") (let ((vals (multiple-value-list - (read-from-string s t nil :allow-other-keys t - :allow-other-keys nil :foo 'bar)))) + (read-from-string s t nil :allow-other-keys t + :allow-other-keys nil :foo 'bar)))) (assert (equal vals '(123 4)) (vals) "VALS is ~A" vals)))) nil) @@ -209,30 +209,30 @@ (deftest read-from-string.error.10 (signals-error (read-from-string "A" nil t - :bad-keyword t - :allow-other-keys nil) - program-error) + :bad-keyword t + :allow-other-keys nil) + program-error) t) (deftest read-from-string.error.11 (signals-error (read-from-string "A" nil t - :bad-keyword t - :allow-other-keys nil - :allow-other-keys t) - program-error) + :bad-keyword t + :allow-other-keys nil + :allow-other-keys t) + program-error) t) (deftest read-from-string.error.12 (signals-error (read-from-string "A" nil t - :allow-other-keys nil - :allow-other-keys t - :bad-keyword t) - program-error) + :allow-other-keys nil + :allow-other-keys t + :bad-keyword t) + program-error) t) (deftest read-from-string.error.13 (signals-error (read-from-string "A" nil t :start) - program-error) + program-error) t) diff --git a/ansi-tests/read-preserving-whitespace.lsp b/ansi-tests/read-preserving-whitespace.lsp index 925696ac..effd48c6 100644 --- a/ansi-tests/read-preserving-whitespace.lsp +++ b/ansi-tests/read-preserving-whitespace.lsp @@ -14,8 +14,8 @@ (with-output-to-string (os) (with-open-stream - (*terminal-io* (make-two-way-stream is os)) - (return-from done (read-preserving-whitespace t)))))) + (*terminal-io* (make-two-way-stream is os)) + (return-from done (read-preserving-whitespace t)))))) 1) (deftest read-preserving-whitespace.2 @@ -115,7 +115,7 @@ (with-input-from-string (s "") (read-preserving-whitespace s nil 'foo)) - foo) + foo) ;;; Error tests diff --git a/ansi-tests/read-sequence.lsp b/ansi-tests/read-sequence.lsp index 0250aac8..1010f8b2 100644 --- a/ansi-tests/read-sequence.lsp +++ b/ansi-tests/read-sequence.lsp @@ -11,10 +11,10 @@ `(deftest ,name (let ((s ,init)) (with-input-from-string - (is ,input) - (values - (read-sequence s is ,@args) - s))) + (is ,input) + (values + (read-sequence s is ,@args) + s))) ,@expected)) (def-read-sequence-test read-sequence.string.1 (copy-seq " ") @@ -190,40 +190,40 @@ ;; Create output file (progn (let (os) - (unwind-protect - (progn - (setq os (open "temp.dat" :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede)) - (loop for i in '(0 1 1 0 0 1 1 0 1 0 1 1 1 0) - do (write-byte i os))) - (when os (close os)))) + (unwind-protect + (progn + (setq os (open "temp.dat" :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede)) + (loop for i in '(0 1 1 0 0 1 1 0 1 0 1 1 1 0) + do (write-byte i os))) + (when os (close os)))) (let (is (bv (copy-seq ,init))) - (unwind-protect - (progn - (setq is (open "temp.dat" :direction :input - :element-type '(unsigned-byte 8))) - (values - (read-sequence bv is ,@args) - bv)) - (when is (close is))))) + (unwind-protect + (progn + (setq is (open "temp.dat" :direction :input + :element-type '(unsigned-byte 8))) + (values + (read-sequence bv is ,@args) + bv)) + (when is (close is))))) ,@expected)) - + (def-read-sequence-bv-test read-sequence.bv.1 #*00000000000000 () 14 #*01100110101110) - + (def-read-sequence-bv-test read-sequence.bv.2 #*00000000000000 (:start 0) 14 #*01100110101110) - + (def-read-sequence-bv-test read-sequence.bv.3 #*00000000000000 (:end 14) 14 #*01100110101110) - + (def-read-sequence-bv-test read-sequence.bv.4 #*00000000000000 (:end nil) 14 #*01100110101110) - + (def-read-sequence-bv-test read-sequence.bv.5 #*00000000000000 (:start 2) 14 #*00011001101011) - + (def-read-sequence-bv-test read-sequence.bv.6 #*00000000000000 (:start 2 :end 13) 13 #*00011001101010) @@ -256,13 +256,13 @@ (deftest read-sequence.error.5 (signals-error (read-sequence (make-string 5) (make-string-input-stream "abc") - :allow-other-keys nil :bar 2) + :allow-other-keys nil :bar 2) program-error) t) (deftest read-sequence.error.6 (check-type-error #'(lambda (x) (read-sequence x (make-string-input-stream "abc"))) - #'sequencep) + #'sequencep) nil) (deftest read-sequence.error.7 @@ -274,27 +274,27 @@ ;;; This test appears to cause Allegro CL to crash (deftest read-sequence.error.8 (signals-type-error x -1 - (read-sequence (make-string 3) - (make-string-input-stream "abc") - :start x)) + (read-sequence (make-string 3) + (make-string-input-stream "abc") + :start x)) t) (deftest read-sequence.error.9 (check-type-error #'(lambda (s) - (read-sequence (make-string 3) (make-string-input-stream "abc") - :start s)) - (typef 'unsigned-byte)) + (read-sequence (make-string 3) (make-string-input-stream "abc") + :start s)) + (typef 'unsigned-byte)) nil) (deftest read-sequence.error.10 (signals-type-error x -1 - (read-sequence (make-string 3) (make-string-input-stream "abc") - :end x)) + (read-sequence (make-string 3) (make-string-input-stream "abc") + :end x)) t) (deftest read-sequence.error.11 (check-type-error #'(lambda (e) - (read-sequence (make-string 3) (make-string-input-stream "abc") - :end e)) - (typef '(or unsigned-byte null))) + (read-sequence (make-string 3) (make-string-input-stream "abc") + :end e)) + (typef '(or unsigned-byte null))) nil) diff --git a/ansi-tests/read-suppress.lsp b/ansi-tests/read-suppress.lsp index 0a93829e..db1ea6ab 100644 --- a/ansi-tests/read-suppress.lsp +++ b/ansi-tests/read-suppress.lsp @@ -32,36 +32,36 @@ (declaim (type simple-base-string *non-macro-chars*)) (defmacro def-random-suppress-test (name &key - (chars '*non-macro-chars*) - (reps 1000) - (maxlen 8) - (count 10) - (prefix "") - (suffix "")) + (chars '*non-macro-chars*) + (reps 1000) + (maxlen 8) + (count 10) + (prefix "") + (suffix "")) `(def-syntax-test ,name (let* ((chars ,chars) - (prefix ,prefix) - (suffix ,suffix) - (*read-suppress* t) - (count 0) - (maxlen ,maxlen) - (reps ,reps) - (maxcount ,count)) + (prefix ,prefix) + (suffix ,suffix) + (*read-suppress* t) + (count 0) + (maxlen ,maxlen) + (reps ,reps) + (maxcount ,count)) (loop for n = (1+ (random maxlen)) - for s = (concatenate 'string - prefix - (loop repeat n - collect (random-from-seq chars)) - suffix) - for vals = (multiple-value-list - (handler-case (read-from-string s) - (reader-error (rc) rc))) - repeat reps - unless (equal vals (list nil (length s))) - collect (progn (when (> (incf count) maxcount) - (loop-finish)) - (list n s vals)))) - nil)) + for s = (concatenate 'string + prefix + (loop repeat n + collect (random-from-seq chars)) + suffix) + for vals = (multiple-value-list + (handler-case (read-from-string s) + (reader-error (rc) rc))) + repeat reps + unless (equal vals (list nil (length s))) + collect (progn (when (> (incf count) maxcount) + (loop-finish)) + (list n s vals)))) + nil)) (def-random-suppress-test read-suppress.13) (def-random-suppress-test read-suppress.14 :prefix "(" :suffix ")") @@ -232,20 +232,20 @@ (def-syntax-test read-suppress.error.1 (signals-error (let ((*read-suppress* t)) (read-from-string "')")) - reader-error) + reader-error) t) (def-syntax-test read-suppress.error.2 (signals-error (let ((*read-suppress* t)) (read-from-string "#<")) - reader-error) + reader-error) t) (def-syntax-test read-suppress.error.3 (signals-error (let ((*read-suppress* t)) (read-from-string "# ")) - reader-error) + reader-error) t) (def-syntax-test read-suppress.error.4 (signals-error (let ((*read-suppress* t)) (read-from-string "#)")) - reader-error) + reader-error) t) diff --git a/ansi-tests/read.lsp b/ansi-tests/read.lsp index fa298c73..9b470350 100644 --- a/ansi-tests/read.lsp +++ b/ansi-tests/read.lsp @@ -14,8 +14,8 @@ (with-output-to-string (os) (with-open-stream - (*terminal-io* (make-two-way-stream is os)) - (return-from done (read t)))))) + (*terminal-io* (make-two-way-stream is os)) + (return-from done (read t)))))) 1) (deftest read.2 @@ -115,7 +115,7 @@ (with-input-from-string (s "") (read s nil 'foo)) - foo) + foo) ;;; Error tests diff --git a/ansi-tests/reader-aux.lsp b/ansi-tests/reader-aux.lsp index 40524820..490f3f60 100644 --- a/ansi-tests/reader-aux.lsp +++ b/ansi-tests/reader-aux.lsp @@ -32,8 +32,8 @@ `(deftest ,name (let ((s (read-from-string ,(concatenate 'string "#:" string)))) (values - (symbol-package s) - (symbol-name s))) + (symbol-package s) + (symbol-name s))) nil ,(string-upcase string))) (defmacro def-syntax-array-test (name form expected-result) @@ -42,7 +42,7 @@ (assert (typep v 'simple-array)) (assert (not (array-has-fill-pointer-p v))) (assert (eql (array-element-type v) - (upgraded-array-element-type t))) + (upgraded-array-element-type t))) v) ,(eval expected-result))) diff --git a/ansi-tests/reader-test.lsp b/ansi-tests/reader-test.lsp index ec6b70a4..b3d63582 100644 --- a/ansi-tests/reader-test.lsp +++ b/ansi-tests/reader-test.lsp @@ -20,9 +20,9 @@ (read-from-string "#:abc") (not (and (symbolp s) - (eql n 5) - (not (symbol-package s)) - (string-equal (symbol-name s) "abc")))) + (eql n 5) + (not (symbol-package s)) + (string-equal (symbol-name s) "abc")))) nil) (def-syntax-test read-symbol.4 @@ -30,74 +30,74 @@ (read-from-string "#:|abc|") (not (and (symbolp s) - (eql n 7) - (not (symbol-package s)) - (string= (symbol-name s) "abc")))) + (eql n 7) + (not (symbol-package s)) + (string= (symbol-name s) "abc")))) nil) (def-syntax-test read-symbol.5 (multiple-value-bind (s n) (read-from-string "#:||") (if (not (symbolp s)) - s + s (not (not - (and (eql n 4) - (not (symbol-package s)) - (string= (symbol-name s) "")))))) + (and (eql n 4) + (not (symbol-package s)) + (string= (symbol-name s) "")))))) t) (def-syntax-test read-symbol.6 (let ((str "cl-test::abcd0123")) (multiple-value-bind (s n) - (read-from-string str) + (read-from-string str) (if (not (symbolp s)) - s - (not (not - (and (eql n (length str)) - (eqt (symbol-package s) (find-package :cl-test)) - (string-equal (symbol-name s) - "abcd0123"))))))) + s + (not (not + (and (eql n (length str)) + (eqt (symbol-package s) (find-package :cl-test)) + (string-equal (symbol-name s) + "abcd0123"))))))) t) (def-syntax-test read-symbol.7 (multiple-value-bind (s n) (read-from-string ":ABCD") (if (not (symbolp s)) - s + s (not (not - (and (eql n 5) - (eqt (symbol-package s) (find-package "KEYWORD")) - (string-equal (symbol-name s) - "ABCD")))))) + (and (eql n 5) + (eqt (symbol-package s) (find-package "KEYWORD")) + (string-equal (symbol-name s) + "ABCD")))))) t) - + (defun read-symbol.9-body (natoms maxlen &optional (chars +standard-chars+)) (loop repeat natoms count (let* ((len (random (1+ maxlen))) - (actual-len 0) - (s (make-string (+ 2 (* 2 len)))) - (s2 (make-string len))) + (actual-len 0) + (s (make-string (+ 2 (* 2 len)))) + (s2 (make-string len))) (loop for j from 0 to (1- len) do - (let ((c (random-from-seq chars))) - (when (member c '(#\| #\\)) - (setf (elt s actual-len) #\\) - (incf actual-len)) - (setf (elt s actual-len) c) - (setf (elt s2 j) c) - (incf actual-len))) + (let ((c (random-from-seq chars))) + (when (member c '(#\| #\\)) + (setf (elt s actual-len) #\\) + (incf actual-len)) + (setf (elt s actual-len) c) + (setf (elt s2 j) c) + (incf actual-len))) (let ((actual-string (subseq s 0 actual-len))) (multiple-value-bind (sym nread) - (read-from-string - (concatenate 'string "#:|" actual-string "|")) - (unless (and (symbolp sym) - (eql nread (+ 4 actual-len)) - (string-equal s2 (symbol-name sym))) - (let ((*print-readably* t)) - (format t "Symbol read failed: ~S (~S) read as ~S~%" - actual-string s2 sym)) - t)))))) + (read-from-string + (concatenate 'string "#:|" actual-string "|")) + (unless (and (symbolp sym) + (eql nread (+ 4 actual-len)) + (string-equal s2 (symbol-name sym))) + (let ((*print-readably* t)) + (format t "Symbol read failed: ~S (~S) read as ~S~%" + actual-string s2 sym)) + t)))))) (def-syntax-test read-symbol.9 (read-symbol.9-body 1000 100) @@ -105,118 +105,118 @@ (def-syntax-test read-symbol.9a (let ((chars (coerce (loop for i below (min 256 char-code-limit) - for c = (code-char i) - when c collect c) - 'string))) + for c = (code-char i) + when c collect c) + 'string))) (if (> (length chars) 0) - (read-symbol.9-body 1000 100) + (read-symbol.9-body 1000 100) 0)) 0) (def-syntax-test read-symbol.9b (let ((chars (coerce (loop for i below (min 65536 char-code-limit) - for c = (code-char i) - when c collect c) - 'string))) + for c = (code-char i) + when c collect c) + 'string))) (if (> (length chars) 0) - (read-symbol.9-body 1000 100) + (read-symbol.9-body 1000 100) 0)) 0) (def-syntax-test read-symbol.10 (equalt (symbol-name - (read-from-string - (with-output-to-string (s) - (write (make-symbol ":") - :readably t - :stream s)))) - ":") + (read-from-string + (with-output-to-string (s) + (write (make-symbol ":") + :readably t + :stream s)))) + ":") t) (def-syntax-test read-symbol.11 (loop for c across +standard-chars+ - for str = (make-array 2 :element-type 'character :initial-contents (list #\\ c)) - for sym = (read-from-string str) - unless (and (symbolp sym) - (eql sym (find-symbol (string c))) - (equal (symbol-name sym) (string c))) - collect (list c str sym)) + for str = (make-array 2 :element-type 'character :initial-contents (list #\\ c)) + for sym = (read-from-string str) + unless (and (symbolp sym) + (eql sym (find-symbol (string c))) + (equal (symbol-name sym) (string c))) + collect (list c str sym)) nil) (def-syntax-test read-symbol.12 (loop for c across +standard-chars+ - for str = (make-array 2 :element-type 'base-char :initial-contents (list #\\ c)) - for sym = (read-from-string str) - unless (and (symbolp sym) - (eql sym (find-symbol (string c))) - (equal (symbol-name sym) (string c))) - collect (list c str sym)) + for str = (make-array 2 :element-type 'base-char :initial-contents (list #\\ c)) + for sym = (read-from-string str) + unless (and (symbolp sym) + (eql sym (find-symbol (string c))) + (equal (symbol-name sym) (string c))) + collect (list c str sym)) nil) (def-syntax-test read-symbol.13 (loop for i below (min 65536 char-code-limit) - for c = (code-char i) - for str = (and c (make-array 2 :element-type 'character :initial-contents (list #\\ c))) - for sym = (and c (read-from-string str)) - unless (or (not c) - (and (symbolp sym) - (eql sym (find-symbol (string c))) - (equal (symbol-name sym) (string c)))) - collect (list c str sym)) + for c = (code-char i) + for str = (and c (make-array 2 :element-type 'character :initial-contents (list #\\ c))) + for sym = (and c (read-from-string str)) + unless (or (not c) + (and (symbolp sym) + (eql sym (find-symbol (string c))) + (equal (symbol-name sym) (string c)))) + collect (list c str sym)) nil) (def-syntax-test read-symbol.14 (loop for i = (random (min (ash 1 24) char-code-limit)) - for c = (code-char i) - for str = (and c (make-array 2 :element-type 'character :initial-contents (list #\\ c))) - for sym = (and c (read-from-string str)) - repeat 1000 - unless (or (not c) - (and (symbolp sym) - (eql sym (find-symbol (string c))) - (equal (symbol-name sym) (string c)))) - collect (list c str sym)) + for c = (code-char i) + for str = (and c (make-array 2 :element-type 'character :initial-contents (list #\\ c))) + for sym = (and c (read-from-string str)) + repeat 1000 + unless (or (not c) + (and (symbolp sym) + (eql sym (find-symbol (string c))) + (equal (symbol-name sym) (string c)))) + collect (list c str sym)) nil) (def-syntax-test read-symbol.15 (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" - for str = (string c) - for sym = (read-from-string str) - unless (eql sym (find-symbol (string (char-upcase c)))) - collect (list c str sym)) + for str = (string c) + for sym = (read-from-string str) + unless (eql sym (find-symbol (string (char-upcase c)))) + collect (list c str sym)) nil) (def-syntax-test read-symbol.16 (let ((*readtable* (copy-readtable))) (setf (readtable-case *readtable*) :downcase) (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" - for str = (string c) - for sym = (read-from-string str) - unless (eql sym (find-symbol (string (char-downcase c)))) - collect (list c str sym))) + for str = (string c) + for sym = (read-from-string str) + unless (eql sym (find-symbol (string (char-downcase c)))) + collect (list c str sym))) nil) (def-syntax-test read-symbol.17 (let ((*readtable* (copy-readtable))) (setf (readtable-case *readtable*) :preserve) (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" - for str = (string c) - for sym = (read-from-string str) - unless (eql sym (find-symbol str)) - collect (list c str sym))) + for str = (string c) + for sym = (read-from-string str) + unless (eql sym (find-symbol str)) + collect (list c str sym))) nil) (def-syntax-test read-symbol.18 (let ((*readtable* (copy-readtable))) (setf (readtable-case *readtable*) :invert) (loop for c across "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ!@$%^&*_-+={}[]<>?/~" - for str = (string c) - for sym = (read-from-string str) - for c2 = (cond ((upper-case-p c) (char-downcase c)) - ((lower-case-p c) (char-upcase c)) - (t c)) - unless (eql sym (find-symbol (string c2))) - collect (list c c2 str sym))) + for str = (string c) + for sym = (read-from-string str) + for c2 = (cond ((upper-case-p c) (char-downcase c)) + ((lower-case-p c) (char-upcase c)) + (t c)) + unless (eql sym (find-symbol (string c2))) + collect (list c c2 str sym))) nil) (def-syntax-test read-symbol.19 @@ -237,48 +237,48 @@ (def-syntax-test read-symbol.23 (loop for c across +standard-chars+ - for s = (concatenate 'string (string c) ".") - for sym = (intern (string-upcase s)) - when (alpha-char-p c) - nconc - (let ((sym2 (let ((*read-base* 36)) - (read-from-string s)))) - (if (eq sym sym2) - nil - (list c s sym sym2)))) + for s = (concatenate 'string (string c) ".") + for sym = (intern (string-upcase s)) + when (alpha-char-p c) + nconc + (let ((sym2 (let ((*read-base* 36)) + (read-from-string s)))) + (if (eq sym sym2) + nil + (list c s sym sym2)))) nil) (def-syntax-test read-symbol.24 (loop for c1 = (random-from-seq +alpha-chars+) - for c2 = (random-from-seq +alpha-chars+) - for d1 = (loop repeat (random 4) collect (random-from-seq +digit-chars+)) - for d2 = (loop repeat (random 4) collect (random-from-seq +digit-chars+)) - for s = (concatenate 'string d1 (list c1 c2) d2) - for sym = (intern (string-upcase s)) - repeat 1000 - nconc - (let ((sym2 (read-from-string s))) - (if (eq sym sym2) - nil - (list c1 c2 d1 d2 s sym sym2)))) + for c2 = (random-from-seq +alpha-chars+) + for d1 = (loop repeat (random 4) collect (random-from-seq +digit-chars+)) + for d2 = (loop repeat (random 4) collect (random-from-seq +digit-chars+)) + for s = (concatenate 'string d1 (list c1 c2) d2) + for sym = (intern (string-upcase s)) + repeat 1000 + nconc + (let ((sym2 (read-from-string s))) + (if (eq sym sym2) + nil + (list c1 c2 d1 d2 s sym sym2)))) nil) (def-syntax-test read-symbol.25 (let ((potential-chars "01234567890123456789+-esdlf_^/") - (*readtable* (copy-readtable))) + (*readtable* (copy-readtable))) (setf (readtable-case *readtable*) :preserve) (loop for d1 = (loop repeat (random 6) - collect (random-from-seq potential-chars)) - for c = (random-from-seq potential-chars) - for d2 = (loop repeat (random 6) - collect (random-from-seq potential-chars)) - for s1 = (concatenate 'string d1 (list c) d2) - for sym1 = (intern s1) - for s2 = (concatenate 'string d1 (list #\\ c) d2) - for sym2 = (read-from-string s2) - repeat 1000 - unless (eql sym1 sym2) - collect (list d1 c d2 s1 sym1 s2 sym2))) + collect (random-from-seq potential-chars)) + for c = (random-from-seq potential-chars) + for d2 = (loop repeat (random 6) + collect (random-from-seq potential-chars)) + for s1 = (concatenate 'string d1 (list c) d2) + for sym1 = (intern s1) + for s2 = (concatenate 'string d1 (list #\\ c) d2) + for sym2 = (read-from-string s2) + repeat 1000 + unless (eql sym1 sym2) + collect (list d1 c d2 s1 sym1 s2 sym2))) nil) (deftest read-float.1 diff --git a/ansi-tests/readtable-case.lsp b/ansi-tests/readtable-case.lsp index a6faf003..85eec66b 100644 --- a/ansi-tests/readtable-case.lsp +++ b/ansi-tests/readtable-case.lsp @@ -47,10 +47,10 @@ (deftest readtable-case.7 (let ((rt (copy-readtable))) (loop for rtc in '(:upcase :downcase :preserve :invert) - do (setf (readtable-case rt) rtc) - nconc (let ((rt2 (copy-readtable rt))) - (unless (eq (readtable-case rt2) rtc) - (list rtc rt2))))) + do (setf (readtable-case rt) rtc) + nconc (let ((rt2 (copy-readtable rt))) + (unless (eq (readtable-case rt2) rtc) + (list rtc rt2))))) nil) ;;; Error cases @@ -69,13 +69,13 @@ (deftest readtable-case.error.4 (check-type-error #'(lambda (x) - (let ((rt (copy-readtable))) - (setf (readtable-case rt) x))) - (typef '(member :upcase :downcase :preserve :invert))) + (let ((rt (copy-readtable))) + (setf (readtable-case rt) x))) + (typef '(member :upcase :downcase :preserve :invert))) nil) (deftest readtable-case.error.5 (check-type-error #'(lambda (x) (setf (readtable-case x) :upcase)) - (typef 'readtable)) + (typef 'readtable)) nil) diff --git a/ansi-tests/readtablep.lsp b/ansi-tests/readtablep.lsp index a93dac86..3626c075 100644 --- a/ansi-tests/readtablep.lsp +++ b/ansi-tests/readtablep.lsp @@ -7,29 +7,29 @@ (deftest readtablep.1 (and (not (readtablep nil)) - (not (readtablep 'a)) - (not (readtablep 0)) - (not (readtablep 1/2)) - (not (readtablep 1.2)) - (not (readtablep 1.2s2)) - (not (readtablep 1.2f3)) - (not (readtablep 1.2e2)) - (not (readtablep 1.2d2)) - (not (readtablep (list 'a))) - (not (readtablep "abcde")) - (not (readtablep t)) - (not (readtablep '*readtable*)) - (not (readtablep (make-array '(10)))) - (not (readtablep (make-array '(10) :element-type 'fixnum))) - (not (readtablep (make-array '(10) :element-type 'float))) - (not (readtablep (make-array '(10) :element-type 'double-float))) - (not (readtablep (make-array '(10) :element-type 'string))) - (not (readtablep (make-array '(10) :element-type 'character))) - (not (readtablep (make-array '(10) :element-type 'bit))) - (not (readtablep (make-array '(10) :element-type 'boolean))) - (not (not (readtablep (copy-readtable)))) - (not (readtablep #'car)) - ) + (not (readtablep 'a)) + (not (readtablep 0)) + (not (readtablep 1/2)) + (not (readtablep 1.2)) + (not (readtablep 1.2s2)) + (not (readtablep 1.2f3)) + (not (readtablep 1.2e2)) + (not (readtablep 1.2d2)) + (not (readtablep (list 'a))) + (not (readtablep "abcde")) + (not (readtablep t)) + (not (readtablep '*readtable*)) + (not (readtablep (make-array '(10)))) + (not (readtablep (make-array '(10) :element-type 'fixnum))) + (not (readtablep (make-array '(10) :element-type 'float))) + (not (readtablep (make-array '(10) :element-type 'double-float))) + (not (readtablep (make-array '(10) :element-type 'string))) + (not (readtablep (make-array '(10) :element-type 'character))) + (not (readtablep (make-array '(10) :element-type 'bit))) + (not (readtablep (make-array '(10) :element-type 'boolean))) + (not (not (readtablep (copy-readtable)))) + (not (readtablep #'car)) + ) t) (deftest readtablep.2 diff --git a/ansi-tests/real.lsp b/ansi-tests/real.lsp index ed659963..b25851cb 100644 --- a/ansi-tests/real.lsp +++ b/ansi-tests/real.lsp @@ -7,56 +7,56 @@ (deftest real.1 (loop for i = 1 then (ash i 1) - for tp = `(real 0 ,i) - repeat 200 - unless (and (not (typep -1 tp)) - (not (typep -0.0001 tp)) - (typep 0 tp) - (typep 0.0001 tp) - (typep 1 tp) - (typep i tp) - (not (typep (1+ i) tp))) - collect (list i tp)) + for tp = `(real 0 ,i) + repeat 200 + unless (and (not (typep -1 tp)) + (not (typep -0.0001 tp)) + (typep 0 tp) + (typep 0.0001 tp) + (typep 1 tp) + (typep i tp) + (not (typep (1+ i) tp))) + collect (list i tp)) nil) (deftest real.2 (loop for i = 1 then (ash i 1) - for tp = `(real ,(- i) 0) - repeat 200 - unless (and (not (typep (- -1 i) tp)) - (typep (- i) tp) - (typep -1 tp) - (typep 0 tp) - (not (typep 1 tp)) - (not (typep i tp)) - (not (typep (1+ i) tp))) - collect (list i tp)) + for tp = `(real ,(- i) 0) + repeat 200 + unless (and (not (typep (- -1 i) tp)) + (typep (- i) tp) + (typep -1 tp) + (typep 0 tp) + (not (typep 1 tp)) + (not (typep i tp)) + (not (typep (1+ i) tp))) + collect (list i tp)) nil) (deftest real.3 (loop for i = 4 then (ash i 1) - for tp = `(real 0 ,(/ i 3)) - repeat 200 - unless (and (not (typep -1 tp)) - (not (typep -0.0001 tp)) - (typep 0 tp) - (typep 0.0001 tp) - (typep 1 tp) - (typep (/ i 3) tp) - (not (typep (/ (1+ i) 3) tp))) - collect (list i tp)) + for tp = `(real 0 ,(/ i 3)) + repeat 200 + unless (and (not (typep -1 tp)) + (not (typep -0.0001 tp)) + (typep 0 tp) + (typep 0.0001 tp) + (typep 1 tp) + (typep (/ i 3) tp) + (not (typep (/ (1+ i) 3) tp))) + collect (list i tp)) nil) (deftest real.4 (loop for i = 4 then (ash i 1) - for tp = `(real ,(- (/ i 3)) 0) - repeat 200 - unless (and (not (typep (- -1 (/ i 3)) tp)) - (typep (- (/ i 3)) tp) - (typep -1 tp) - (typep 0 tp) - (not (typep 1 tp)) - (not (typep (/ i 3) tp)) - (not (typep (1+ (/ i 3)) tp))) - collect (list i tp)) + for tp = `(real ,(- (/ i 3)) 0) + repeat 200 + unless (and (not (typep (- -1 (/ i 3)) tp)) + (typep (- (/ i 3)) tp) + (typep -1 tp) + (typep 0 tp) + (not (typep 1 tp)) + (not (typep (/ i 3) tp)) + (not (typep (1+ (/ i 3)) tp))) + collect (list i tp)) nil) diff --git a/ansi-tests/realpart.lsp b/ansi-tests/realpart.lsp index c6198e24..6b3c487b 100644 --- a/ansi-tests/realpart.lsp +++ b/ansi-tests/realpart.lsp @@ -19,34 +19,34 @@ (deftest realpart.1 (loop for x in *reals* - for c = (complex x 0) - for rp = (realpart c) - unless (eql x rp) - collect (list x c rp)) + for c = (complex x 0) + for rp = (realpart c) + unless (eql x rp) + collect (list x c rp)) nil) (deftest realpart.2 (loop for x in *reals* - for c = (complex x 1) - for rp = (realpart c) - unless (eql x rp) - collect (list x c rp)) + for c = (complex x 1) + for rp = (realpart c) + unless (eql x rp) + collect (list x c rp)) nil) (deftest realpart.3 (loop for x in *reals* - for c = (complex x x) - for rp = (realpart c) - unless (eql x rp) - collect (list x c rp)) + for c = (complex x x) + for rp = (realpart c) + unless (eql x rp) + collect (list x c rp)) nil) ;;; Should move this to complex.lsp (deftest realpart.4 (loop for c in *complexes* - for rp = (realpart c) - for ip = (imagpart c) - for c2 = (complex rp ip) - unless (eql c c2) - collect (list c rp ip c2)) + for rp = (realpart c) + for ip = (imagpart c) + for c2 = (complex rp ip) + unless (eql c c2) + collect (list c rp ip c2)) nil) diff --git a/ansi-tests/reduce.lsp b/ansi-tests/reduce.lsp index 8f15549b..d421fd82 100644 --- a/ansi-tests/reduce.lsp +++ b/ansi-tests/reduce.lsp @@ -16,7 +16,7 @@ (deftest reduce-list.3 (reduce #'cons '(a b c d e f) :initial-value 'z) ((((((z . a) . b) . c) . d) . e) . f)) - + (deftest reduce-list.4 (reduce #'cons '(a b c d e f) :from-end t :initial-value 'g) (a b c d e f . g)) @@ -47,7 +47,7 @@ (deftest reduce-list.11 (reduce #'cons '(a b c d e f) :start 1 :end 4 :from-end t - :initial-value nil) + :initial-value nil) (b c d)) (deftest reduce-list.12 @@ -87,7 +87,7 @@ (deftest reduce-array.3 (reduce #'cons #(a b c d e f) :initial-value 'z) ((((((z . a) . b) . c) . d) . e) . f)) - + (deftest reduce-array.4 (reduce #'cons #(a b c d e f) :from-end t :initial-value 'g) (a b c d e f . g)) @@ -118,7 +118,7 @@ (deftest reduce-array.11 (reduce #'cons #(a b c d e f) :start 1 :end 4 :from-end t - :initial-value nil) + :initial-value nil) (b c d)) (deftest reduce-array.12 @@ -131,37 +131,37 @@ (deftest reduce-array.14 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 4))) + :fill-pointer 4))) (reduce #'+ a)) 10) (deftest reduce-array.15 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 4))) + :fill-pointer 4))) (reduce #'+ a :end nil)) 10) (deftest reduce-array.16 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 4))) + :fill-pointer 4))) (reduce #'+ a :from-end t)) 10) (deftest reduce-array.17 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 4))) + :fill-pointer 4))) (reduce #'+ a :initial-value 1)) 11) (deftest reduce-array.18 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 4))) + :fill-pointer 4))) (reduce #'+ a :initial-value 1 :start 2)) 8) (deftest reduce-array.19 (let ((a (make-array '(8) :initial-contents '(1 2 3 4 5 6 7 8) - :fill-pointer 4))) + :fill-pointer 4))) (reduce #'+ a :end 3)) 6) @@ -177,7 +177,7 @@ (do-special-integer-vectors (v #(1 0 0 1 1 0) nil) (assert (equal (reduce #'cons v :from-end t :initial-value nil) - '(1 0 0 1 1 0)))) + '(1 0 0 1 1 0)))) nil) (deftest reduce-array.22 @@ -192,26 +192,26 @@ (deftest reduce-array.23 (let* ((len 10) - (expected (* 1/2 (1+ len) len))) + (expected (* 1/2 (1+ len) len))) (loop for etype in '(short-float single-float double-float long-float) - for vals = (loop for i from 1 to len collect (coerce i etype)) - for vec = (make-array len :initial-contents vals :element-type etype) - for result = (reduce #'+ vec) - unless (= result (coerce expected etype)) - collect (list etype vals vec result))) + for vals = (loop for i from 1 to len collect (coerce i etype)) + for vec = (make-array len :initial-contents vals :element-type etype) + for result = (reduce #'+ vec) + unless (= result (coerce expected etype)) + collect (list etype vals vec result))) nil) (deftest reduce-array.24 (let* ((len 10) - (expected (* 1/2 (1+ len) len))) + (expected (* 1/2 (1+ len) len))) (loop for cetype in '(short-float single-float double-float long-float) - for etype = `(complex ,cetype) - for vals = (loop for i from 1 to len collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for vec = (make-array len :initial-contents vals :element-type etype) - for result = (reduce #'+ vec) - unless (= result (complex (coerce expected cetype) (coerce (- expected) cetype))) - collect (list etype vals vec result))) + for etype = `(complex ,cetype) + for vals = (loop for i from 1 to len collect (complex (coerce i cetype) + (coerce (- i) cetype))) + for vec = (make-array len :initial-contents vals :element-type etype) + for result = (reduce #'+ vec) + unless (= result (complex (coerce expected cetype) (coerce (- expected) cetype))) + collect (list etype vals vec result))) nil) (deftest reduce-array.25 @@ -276,7 +276,7 @@ (deftest reduce-string.3 (reduce #'cons "abcdef" :initial-value 'z) ((((((z . #\a) . #\b) . #\c) . #\d) . #\e) . #\f)) - + (deftest reduce-string.4 (reduce #'cons "abcdef" :from-end t :initial-value 'g) (#\a #\b #\c #\d #\e #\f . g)) @@ -307,7 +307,7 @@ (deftest reduce-string.11 (reduce #'cons "abcdef" :start 1 :end 4 :from-end t - :initial-value nil) + :initial-value nil) (#\b #\c #\d)) (deftest reduce-string.12 @@ -320,37 +320,37 @@ (deftest reduce-string.14 (let ((s (make-array '(8) :initial-contents "abcdefgh" - :fill-pointer 6 - :element-type 'character))) + :fill-pointer 6 + :element-type 'character))) (coerce (reduce #'(lambda (x y) (cons y x)) s :initial-value nil) - 'string)) + 'string)) "fedcba") (deftest reduce-string.15 (let ((s (make-array '(8) :initial-contents "abcdefgh" - :fill-pointer 6 - :element-type 'character))) + :fill-pointer 6 + :element-type 'character))) (coerce (reduce #'(lambda (x y) (cons y x)) s :initial-value nil - :start 1) - 'string)) + :start 1) + 'string)) "fedcb") (deftest reduce-string.16 (let ((s (make-array '(8) :initial-contents "abcdefgh" - :fill-pointer 6 - :element-type 'character))) - (coerce (reduce #'(lambda (x y) (cons y x)) s :end nil - :initial-value nil) - 'string)) + :fill-pointer 6 + :element-type 'character))) + (coerce (reduce #'(lambda (x y) (cons y x)) s :end nil + :initial-value nil) + 'string)) "fedcba") (deftest reduce-string.17 (let ((s (make-array '(8) :initial-contents "abcdefgh" - :fill-pointer 6 - :element-type 'character))) - (coerce (reduce #'(lambda (x y) (cons y x)) s :end 4 - :initial-value nil) - 'string)) + :fill-pointer 6 + :element-type 'character))) + (coerce (reduce #'(lambda (x y) (cons y x)) s :end 4 + :initial-value nil) + 'string)) "dcba") (deftest reduce-string.18 @@ -387,7 +387,7 @@ (deftest reduce-bitstring.3 (reduce #'cons #*001101 :initial-value 'z) ((((((z . 0) . 0) . 1) . 1) . 0) . 1)) - + (deftest reduce-bitstring.4 (reduce #'cons #*001101 :from-end t :initial-value 'g) (0 0 1 1 0 1 . g)) @@ -418,7 +418,7 @@ (deftest reduce-bitstring.11 (reduce #'cons #*001101 :start 1 :end 4 :from-end t - :initial-value nil) + :initial-value nil) (0 1 1)) (deftest reduce-bitstring.12 @@ -431,36 +431,36 @@ (deftest reduce-bitstring.14 (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) - :fill-pointer 6 - :element-type 'bit))) + :fill-pointer 6 + :element-type 'bit))) (reduce #'+ s)) 3) (deftest reduce-bitstring.15 (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) - :fill-pointer 6 - :element-type 'bit))) + :fill-pointer 6 + :element-type 'bit))) (reduce #'+ s :start 3)) 2) (deftest reduce-bitstring.16 (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) - :fill-pointer 6 - :element-type 'bit))) + :fill-pointer 6 + :element-type 'bit))) (reduce #'+ s :start 3 :initial-value 10)) 12) (deftest reduce-bitstring.17 (let ((s (make-array '(8) :initial-contents '(0 0 1 0 1 1 0 1) - :fill-pointer 6 - :element-type 'bit))) + :fill-pointer 6 + :element-type 'bit))) (reduce #'+ s :end nil)) 3) (deftest reduce-bitstring.18 (let ((s (make-array '(8) :initial-contents '(1 1 1 1 1 1 1 1) - :fill-pointer 6 - :element-type 'bit))) + :fill-pointer 6 + :element-type 'bit))) (reduce #'+ s :start 2 :end 4)) 2) @@ -470,7 +470,7 @@ (let ((i 0) x y) (values (reduce (progn (setf x (incf i)) #'cons) - (progn (setf y (incf i)) '(a b c))) + (progn (setf y (incf i)) '(a b c))) i x y)) ((a . b) . c) 2 1 2) @@ -478,13 +478,13 @@ (let ((i 0) a b c d e f g) (values (reduce (progn (setf a (incf i)) #'cons) - (progn (setf b (incf i)) '(a b c d e f)) - :from-end (progn (setf c (incf i)) t) - :initial-value (progn (setf d (incf i)) 'nil) - :start (progn (setf e (incf i)) 1) - :end (progn (setf f (incf i)) 4) - :key (progn (setf g (incf i)) #'identity) - ) + (progn (setf b (incf i)) '(a b c d e f)) + :from-end (progn (setf c (incf i)) t) + :initial-value (progn (setf d (incf i)) 'nil) + :start (progn (setf e (incf i)) 1) + :end (progn (setf f (incf i)) 4) + :key (progn (setf g (incf i)) #'identity) + ) i a b c d e f g)) (b c d) 7 1 2 3 4 5 6 7) @@ -492,13 +492,13 @@ (let ((i 0) a b c d e f g) (values (reduce (progn (setf a (incf i)) #'cons) - (progn (setf b (incf i)) '(a b c d e f)) - :key (progn (setf c (incf i)) #'identity) - :end (progn (setf d (incf i)) 4) - :start (progn (setf e (incf i)) 1) - :initial-value (progn (setf f (incf i)) 'nil) - :from-end (progn (setf g (incf i)) t) - ) + (progn (setf b (incf i)) '(a b c d e f)) + :key (progn (setf c (incf i)) #'identity) + :end (progn (setf d (incf i)) 4) + :start (progn (setf e (incf i)) 1) + :initial-value (progn (setf f (incf i)) 'nil) + :from-end (progn (setf g (incf i)) t) + ) i a b c d e f g)) (b c d) 7 1 2 3 4 5 6 7) @@ -535,11 +535,11 @@ (deftest reduce.allow-other-keys.8 (reduce #'cons '(1 2 3) :allow-other-keys t :from-end t :bad t - :initial-value nil) + :initial-value nil) (1 2 3)) (deftest reduce.keywords.9 (reduce #'cons '(1 2 3) :from-end t :from-end nil - :initial-value nil :initial-value 'a) + :initial-value nil :initial-value 'a) (1 2 3)) diff --git a/ansi-tests/reinitialize-instance.lsp b/ansi-tests/reinitialize-instance.lsp index 310c7b18..952b034a 100644 --- a/ansi-tests/reinitialize-instance.lsp +++ b/ansi-tests/reinitialize-instance.lsp @@ -9,7 +9,7 @@ (deftest reinitialize-instance.1 (let* ((obj (make-instance 'class-01)) - (obj2 (reinitialize-instance obj))) + (obj2 (reinitialize-instance obj))) (values (eqt obj obj2) (map-slot-boundp* obj '(s1 s2 s3)))) @@ -18,7 +18,7 @@ (deftest reinitialize-instance.2 (let* ((obj (make-instance 'class-01)) - (obj2 (reinitialize-instance obj :allow-other-keys nil))) + (obj2 (reinitialize-instance obj :allow-other-keys nil))) (values (eqt obj obj2) (map-slot-boundp* obj '(s1 s2 s3)))) @@ -26,7 +26,7 @@ (deftest reinitialize-instance.3 (let* ((obj (make-instance 'class-01)) - (obj2 (reinitialize-instance obj :allow-other-keys t))) + (obj2 (reinitialize-instance obj :allow-other-keys t))) (values (eqt obj obj2) (map-slot-boundp* obj '(s1 s2 s3)))) @@ -34,8 +34,8 @@ (deftest reinitialize-instance.4 (let* ((obj (make-instance 'class-01)) - (obj2 (reinitialize-instance obj :allow-other-keys t - :allow-other-keys nil))) + (obj2 (reinitialize-instance obj :allow-other-keys t + :allow-other-keys nil))) (values (eqt obj obj2) (map-slot-boundp* obj '(s1 s2 s3)))) @@ -43,8 +43,8 @@ (deftest reinitialize-instance.5 (let* ((obj (make-instance 'class-07)) - (obj2 (reinitialize-instance obj :s1a 'a :s2 'b :s1a 'bad - :s2 'bad2 :s1b 'bad3))) + (obj2 (reinitialize-instance obj :s1a 'a :s2 'b :s1a 'bad + :s2 'bad2 :s1b 'bad3))) (values (eqt obj obj2) (map-slot-value obj '(s1 s2)))) @@ -52,7 +52,7 @@ (deftest reinitialize-instance.6 (let* ((obj (make-instance 'class-07 :s1a 'a)) - (obj2 (reinitialize-instance obj :s1b 'b))) + (obj2 (reinitialize-instance obj :s1b 'b))) (values (eqt obj obj2) (slot-value obj 's1) @@ -61,7 +61,7 @@ (deftest reinitialize-instance.7 (let* ((obj (make-instance 'class-07 :s1a 'a)) - (obj2 (reinitialize-instance obj :s2 'b))) + (obj2 (reinitialize-instance obj :s2 'b))) (values (eqt obj obj2) (slot-value obj 's1) @@ -75,15 +75,15 @@ ((a :initarg :a) (b :initarg :b))) (defmethod reinitialize-instance :after ((instance reinit-class-01) - &rest initargs - &key (x nil x-p)) + &rest initargs + &key (x nil x-p)) (declare (ignore initargs)) (when x-p (setf (slot-value instance 'a) x)) instance) (deftest reinitialize-instance.8 (let* ((obj (make-instance 'reinit-class-01)) - (obj2 (reinitialize-instance obj :a 1 :b 3))) + (obj2 (reinitialize-instance obj :a 1 :b 3))) (values (eqt obj obj2) (map-slot-value obj2 '(a b)))) @@ -91,7 +91,7 @@ (deftest reinitialize-instance.9 (let* ((obj (make-instance 'reinit-class-01 :a 10 :b 20)) - (obj2 (reinitialize-instance obj :x 3))) + (obj2 (reinitialize-instance obj :x 3))) (values (eqt obj obj2) (map-slot-value obj2 '(a b)))) @@ -99,7 +99,7 @@ (deftest reinitialize-instance.10 (let* ((obj (make-instance 'reinit-class-01 :a 10 :b 20)) - (obj2 (reinitialize-instance obj :x 3 :x 100))) + (obj2 (reinitialize-instance obj :x 3 :x 100))) (values (eqt obj obj2) (map-slot-value obj2 '(a b)))) @@ -109,12 +109,12 @@ (deftest reinitialize-instance.order.1 (let* ((obj (make-instance 'reinit-class-01)) - (i 0) x y z w - (obj2 (reinitialize-instance - (progn (setf x (incf i)) obj) - :b (setf y (incf i)) - :a (setf z (incf i)) - :b (setf w (incf i))))) + (i 0) x y z w + (obj2 (reinitialize-instance + (progn (setf x (incf i)) obj) + :b (setf y (incf i)) + :a (setf z (incf i)) + :b (setf w (incf i))))) (values (eqt obj obj2) (map-slot-value obj2 '(a b)) diff --git a/ansi-tests/remf.lsp b/ansi-tests/remf.lsp index 876cecd6..5b8dc450 100644 --- a/ansi-tests/remf.lsp +++ b/ansi-tests/remf.lsp @@ -65,20 +65,20 @@ (deftest remf.order.1 (let ((i 0) x y - (p (make-array 1 :initial-element (copy-list '(a b c d e f))))) + (p (make-array 1 :initial-element (copy-list '(a b c d e f))))) (values (notnot (remf (aref p (progn (setf x (incf i)) 0)) - (progn (setf y (incf i)) - 'c))) + (progn (setf y (incf i)) + 'c))) (aref p 0) i x y)) t (a b e f) 2 1 2) (deftest remf.order.2 (let ((x (copy-seq #(nil :a :b))) - (pa (vector (list :a 1) (list :b 2) (list :c 3) (list :d 4))) - (i 0)) + (pa (vector (list :a 1) (list :b 2) (list :c 3) (list :d 4))) + (i 0)) (values (not (remf (aref pa (incf i)) (aref x (incf i)))) pa)) diff --git a/ansi-tests/remhash.lsp b/ansi-tests/remhash.lsp index 7b5a1a49..24492ea7 100644 --- a/ansi-tests/remhash.lsp +++ b/ansi-tests/remhash.lsp @@ -8,41 +8,41 @@ (deftest remhash.1 (let ((table (make-hash-table))) (values (gethash 'a table) - (remhash 'a table) - (setf (gethash 'a table) 'b) - (gethash 'a table) - (notnot (remhash 'a table)) - (gethash 'a table))) + (remhash 'a table) + (setf (gethash 'a table) 'b) + (gethash 'a table) + (notnot (remhash 'a table)) + (gethash 'a table))) nil nil b b t nil) (deftest remhash.2 (let ((table (make-hash-table :test 'eq))) (values (gethash 'a table) - (remhash 'a table) - (setf (gethash 'a table) 'b) - (gethash 'a table) - (notnot (remhash 'a table)) - (gethash 'a table))) + (remhash 'a table) + (setf (gethash 'a table) 'b) + (gethash 'a table) + (notnot (remhash 'a table)) + (gethash 'a table))) nil nil b b t nil) (deftest remhash.3 (let ((table (make-hash-table :test 'equal))) (values (gethash 'a table) - (remhash 'a table) - (setf (gethash 'a table) 'b) - (gethash 'a table) - (notnot (remhash 'a table)) - (gethash 'a table))) + (remhash 'a table) + (setf (gethash 'a table) 'b) + (gethash 'a table) + (notnot (remhash 'a table)) + (gethash 'a table))) nil nil b b t nil) (deftest remhash.4 (let ((table (make-hash-table :test 'equalp))) (values (gethash 'a table) - (remhash 'a table) - (setf (gethash 'a table) 'b) - (gethash 'a table) - (notnot (remhash 'a table)) - (gethash 'a table))) + (remhash 'a table) + (setf (gethash 'a table) 'b) + (gethash 'a table) + (notnot (remhash 'a table)) + (gethash 'a table))) nil nil b b t nil) (deftest remhash.5 @@ -51,15 +51,15 @@ (deftest remhash.6 (notnot-mv (remhash nil (let ((table (make-hash-table))) - (setf (gethash nil table) t) - table))) + (setf (gethash nil table) t) + table))) t) (deftest remhash.order.1 (let ((i 0) x y) (values (remhash (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) (make-hash-table))) + (progn (setf y (incf i)) (make-hash-table))) i x y)) nil 2 1 2) @@ -83,4 +83,4 @@ - + diff --git a/ansi-tests/remove-aux.lsp b/ansi-tests/remove-aux.lsp index 2910f6a4..94a1ebc9 100644 --- a/ansi-tests/remove-aux.lsp +++ b/ansi-tests/remove-aux.lsp @@ -10,10 +10,10 @@ ((subtypep* 'fixnum type) (random most-positive-fixnum)) ((and (listp type) - (eql (car type) 'integer) - (integerp (cadr type)) - (integerp (caddr type)) - (null (cdddr type))) + (eql (car type) 'integer) + (integerp (cadr type)) + (integerp (caddr type)) + (null (cdddr type))) (+ (cadr type) (random (- (1+ (caddr type)) (cadr type))))) ((subtypep* '(integer 0 255) type) (random 255)) @@ -34,61 +34,61 @@ sequence of length LEN of sequence type TYPE, and either generate a random member of the sequence or a random element of the element type to delete from the sequence." - + (let* ((seq (if (subtypep* type 'list) - (loop for i from 1 to len collect - (make-random-element element-type)) - (let ((seq (if (and (subtypep type 'vector) - (coin 3)) - (make-array - (list (+ len (random (1+ len)))) - :initial-element (make-random-element element-type) - :fill-pointer len - :element-type element-type) - (make-sequence type len)))) - (dotimes (i len) - (setf (elt seq i) (make-random-element element-type))) - seq))) - (e (if (and (> len 0) (coin)) - (elt seq (random len)) - (make-random-element element-type))) - ) + (loop for i from 1 to len collect + (make-random-element element-type)) + (let ((seq (if (and (subtypep type 'vector) + (coin 3)) + (make-array + (list (+ len (random (1+ len)))) + :initial-element (make-random-element element-type) + :fill-pointer len + :element-type element-type) + (make-sequence type len)))) + (dotimes (i len) + (setf (elt seq i) (make-random-element element-type))) + seq))) + (e (if (and (> len 0) (coin)) + (elt seq (random len)) + (make-random-element element-type))) + ) (values len seq e))) (defun my-remove (element - sequence - &key - (start 0) - (end nil) - (test #'eql test-p) - (test-not nil test-not-p) - (key nil) - (from-end nil) - (count nil)) + sequence + &key + (start 0) + (end nil) + (test #'eql test-p) + (test-not nil test-not-p) + (key nil) + (from-end nil) + (count nil)) (assert (not (and test-p test-not-p))) (my-remove-if (cond (test-p - (setf test (coerce test 'function)) - #'(lambda (x) (funcall (the function test) element x))) - (test-not-p - (setf test-not (coerce test-not 'function)) - #'(lambda (x) (not (funcall (the function test-not) element x)))) - (t #'(lambda (x) (eql element x)))) + (setf test (coerce test 'function)) + #'(lambda (x) (funcall (the function test) element x))) + (test-not-p + (setf test-not (coerce test-not 'function)) + #'(lambda (x) (not (funcall (the function test-not) element x)))) + (t #'(lambda (x) (eql element x)))) sequence :start start :end end :key key :from-end from-end :count count)) - + (defun my-remove-if (predicate - original-sequence - &key (from-end nil) - (start 0) - (end nil) - (count nil) - (key #'identity)) + original-sequence + &key (from-end nil) + (start 0) + (end nil) + (count nil) + (key #'identity)) (let ((len (length original-sequence)) - (sequence (copy-seq original-sequence))) + (sequence (copy-seq original-sequence))) (unless end (setq end len)) (unless key (setq key #'identity)) (unless count (setq count len)) - + ;; Check that everything's kosher (assert (<= 0 start end len)) (assert (typep sequence 'sequence)) @@ -98,36 +98,36 @@ (setf predicate (coerce predicate 'function)) (setf key (coerce key 'function)) - + ;; If FROM-END, reverse the sequence and flip ;; start, end (when from-end (psetq sequence (nreverse sequence) - start (- len end) - end (- len start))) + start (- len end) + end (- len start))) ;; Accumulate a list of elements for the result (let ((pos 0) - (result nil)) ;; accumulate in reverse order + (result nil)) ;; accumulate in reverse order (map nil - #'(lambda (e) - (if (and (> count 0) - (>= pos start) - (< pos end) - (funcall (the function predicate) - (funcall (the function key) e))) - (decf count) - (push e result)) - (incf pos)) - sequence) + #'(lambda (e) + (if (and (> count 0) + (>= pos start) + (< pos end) + (funcall (the function predicate) + (funcall (the function key) e))) + (decf count) + (push e result)) + (incf pos)) + sequence) (unless from-end - (setq result (nreverse result))) + (setq result (nreverse result))) ;; Convert to the correct type (if (listp sequence) - result - (let ((element-type (array-element-type original-sequence))) - (make-array (length result) :element-type element-type - :initial-contents result)))))) + result + (let ((element-type (array-element-type original-sequence))) + (make-array (length result) :element-type element-type + :initial-contents result)))))) (defun my-remove-if-not (pred &rest args) (when (symbolp pred) @@ -138,53 +138,53 @@ (defun make-random-rd-params (maxlen) "Generate random paramaters for remove/delete/etc. functions." (let* ((element-type - (rcase - (2 t) - (1 'bit) - (1 '(integer 0 2)) - (1 'symbol))) - (type-select (random 7)) - (type - (case type-select - (0 'list) - (1 'vector) - (2 (setq element-type 'character) 'string) - (3 (setq element-type 'bit) 'bit-vector) - (4 'simple-vector) - (5 (setq element-type '(integer 0 255)) - '(vector (integer 0 255))) - (6 (setq element-type 'fixnum) '(vector fixnum)) - (t (error "Can't happen?!~%")))) - (len (random maxlen)) - (start (and (coin) (> len 0) - (random len))) - (end (and (coin) - (if start (+ start (random (- len start))) - (random (1+ len))))) - (from-end (coin)) - (count (case (random 5) - ((0 1) nil) - ((2 3) (random (1+ len))) - (t (if (coin) -1 -10000000000000)))) - (seq (multiple-value-bind (x y z) (make-random-remove-input len type element-type) - (declare (ignore x z)) - y)) - (key (and (coin) - (case type-select - (2 (random-case - #'char-upcase 'char-upcase - #'char-downcase 'char-downcase)) - (3 #'(lambda (x) (- 1 x))) - ((5 6) (random-case #'1+ '1+ #'1- '1-)) - (t (random-case 'identity #'identity))))) - (test (and (eql (random 3) 0) - (random-case 'eq 'eql 'equal - #'eq #'eql #'equal))) - (test-not (and (not test) - (coin) - (random-case 'eq 'eql 'equal - #'eq #'eql #'equal))) - ) + (rcase + (2 t) + (1 'bit) + (1 '(integer 0 2)) + (1 'symbol))) + (type-select (random 7)) + (type + (case type-select + (0 'list) + (1 'vector) + (2 (setq element-type 'character) 'string) + (3 (setq element-type 'bit) 'bit-vector) + (4 'simple-vector) + (5 (setq element-type '(integer 0 255)) + '(vector (integer 0 255))) + (6 (setq element-type 'fixnum) '(vector fixnum)) + (t (error "Can't happen?!~%")))) + (len (random maxlen)) + (start (and (coin) (> len 0) + (random len))) + (end (and (coin) + (if start (+ start (random (- len start))) + (random (1+ len))))) + (from-end (coin)) + (count (case (random 5) + ((0 1) nil) + ((2 3) (random (1+ len))) + (t (if (coin) -1 -10000000000000)))) + (seq (multiple-value-bind (x y z) (make-random-remove-input len type element-type) + (declare (ignore x z)) + y)) + (key (and (coin) + (case type-select + (2 (random-case + #'char-upcase 'char-upcase + #'char-downcase 'char-downcase)) + (3 #'(lambda (x) (- 1 x))) + ((5 6) (random-case #'1+ '1+ #'1- '1-)) + (t (random-case 'identity #'identity))))) + (test (and (eql (random 3) 0) + (random-case 'eq 'eql 'equal + #'eq #'eql #'equal))) + (test-not (and (not test) + (coin) + (random-case 'eq 'eql 'equal + #'eq #'eql #'equal))) + ) ;; Return parameters (values element-type type len start end from-end count seq key test test-not))) @@ -194,39 +194,39 @@ (make-random-rd-params maxlen) (declare (ignore type)) (let ((element (if (and (coin) (> len 0)) - (random-from-seq seq) - (make-random-element element-type))) - (arg-list - (reduce #'nconc - (random-permute - (list - (when start (list :start start)) - (cond (end (list :end end)) - ((coin) (list :end nil))) - (cond (from-end (list :from-end from-end)) - ((coin) (list :from-end nil))) - (cond (count (list :count count)) - ((coin) (list :count nil))) - (cond (key (list :key key)) - ;; ((coin) (list :key nil)) - ) - (when test (list :test test)) - (when test-not (list :test test-not))))))) + (random-from-seq seq) + (make-random-element element-type))) + (arg-list + (reduce #'nconc + (random-permute + (list + (when start (list :start start)) + (cond (end (list :end end)) + ((coin) (list :end nil))) + (cond (from-end (list :from-end from-end)) + ((coin) (list :from-end nil))) + (cond (count (list :count count)) + ((coin) (list :count nil))) + (cond (key (list :key key)) + ;; ((coin) (list :key nil)) + ) + (when test (list :test test)) + (when test-not (list :test test-not))))))) (values element seq arg-list)))) (defparameter *remove-fail-args* nil) (defun random-test-remove (maxlen &key (tested-fn #'remove) - (check-fn #'my-remove) - (pure t)) + (check-fn #'my-remove) + (pure t)) (setf tested-fn (coerce tested-fn 'function)) (setf check-fn (coerce check-fn 'function)) (multiple-value-bind (element seq arg-list) (random-test-remove-args maxlen) (let* ((seq1 (copy-seq seq)) - (seq2 (copy-seq seq)) - (seq1r (apply (the function tested-fn) element seq1 arg-list)) - (seq2r (apply (the function check-fn) element seq2 arg-list))) + (seq2 (copy-seq seq)) + (seq1r (apply (the function tested-fn) element seq1 arg-list)) + (seq2r (apply (the function check-fn) element seq2 arg-list))) (setq *remove-fail-args* (list* element seq arg-list)) (cond ((and pure (not (equalp seq seq1))) :fail1) @@ -238,32 +238,32 @@ (multiple-value-bind (element seq arg-list) (random-test-remove-args maxlen) (let ((fn (getf arg-list :key)) - (test (getf arg-list :test))) + (test (getf arg-list :test))) (remf arg-list :key) (remf arg-list :test) (remf arg-list :test-not) (unless test (setq test #'eql)) (setf test (coerce test 'function)) (if fn - (case (random 3) - (0 (setf arg-list (list* :key 'identity arg-list))) - (1 (setf arg-list (list* :key #'identity arg-list))) - (t nil)) - (setf fn (if (coin) 'identity - #'(lambda (x) (funcall (the function test) - element x))))) + (case (random 3) + (0 (setf arg-list (list* :key 'identity arg-list))) + (1 (setf arg-list (list* :key #'identity arg-list))) + (t nil)) + (setf fn (if (coin) 'identity + #'(lambda (x) (funcall (the function test) + element x))))) (let* ((seq1 (copy-seq seq)) - (seq2 (copy-seq seq)) - (seq1r (apply (if negate #'remove-if-not #'remove-if) - fn seq1 arg-list)) - (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) - fn seq2 arg-list))) - (setq *remove-fail-args* (cons seq1 arg-list)) - (cond - ((not (equalp seq seq1)) :fail1) - ((not (equalp seq seq2)) :fail2) - ((not (equalp seq1r seq2r)) :fail3) - (t t)))))) + (seq2 (copy-seq seq)) + (seq1r (apply (if negate #'remove-if-not #'remove-if) + fn seq1 arg-list)) + (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) + fn seq2 arg-list))) + (setq *remove-fail-args* (cons seq1 arg-list)) + (cond + ((not (equalp seq seq1)) :fail1) + ((not (equalp seq seq2)) :fail2) + ((not (equalp seq1r seq2r)) :fail3) + (t t)))))) (defun random-test-delete (maxlen) (random-test-remove maxlen :tested-fn #'delete :pure nil)) @@ -272,26 +272,26 @@ (multiple-value-bind (element seq arg-list) (random-test-remove-args maxlen) (let ((fn (getf arg-list :key)) - (test (getf arg-list :test))) + (test (getf arg-list :test))) (remf arg-list :key) (remf arg-list :test) (remf arg-list :test-not) (unless test (setq test #'eql)) (setf test (coerce test 'function)) (if fn - (case (random 3) - (0 (setf arg-list (list* :key 'identity arg-list))) - (1 (setf arg-list (list* :key #'identity arg-list))) - (t nil)) - (setf fn (if (coin) 'identity - #'(lambda (x) (funcall (the function test) element x))))) + (case (random 3) + (0 (setf arg-list (list* :key 'identity arg-list))) + (1 (setf arg-list (list* :key #'identity arg-list))) + (t nil)) + (setf fn (if (coin) 'identity + #'(lambda (x) (funcall (the function test) element x))))) (setq *remove-fail-args* (list* seq arg-list)) (let* ((seq1 (copy-seq seq)) - (seq2 (copy-seq seq)) - (seq1r (apply (if negate #'delete-if-not #'delete-if) - fn seq1 arg-list)) - (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) - fn seq2 arg-list))) - (cond - ((not (equalp seq1r seq2r)) :fail3) - (t t)))))) + (seq2 (copy-seq seq)) + (seq1r (apply (if negate #'delete-if-not #'delete-if) + fn seq1 arg-list)) + (seq2r (apply (if negate #'my-remove-if-not #'my-remove-if) + fn seq2 arg-list))) + (cond + ((not (equalp seq1r seq2r)) :fail3) + (t t)))))) diff --git a/ansi-tests/remove-duplicates-aux.lsp b/ansi-tests/remove-duplicates-aux.lsp index cca014ed..0207d329 100644 --- a/ansi-tests/remove-duplicates-aux.lsp +++ b/ansi-tests/remove-duplicates-aux.lsp @@ -6,85 +6,85 @@ (in-package :cl-test) (defun my-remove-duplicates (orig-sequence - &key from-end test test-not (start 0) end key) + &key from-end test test-not (start 0) end key) (assert (typep orig-sequence 'sequence)) (let* ((sequence orig-sequence) - (len (length sequence))) + (len (length sequence))) (unless end (setq end len)) (unless key (setq key #'identity)) (setf key (coerce key 'function)) (cond (test (setf test (coerce test 'function)) - (assert (not test-not))) + (assert (not test-not))) (test-not (setf test-not (coerce test-not 'function)) - (setq test #'(lambda (x y) - (not (funcall (the function test) x y))))) + (setq test #'(lambda (x y) + (not (funcall (the function test) x y))))) (t (setq test #'eql))) (assert (integerp start)) (assert (integerp end)) (assert (<= 0 start end len)) ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len) (if from-end - (psetq start (- len end) - end (- len start) - sequence (reverse sequence)) - (setq sequence (copy-seq sequence))) + (psetq start (- len end) + end (- len start) + sequence (reverse sequence)) + (setq sequence (copy-seq sequence))) ;; (format t "start = ~A, end = ~A, len = ~A~%" start end len) (assert (<= 0 start end len) (start end len)) (let ((result nil)) (loop for i from 0 below start - do (push (elt sequence i) result)) + do (push (elt sequence i) result)) (loop for i from start below end - for x = (elt sequence i) - for kx = (funcall (the function key) x) - unless (position kx - sequence - :start (1+ i) - :end end - :test (the function test) - :key (the function key)) - do (push x result)) + for x = (elt sequence i) + for kx = (funcall (the function key) x) + unless (position kx + sequence + :start (1+ i) + :end end + :test (the function test) + :key (the function key)) + do (push x result)) (loop for i from end below len - do (push (elt sequence i) result)) + do (push (elt sequence i) result)) (unless from-end (setq result (reverse result))) (cond - ((listp orig-sequence) result) - ((arrayp orig-sequence) - (make-array (length result) :initial-contents result - :element-type (array-element-type orig-sequence))) - (t (assert nil)))))) + ((listp orig-sequence) result) + ((arrayp orig-sequence) + (make-array (length result) :initial-contents result + :element-type (array-element-type orig-sequence))) + (t (assert nil)))))) (defun make-random-rdup-params (maxlen) "Make random input parameters for REMOVE-DUPLICATES." (multiple-value-bind (element-type type len start end from-end - count seq key test test-not) + count seq key test test-not) (make-random-rd-params maxlen) (declare (ignore count element-type len type)) (let ((arg-list - (reduce #'nconc - (random-permute - (list - (when start (list :start start)) - (cond (end (list :end end)) - ((coin) (list :end nil))) - (cond (from-end (list :from-end from-end)) - ((coin) (list :from-end nil))) - (cond (key (list :key key)) - ;; ((coin) (list :key nil)) - ) - (when test (list :test test)) - (when test-not (list :test test-not))))))) + (reduce #'nconc + (random-permute + (list + (when start (list :start start)) + (cond (end (list :end end)) + ((coin) (list :end nil))) + (cond (from-end (list :from-end from-end)) + ((coin) (list :from-end nil))) + (cond (key (list :key key)) + ;; ((coin) (list :key nil)) + ) + (when test (list :test test)) + (when test-not (list :test test-not))))))) (values seq arg-list)))) (defun random-test-remove-dups (maxlen &optional (pure t)) (multiple-value-bind (seq arg-list) (make-random-rdup-params maxlen) (let* ((seq1 (copy-seq seq)) - (seq2 (copy-seq seq)) - (seq1r (apply (if pure #'remove-duplicates - #'delete-duplicates) - seq1 arg-list)) - (seq2r (apply #'my-remove-duplicates seq2 arg-list))) + (seq2 (copy-seq seq)) + (seq1r (apply (if pure #'remove-duplicates + #'delete-duplicates) + seq1 arg-list)) + (seq2r (apply #'my-remove-duplicates seq2 arg-list))) (cond ((and pure (not (equalp seq seq1))) (list :fail1 seq seq1r seq2r arg-list)) ((and pure (not (equalp seq seq2))) (list :fail2 seq seq1r seq2r arg-list)) diff --git a/ansi-tests/remove-duplicates.lsp b/ansi-tests/remove-duplicates.lsp index 90d61b54..51b041f0 100644 --- a/ansi-tests/remove-duplicates.lsp +++ b/ansi-tests/remove-duplicates.lsp @@ -10,49 +10,49 @@ (deftest random-remove-duplicates (loop for result = (random-test-remove-dups (1+ (random 20))) - repeat 1000 - unless (eq result t) - collect result) + repeat 1000 + unless (eq result t) + collect result) nil) (deftest random-delete-duplicates (loop for result = (random-test-remove-dups (1+ (random 20)) nil) - repeat 1000 - unless (eq result t) - collect result) + repeat 1000 + unless (eq result t) + collect result) nil) ;;; Look for :KEY NIL bugs (deftest remove-duplicates.1 (let* ((orig '(1 2 3 4 1 3 4 1 2 5 6 2 7)) - (x (copy-seq orig)) - (y (remove-duplicates x :key nil))) + (x (copy-seq orig)) + (y (remove-duplicates x :key nil))) (and (equalp orig x) y)) (3 4 1 5 6 2 7)) (deftest delete-duplicates.1 (let* ((orig '(1 2 3 4 1 3 4 1 2 5 6 2 7)) - (x (copy-seq orig)) - (y (delete-duplicates x :key nil))) + (x (copy-seq orig)) + (y (delete-duplicates x :key nil))) y) (3 4 1 5 6 2 7)) (defharmless remove-duplicates.test-and-test-not.1 (remove-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test #'eql - :test-not #'eql)) + :test-not #'eql)) (defharmless remove-duplicates.test-and-test-not.2 (remove-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test-not #'eql - :test #'eql)) + :test #'eql)) (defharmless delete-duplicates.test-and-test-not.1 (delete-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test #'eql - :test-not #'eql)) + :test-not #'eql)) (defharmless delete-duplicates.test-and-test-not.2 (delete-duplicates (list 'a 'b 'c 'd 'a 'e 'f 'd 'g) :test-not #'eql - :test #'eql)) + :test #'eql)) ;;; Const fold tests @@ -90,7 +90,7 @@ ) i a b c d e f)) (3 1 2 4) 6 1 2 3 4 5 6) - + ;;; Keyword tests @@ -112,22 +112,22 @@ (deftest remove-duplicates.allow-other-keys.5 (remove-duplicates '(1 2 3 4 2 7 8 1 5) :bad t - :allow-other-keys t :allow-other-keys nil) + :allow-other-keys t :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.6 (remove-duplicates '(1 2 3 4 2 7 8 1 5) - :allow-other-keys t :bad t :allow-other-keys nil) + :allow-other-keys t :bad t :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.7 (remove-duplicates '(1 2 3 4 2 7 8 1 5) - :allow-other-keys t :allow-other-keys nil :bad t) + :allow-other-keys t :allow-other-keys nil :bad t) (3 4 2 7 8 1 5)) (deftest remove-duplicates.allow-other-keys.8 (remove-duplicates '(1 2 3 4 2 7 8 1 5) - :allow-other-keys t :from-end t) + :allow-other-keys t :from-end t) (1 2 3 4 7 8 5)) (deftest remove-duplicates.keywords.1 @@ -153,22 +153,22 @@ (deftest delete-duplicates.allow-other-keys.5 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) :bad t - :allow-other-keys t :allow-other-keys nil) + :allow-other-keys t :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.6 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) - :allow-other-keys t :bad t :allow-other-keys nil) + :allow-other-keys t :bad t :allow-other-keys nil) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.7 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) - :allow-other-keys t :allow-other-keys nil :bad t) + :allow-other-keys t :allow-other-keys nil :bad t) (3 4 2 7 8 1 5)) (deftest delete-duplicates.allow-other-keys.8 (delete-duplicates (list 1 2 3 4 2 7 8 1 5) - :allow-other-keys t :from-end t) + :allow-other-keys t :from-end t) (1 2 3 4 7 8 5)) (deftest delete-duplicates.keywords.1 @@ -204,7 +204,7 @@ ) i a b c d e f)) (3 1 2 4) 6 1 2 3 4 5 6) - + ;;; Error cases (deftest remove-duplicates.error.1 @@ -297,7 +297,7 @@ (let ((s2 (remove-duplicates s))) (assert (string= s "abcadefabgz")) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "cdefabgz")))) nil) @@ -307,7 +307,7 @@ (let ((s2 (remove-duplicates s :from-end t))) (assert (string= s "abcadefabgz")) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "abcdefgz")))) nil) @@ -315,7 +315,7 @@ (do-special-strings (s "abcadefabgz" nil) (let ((aet (array-element-type s)) - (s2 (delete-duplicates s))) + (s2 (delete-duplicates s))) (assert (equal aet (array-element-type s2))) (assert (string= s2 "cdefabgz")))) nil) @@ -324,7 +324,7 @@ (do-special-strings (s "abcadefabgz" nil) (let ((aet (array-element-type s)) - (s2 (delete-duplicates s :from-end t))) + (s2 (delete-duplicates s :from-end t))) (assert (equal aet (array-element-type s2))) (assert (string= s2 "abcdefgz")))) nil) @@ -333,8 +333,8 @@ (deftest remove-duplicates.2 (let* ((x (list 'a)) - (y (list 'a)) - (result (remove-duplicates (list x y) :test 'equal))) + (y (list 'a)) + (result (remove-duplicates (list x y) :test 'equal))) (values result (notnot (eql (car result) x)) @@ -343,8 +343,8 @@ (deftest remove-duplicates.2a (let* ((x (list 'a)) - (y (list 'a)) - (result (remove-duplicates (list x 'x y) :test 'equal))) + (y (list 'a)) + (result (remove-duplicates (list x 'x y) :test 'equal))) (values result (notnot (eql (cadr result) x)) @@ -353,8 +353,8 @@ (deftest remove-duplicates.3 (let* ((x (list 'a)) - (y (list 'a)) - (result (remove-duplicates (list x y) :test 'equal :from-end t))) + (y (list 'a)) + (result (remove-duplicates (list x y) :test 'equal :from-end t))) (values result (notnot (eql (car result) x)) @@ -363,8 +363,8 @@ (deftest remove-duplicates.3a (let* ((x (list 'a)) - (y (list 'a)) - (result (remove-duplicates (list x 'u 'v y) :test 'equal :from-end t))) + (y (list 'a)) + (result (remove-duplicates (list x 'u 'v y) :test 'equal :from-end t))) (values result (notnot (eql (car result) x)) @@ -373,8 +373,8 @@ (deftest remove-duplicates.4 (let* ((x (list 'a)) - (y (list 'a)) - (result (remove-duplicates (list x y) :test 'equalp))) + (y (list 'a)) + (result (remove-duplicates (list x y) :test 'equalp))) (values result (notnot (eql (car result) x)) @@ -383,8 +383,8 @@ (deftest remove-duplicates.5 (let* ((x (list 'a)) - (y (list 'a)) - (result (remove-duplicates (list x y) :test 'equalp :from-end t))) + (y (list 'a)) + (result (remove-duplicates (list x y) :test 'equalp :from-end t))) (values result (notnot (eql (car result) x)) @@ -395,8 +395,8 @@ (deftest delete-duplicates.2 (let* ((x (list 'a)) - (y (list 'a)) - (result (delete-duplicates (list x y) :test 'equal))) + (y (list 'a)) + (result (delete-duplicates (list x y) :test 'equal))) (values result (notnot (eql (car result) x)) @@ -405,8 +405,8 @@ (deftest delete-duplicates.2a (let* ((x (list 'a)) - (y (list 'a)) - (result (delete-duplicates (list x 'x y) :test 'equal))) + (y (list 'a)) + (result (delete-duplicates (list x 'x y) :test 'equal))) (values result (notnot (eql (cadr result) x)) @@ -415,8 +415,8 @@ (deftest delete-duplicates.3 (let* ((x (list 'a)) - (y (list 'a)) - (result (delete-duplicates (list x y) :test 'equal :from-end t))) + (y (list 'a)) + (result (delete-duplicates (list x y) :test 'equal :from-end t))) (values result (notnot (eql (car result) x)) @@ -425,8 +425,8 @@ (deftest delete-duplicates.3a (let* ((x (list 'a)) - (y (list 'a)) - (result (delete-duplicates (list x 'u 'v y) :test 'equal :from-end t))) + (y (list 'a)) + (result (delete-duplicates (list x 'u 'v y) :test 'equal :from-end t))) (values result (notnot (eql (car result) x)) @@ -435,8 +435,8 @@ (deftest delete-duplicates.4 (let* ((x (list 'a)) - (y (list 'a)) - (result (delete-duplicates (list x y) :test 'equalp))) + (y (list 'a)) + (result (delete-duplicates (list x y) :test 'equalp))) (values result (notnot (eql (car result) x)) @@ -445,8 +445,8 @@ (deftest delete-duplicates.5 (let* ((x (list 'a)) - (y (list 'a)) - (result (delete-duplicates (list x y) :test 'equalp :from-end t))) + (y (list 'a)) + (result (delete-duplicates (list x y) :test 'equalp :from-end t))) (values result (notnot (eql (car result) x)) @@ -455,8 +455,8 @@ - - - \ No newline at end of file + + + diff --git a/ansi-tests/remove-method.lsp b/ansi-tests/remove-method.lsp index 65ed9a46..89b4812f 100644 --- a/ansi-tests/remove-method.lsp +++ b/ansi-tests/remove-method.lsp @@ -23,7 +23,7 @@ (deftest remove-method.1 (and (eqt (remove-method *remove-meth-gf-01* *remove-meth-gf-02-method-t*) - *remove-meth-gf-01*) + *remove-meth-gf-01*) (remove-meth-gf-01 :good)) :good) @@ -34,11 +34,11 @@ (values (remove-meth-gf-01 10) (progn (setf meth (eval '(defmethod remove-meth-gf-01 ((x integer)) - (1+ x)))) - nil) + (1+ x)))) + nil) (remove-meth-gf-01 10) (eqt *remove-meth-gf-01* - (remove-method *remove-meth-gf-01* meth)) + (remove-method *remove-meth-gf-01* meth)) (remove-meth-gf-01 10))) 10 nil 11 t 10) @@ -50,12 +50,12 @@ (mapcar #'remove-meth-gf-01 '(19 a)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x symbol)) - (list x)))) + (list x)))) (mapcar #'remove-meth-gf-01 '(19 a))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) - (1+ x)))) + (1+ x)))) (mapcar #'remove-meth-gf-01 '(19 a))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) @@ -72,12 +72,12 @@ (mapcar #'remove-meth-gf-01 '(19 a)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x symbol)) - (list x)))) + (list x)))) (mapcar #'remove-meth-gf-01 '(19 a))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) - (1+ x)))) + (1+ x)))) (mapcar #'remove-meth-gf-01 '(19 a))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) @@ -94,12 +94,12 @@ (mapcar #'remove-meth-gf-01 '(10 20.0)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x integer)) - (1- x)))) + (1- x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) - (1+ x)))) + (1+ x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) @@ -114,12 +114,12 @@ (mapcar #'remove-meth-gf-01 '(10 20.0)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x integer)) - (1- x)))) + (1- x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x number)) - (1+ x)))) + (1+ x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) @@ -134,12 +134,12 @@ (mapcar #'remove-meth-gf-01 '(10 20.0)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x number)) - (1+ x)))) + (1+ x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x integer)) - (1- x)))) + (1- x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth1)) @@ -154,12 +154,12 @@ (mapcar #'remove-meth-gf-01 '(10 20.0)) (progn (setf meth1 (eval '(defmethod remove-meth-gf-01 ((x number)) - (1+ x)))) + (1+ x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (progn (setf meth2 (eval '(defmethod remove-meth-gf-01 ((x integer)) - (1- x)))) + (1- x)))) (mapcar #'remove-meth-gf-01 '(10 20.0))) (eqt *remove-meth-gf-01* (remove-method *remove-meth-gf-01* meth2)) @@ -184,7 +184,7 @@ (mapcar #'remove-meth-gf-03 '(5 a)) (progn (setf meth (eval '(defmethod remove-meth-gf-03 :before ((x number)) - (incf *rmgf-03-var*)))) + (incf *rmgf-03-var*)))) (mapcar #'remove-meth-gf-03 '(5 a))) (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth)) (mapcar #'remove-meth-gf-03 '(5 a)))) @@ -199,7 +199,7 @@ (mapcar #'remove-meth-gf-03 '(5 a)) (progn (setf meth (eval '(defmethod remove-meth-gf-03 :after ((x number)) - (incf *rmgf-03-var*)))) + (incf *rmgf-03-var*)))) (mapcar #'remove-meth-gf-03 '(5 a))) (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth)) (mapcar #'remove-meth-gf-03 '(5 a)))) @@ -214,9 +214,9 @@ (mapcar #'remove-meth-gf-03 '(5 a)) (progn (setf meth (eval '(defmethod remove-meth-gf-03 :around ((x number)) - (incf *rmgf-03-var*) - (prog1 (call-next-method) - (decf *rmgf-03-var*))))) + (incf *rmgf-03-var*) + (prog1 (call-next-method) + (decf *rmgf-03-var*))))) (mapcar #'remove-meth-gf-03 '(5 a))) (eqt *remove-meth-gf-03* (remove-method *remove-meth-gf-03* meth)) (mapcar #'remove-meth-gf-03 '(5 a)))) diff --git a/ansi-tests/remove.lsp b/ansi-tests/remove.lsp index 8e3a16b2..bb6f9337 100644 --- a/ansi-tests/remove.lsp +++ b/ansi-tests/remove.lsp @@ -9,80 +9,80 @@ (deftest remove-list.1 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x))) + (x (copy-seq orig)) + (y (remove 'a x))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.2 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :count nil))) + (x (copy-seq orig)) + (y (remove 'a x :count nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.3 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :key nil))) + (x (copy-seq orig)) + (y (remove 'a x :key nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.4 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :count 100))) + (x (copy-seq orig)) + (y (remove 'a x :count 100))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.5 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :count 0))) + (x (copy-seq orig)) + (y (remove 'a x :count 0))) (and (equalp orig x) y)) (a b c a b d a c b a e)) (deftest remove-list.6 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :count 1))) + (x (copy-seq orig)) + (y (remove 'a x :count 1))) (and (equalp orig x) y)) (b c a b d a c b a e)) (deftest remove-list.7 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'c x :count 1))) + (x (copy-seq orig)) + (y (remove 'c x :count 1))) (and (equalp orig x) y)) (a b a b d a c b a e)) (deftest remove-list.8 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :from-end t))) + (x (copy-seq orig)) + (y (remove 'a x :from-end t))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.9 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :from-end t :count 1))) + (x (copy-seq orig)) + (y (remove 'a x :from-end t :count 1))) (and (equalp orig x) y)) (a b c a b d a c b e)) (deftest remove-list.10 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :from-end t :count 4))) + (x (copy-seq orig)) + (y (remove 'a x :from-end t :count 4))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-list.11 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig))) + (x (copy-seq orig))) (values (loop for i from 0 to 10 - collect (remove 'a x :start i)) + collect (remove 'a x :start i)) (equalp orig x))) ((b c b d c b e) (a b c b d c b e) @@ -95,14 +95,14 @@ (a b c a b d a c b e) (a b c a b d a c b e) (a b c a b d a c b a e)) - t) + t) (deftest remove-list.12 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig))) + (x (copy-seq orig))) (values (loop for i from 0 to 10 - collect (remove 'a x :start i :end nil)) + collect (remove 'a x :start i :end nil)) (equalp orig x))) ((b c b d c b e) (a b c b d c b e) @@ -119,10 +119,10 @@ (deftest remove-list.13 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig))) + (x (copy-seq orig))) (values (loop for i from 0 to 10 - collect (remove 'a x :start i :end 11)) + collect (remove 'a x :start i :end 11)) (equalp orig x))) ((b c b d c b e) (a b c b d c b e) @@ -139,17 +139,17 @@ (deftest remove-list.14 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove 'a x :end nil))) + (x (copy-seq orig)) + (y (remove 'a x :end nil))) (and (equalp orig x) y)) (b c b d c b e)) - + (deftest remove-list.15 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig))) + (x (copy-seq orig))) (values (loop for i from 0 to 9 - collect (remove 'a x :start i :end 9)) + collect (remove 'a x :start i :end 9)) (equalp orig x))) ((b c b d c b a e) (a b c b d c b a e) @@ -165,10 +165,10 @@ (deftest remove-list.16 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig))) + (x (copy-seq orig))) (values (loop for i from 0 to 10 - collect (remove 'a x :start i :end 11 :count 1)) + collect (remove 'a x :start i :end 11 :count 1)) (equalp orig x))) ((b c a b d a c b a e) (a b c b d a c b a e) @@ -185,10 +185,10 @@ (deftest remove-list.17 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig))) + (x (copy-seq orig))) (values (loop for i from 0 to 10 - collect (remove 'a x :start i :end (1+ i))) + collect (remove 'a x :start i :end (1+ i))) (equalp orig x))) (( b c a b d a c b a e) (a b c a b d a c b a e) @@ -208,91 +208,91 @@ #| (deftest remove-list.18 (let* ((i (1+ most-positive-fixnum)) - (orig (list i 0 i 1 i 2 3)) - (x (copy-seq orig)) - (y (remove (1+ most-positive-fixnum) x))) + (orig (list i 0 i 1 i 2 3)) + (x (copy-seq orig)) + (y (remove (1+ most-positive-fixnum) x))) (and (equalp orig x) y)) (0 1 2 3)) |# (deftest remove-list.19 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 1 x :key #'1-))) + (x (copy-seq orig)) + (y (remove 1 x :key #'1-))) (and (equalp orig x) y)) (1 3 6 1 4 1 3 7)) (deftest remove-list.20 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :test #'>))) + (x (copy-seq orig)) + (y (remove 3 x :test #'>))) (and (equalp orig x) y)) (3 6 4 3 7)) (deftest remove-list.21 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :test '> :from-end t))) + (x (copy-seq orig)) + (y (remove 3 x :test '> :from-end t))) (and (equalp orig x) y)) (3 6 4 3 7)) (deftest remove-list.22 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 2 x :key nil))) + (x (copy-seq orig)) + (y (remove 2 x :key nil))) (and (equalp orig x) y)) (1 3 6 1 4 1 3 7)) (deftest remove-list.23 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 1 x :key '1-))) + (x (copy-seq orig)) + (y (remove 1 x :key '1-))) (and (equalp orig x) y)) (1 3 6 1 4 1 3 7)) (deftest remove-list.24 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :test-not #'<=))) + (x (copy-seq orig)) + (y (remove 3 x :test-not #'<=))) (and (equalp orig x) y)) (3 6 4 3 7)) (deftest remove-list.25 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :test-not '<= :from-end t))) + (x (copy-seq orig)) + (y (remove 3 x :test-not '<= :from-end t))) (and (equalp orig x) y)) (3 6 4 3 7)) (deftest remove-list.26 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :from-end t :start 1 :end 5))) + (x (copy-seq orig)) + (y (remove 3 x :from-end t :start 1 :end 5))) (and (equalp orig x) y)) (1 2 2 6 1 2 4 1 3 2 7)) (deftest remove-list.27 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :count -1))) + (x (copy-seq orig)) + (y (remove 3 x :count -1))) (and (equalp orig x) - (equalpt x y))) + (equalpt x y))) t) (deftest remove-list.28 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :count -1000000000000))) + (x (copy-seq orig)) + (y (remove 3 x :count -1000000000000))) (and (equalp orig x) - (equalpt x y))) + (equalpt x y))) t) (deftest remove-list.29 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove 3 x :count 1000000000000))) + (x (copy-seq orig)) + (y (remove 3 x :count 1000000000000))) (and (equalp orig x) - y)) + y)) (1 2 2 6 1 2 4 1 2 7)) ;;; Assorted tests of remove and delete on vectors, strings, @@ -662,109 +662,109 @@ (deftest remove-random (loop for i from 1 to 2500 - unless (eq (random-test-remove 20) t) - do (return *remove-fail-args*)) + unless (eq (random-test-remove 20) t) + do (return *remove-fail-args*)) nil) (deftest remove-if-random (loop for i from 1 to 2500 - unless (eq (random-test-remove-if 20) t) - do (return *remove-fail-args*)) + unless (eq (random-test-remove-if 20) t) + do (return *remove-fail-args*)) nil) (deftest remove-if-not-random (loop for i from 1 to 2500 - unless (eq (random-test-remove-if 20 t) t) - do (return *remove-fail-args*)) + unless (eq (random-test-remove-if 20 t) t) + do (return *remove-fail-args*)) nil) (deftest delete-random (loop for i from 1 to 2500 - unless (eq (random-test-delete 20) t) - do (return *remove-fail-args*)) + unless (eq (random-test-delete 20) t) + do (return *remove-fail-args*)) nil) (deftest delete-if-random (loop for i from 1 to 2500 - unless (eq (random-test-delete-if 20) t) - do (return *remove-fail-args*)) + unless (eq (random-test-delete-if 20) t) + do (return *remove-fail-args*)) nil) (deftest delete-if-not-random (loop for i from 1 to 2500 - unless (eq (random-test-delete-if 20 t) t) - do (return *remove-fail-args*)) + unless (eq (random-test-delete-if 20 t) t) + do (return *remove-fail-args*)) nil) ;;; Additional tests with KEY = NIL (deftest remove-if-list.1 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove-if #'evenp x :key nil))) + (x (copy-seq orig)) + (y (remove-if #'evenp x :key nil))) (and (equalp orig x) y)) (1 3 1 1 3 7)) (deftest remove-if-list.2 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove-if #'(lambda (y) (eqt y 'a)) x :key nil))) + (x (copy-seq orig)) + (y (remove-if #'(lambda (y) (eqt y 'a)) x :key nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest remove-if-not-list.1 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (remove-if-not #'oddp x :key nil))) + (x (copy-seq orig)) + (y (remove-if-not #'oddp x :key nil))) (and (equalp orig x) y)) (1 3 1 1 3 7)) (deftest remove-if-not-list.2 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (remove-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) + (x (copy-seq orig)) + (y (remove-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) (and (equalp orig x) y)) (b c b d c b e)) (deftest delete-if-list.1 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (delete-if #'evenp x :key nil))) + (x (copy-seq orig)) + (y (delete-if #'evenp x :key nil))) y) (1 3 1 1 3 7)) (deftest delete-if-list.2 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (delete-if #'(lambda (y) (eqt y 'a)) x :key nil))) + (x (copy-seq orig)) + (y (delete-if #'(lambda (y) (eqt y 'a)) x :key nil))) y) (b c b d c b e)) (deftest delete-if-not-list.1 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (delete-if-not #'oddp x :key nil))) + (x (copy-seq orig)) + (y (delete-if-not #'oddp x :key nil))) y) (1 3 1 1 3 7)) (deftest delete-if-not-list.2 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (delete-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) + (x (copy-seq orig)) + (y (delete-if-not #'(lambda (y) (not (eqt y 'a))) x :key nil))) y) (b c b d c b e)) (deftest delete-list.1 (let* ((orig '(a b c a b d a c b a e)) - (x (copy-seq orig)) - (y (delete 'a x :key nil))) + (x (copy-seq orig)) + (y (delete 'a x :key nil))) y) (b c b d c b e)) (deftest delete-list.2 (let* ((orig '(1 2 3 2 6 1 2 4 1 3 2 7)) - (x (copy-seq orig)) - (y (delete 2 x :key nil))) + (x (copy-seq orig)) + (y (delete 2 x :key nil))) y) (1 3 6 1 4 1 3 7)) @@ -788,7 +788,7 @@ (deftest remove.allow-other-keys.5 (remove 'a '(a b c a d) :bad1 t :allow-other-keys t :bad2 t - :allow-other-keys nil :bad3 t) + :allow-other-keys nil :bad3 t) (b c d)) (deftest remove.allow-other-keys.6 @@ -818,7 +818,7 @@ (deftest delete.allow-other-keys.5 (delete 'a (copy-seq '(a b c a d)) :bad1 t :allow-other-keys t :bad2 t - :allow-other-keys nil :bad3 t) + :allow-other-keys nil :bad3 t) (b c d)) (deftest delete.allow-other-keys.6 @@ -827,7 +827,7 @@ (deftest delete.keywords.7 (delete 'a (copy-seq '(a b c a d)) - :from-end t :count 1 :from-end nil :count 10) + :from-end t :count 1 :from-end nil :count 10) (a b c d)) @@ -936,7 +936,7 @@ (s "ab1c23def4" nil) (let ((s2 (remove-if #'alpha-char-p s))) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "1234")) (assert (string= s "ab1c23def4")))) nil) @@ -946,7 +946,7 @@ (s "ab1c23def4" nil) (let ((s2 (remove-if #'alpha-char-p s :count 3))) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "123def4")) (assert (string= s "ab1c23def4")))) nil) @@ -956,7 +956,7 @@ (s "ab1c23def4" nil) (let ((s2 (remove-if #'alpha-char-p s :count 3 :from-end t))) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "ab1c234")) (assert (string= s "ab1c23def4")))) nil) @@ -966,7 +966,7 @@ (s "ab1c23def4" nil) (let ((s2 (remove-if-not #'digit-char-p s))) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "1234")) (assert (string= s "ab1c23def4")))) nil) @@ -976,7 +976,7 @@ (s "ab1c23def4" nil) (let ((s2 (remove-if-not #'digit-char-p s :count 3))) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "123def4")) (assert (string= s "ab1c23def4")))) nil) @@ -986,7 +986,7 @@ (s "ab1c23def4" nil) (let ((s2 (remove-if-not #'digit-char-p s :count 3 :from-end t))) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "ab1c234")) (assert (string= s "ab1c23def4")))) nil) @@ -997,7 +997,7 @@ (s "ab1c23def4" nil) (let ((s2 (delete-if #'alpha-char-p s))) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "1234")))) nil) @@ -1006,7 +1006,7 @@ (s "ab1c23def4" nil) (let ((s2 (delete-if #'alpha-char-p s :count 3))) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "123def4")))) nil) @@ -1015,7 +1015,7 @@ (s "ab1c23def4" nil) (let ((s2 (delete-if #'alpha-char-p s :count 3 :from-end t))) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "ab1c234")))) nil) @@ -1024,7 +1024,7 @@ (s "ab1c23def4" nil) (let ((s2 (delete-if-not #'digit-char-p s))) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "1234")))) nil) @@ -1033,7 +1033,7 @@ (s "ab1c23def4" nil) (let ((s2 (delete-if-not #'digit-char-p s :count 3))) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "123def4")))) nil) @@ -1042,6 +1042,6 @@ (s "ab1c23def4" nil) (let ((s2 (delete-if-not #'digit-char-p s :count 3 :from-end t))) (assert (equal (array-element-type s) - (array-element-type s2))) + (array-element-type s2))) (assert (string= s2 "ab1c234")))) nil) diff --git a/ansi-tests/rename-file.lsp b/ansi-tests/rename-file.lsp index 906cba07..59a1f4c3 100644 --- a/ansi-tests/rename-file.lsp +++ b/ansi-tests/rename-file.lsp @@ -7,108 +7,108 @@ (deftest rename-file.1 (let ((pn1 #p"file-to-be-renamed.txt") - (pn2 #p"file-that-was-renamed.txt")) + (pn2 #p"file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (values - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn2)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename)))))) + results + (values + (=t (length results) 3) + (probe-file pn1) + (notnot (probe-file pn2)) + (list (notnot (pathnamep defaulted-new-name)) + (notnot (pathnamep old-truename)) + (notnot (pathnamep new-truename)) + (typep old-truename 'logical-pathname) + (typep new-truename 'logical-pathname)) + (notnot (probe-file defaulted-new-name)) + (probe-file old-truename) + (notnot (probe-file new-truename)))))) t nil t (t t t nil nil) t nil t) (deftest rename-file.2 (let ((pn1 "file-to-be-renamed.txt") - (pn2 "file-that-was-renamed.txt")) + (pn2 "file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (values - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn2)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename)))))) + results + (values + (=t (length results) 3) + (probe-file pn1) + (notnot (probe-file pn2)) + (list (notnot (pathnamep defaulted-new-name)) + (notnot (pathnamep old-truename)) + (notnot (pathnamep new-truename)) + (typep old-truename 'logical-pathname) + (typep new-truename 'logical-pathname)) + (notnot (probe-file defaulted-new-name)) + (probe-file old-truename) + (notnot (probe-file new-truename)))))) t nil t (t t t nil nil) t nil t) (deftest rename-file.3 (let* ((pn1 (make-pathname :name "file-to-be-renamed" - :type "txt" - :version :newest - :defaults *default-pathname-defaults*)) - (pn2 (make-pathname :name "file-that-was-renamed")) - (pn3 (make-pathname :name "file-that-was-renamed" - :defaults pn1))) + :type "txt" + :version :newest + :defaults *default-pathname-defaults*)) + (pn2 (make-pathname :name "file-that-was-renamed")) + (pn3 (make-pathname :name "file-that-was-renamed" + :defaults pn1))) (delete-all-versions pn1) (delete-all-versions pn3) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (values - (equalpt (pathname-type pn1) - (pathname-type defaulted-new-name)) - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn3)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename)))))) + results + (values + (equalpt (pathname-type pn1) + (pathname-type defaulted-new-name)) + (=t (length results) 3) + (probe-file pn1) + (notnot (probe-file pn3)) + (list (notnot (pathnamep defaulted-new-name)) + (notnot (pathnamep old-truename)) + (notnot (pathnamep new-truename)) + (typep old-truename 'logical-pathname) + (typep new-truename 'logical-pathname)) + (notnot (probe-file defaulted-new-name)) + (probe-file old-truename) + (notnot (probe-file new-truename)))))) t t nil t (t t t nil nil) t nil t) (deftest rename-file.4 (let ((pn1 "file-to-be-renamed.txt") - (pn2 "file-that-was-renamed.txt")) + (pn2 "file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (let ((s (open pn1 :direction :output))) (format s "Whatever~%") (close s) (let ((results (multiple-value-list (rename-file s pn2)))) - (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (values - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn2)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename))))))) + (destructuring-bind (defaulted-new-name old-truename new-truename) + results + (values + (=t (length results) 3) + (probe-file pn1) + (notnot (probe-file pn2)) + (list (notnot (pathnamep defaulted-new-name)) + (notnot (pathnamep old-truename)) + (notnot (pathnamep new-truename)) + (typep old-truename 'logical-pathname) + (typep new-truename 'logical-pathname)) + (notnot (probe-file defaulted-new-name)) + (probe-file old-truename) + (notnot (probe-file new-truename))))))) t nil t (t t t nil nil) t nil t) (deftest rename-file.5 (let ((pn1 "CLTEST:file-to-be-renamed.txt") - (pn2 "CLTEST:file-that-was-renamed.txt")) + (pn2 "CLTEST:file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (assert (typep (pathname pn1) 'logical-pathname)) @@ -116,21 +116,21 @@ (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (values - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn2)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename)) - (notnot (typep defaulted-new-name 'logical-pathname)) - )))) + results + (values + (=t (length results) 3) + (probe-file pn1) + (notnot (probe-file pn2)) + (list (notnot (pathnamep defaulted-new-name)) + (notnot (pathnamep old-truename)) + (notnot (pathnamep new-truename)) + (typep old-truename 'logical-pathname) + (typep new-truename 'logical-pathname)) + (notnot (probe-file defaulted-new-name)) + (probe-file old-truename) + (notnot (probe-file new-truename)) + (notnot (typep defaulted-new-name 'logical-pathname)) + )))) t nil t (t t t nil nil) t nil t t) ;;; Specialized string tests @@ -139,56 +139,56 @@ (do-special-strings (s "file-to-be-renamed.txt" nil) (let ((pn1 s) - (pn2 "file-that-was-renamed.txt")) + (pn2 "file-that-was-renamed.txt")) (delete-all-versions pn1) (delete-all-versions pn2) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (assert - (equal - (list - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn2)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename))) - '(t nil t (t t t nil nil) t nil t))))))) + results + (assert + (equal + (list + (=t (length results) 3) + (probe-file pn1) + (notnot (probe-file pn2)) + (list (notnot (pathnamep defaulted-new-name)) + (notnot (pathnamep old-truename)) + (notnot (pathnamep new-truename)) + (typep old-truename 'logical-pathname) + (typep new-truename 'logical-pathname)) + (notnot (probe-file defaulted-new-name)) + (probe-file old-truename) + (notnot (probe-file new-truename))) + '(t nil t (t t t nil nil) t nil t))))))) nil) (deftest rename-file.7 (do-special-strings (s "file-that-was-renamed.txt" nil) (let ((pn1 "file-to-be-renamed.txt") - (pn2 s)) + (pn2 s)) (delete-all-versions pn1) (delete-all-versions pn2) (with-open-file (s pn1 :direction :output) (format s "Whatever~%")) (let ((results (multiple-value-list (rename-file pn1 pn2)))) (destructuring-bind (defaulted-new-name old-truename new-truename) - results - (assert - (equal - (list - (=t (length results) 3) - (probe-file pn1) - (notnot (probe-file pn2)) - (list (notnot (pathnamep defaulted-new-name)) - (notnot (pathnamep old-truename)) - (notnot (pathnamep new-truename)) - (typep old-truename 'logical-pathname) - (typep new-truename 'logical-pathname)) - (notnot (probe-file defaulted-new-name)) - (probe-file old-truename) - (notnot (probe-file new-truename))) - '(t nil t (t t t nil nil) t nil t))))))) + results + (assert + (equal + (list + (=t (length results) 3) + (probe-file pn1) + (notnot (probe-file pn2)) + (list (notnot (pathnamep defaulted-new-name)) + (notnot (pathnamep old-truename)) + (notnot (pathnamep new-truename)) + (typep old-truename 'logical-pathname) + (typep new-truename 'logical-pathname)) + (notnot (probe-file defaulted-new-name)) + (probe-file old-truename) + (notnot (probe-file new-truename))) + '(t nil t (t t t nil nil) t nil t))))))) nil) ;;; Error tests diff --git a/ansi-tests/rename-package.lsp b/ansi-tests/rename-package.lsp index e97a46c8..f48fe8d4 100644 --- a/ansi-tests/rename-package.lsp +++ b/ansi-tests/rename-package.lsp @@ -14,23 +14,23 @@ (safely-delete-package "TEST1") (safely-delete-package "TEST2") (let ((p (make-package "TEST1")) - (i 0) x y) + (i 0) x y) (unless (packagep p) (return nil)) (let ((p2 (rename-package (progn (setf x (incf i)) "TEST1") - (progn (setf y (incf i)) "TEST2")))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (eql i 2) - (eql x 1) - (eql y 2) - (equal (package-name p2) "TEST2")) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t))) + (progn (setf y (incf i)) "TEST2")))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (eql i 2) + (eql x 1) + (eql y 2) + (equal (package-name p2) "TEST2")) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t))) t) (deftest rename-package.2 @@ -41,22 +41,22 @@ (safely-delete-package "TEST4") (safely-delete-package "TEST5") (let ((p (make-package "TEST1")) - (nicknames (copy-list '("TEST3" "TEST4" "TEST5")))) + (nicknames (copy-list '("TEST3" "TEST4" "TEST5")))) (unless (packagep p) (return nil)) (let ((p2 (rename-package "TEST1" "TEST2" nicknames))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (equal (package-name p2) "TEST2") - (null (set-exclusive-or nicknames - (package-nicknames p2) - :test #'equal))) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (equal (package-name p2) "TEST2") + (null (set-exclusive-or nicknames + (package-nicknames p2) + :test #'equal))) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t))) t) (deftest rename-package.3 @@ -64,26 +64,26 @@ (safely-delete-package "TEST1") (safely-delete-package "TEST2") (let ((p (make-package "TEST1")) - (nicknames (copy-list '(#\M #\N)))) + (nicknames (copy-list '(#\M #\N)))) (unless (packagep p) (return nil)) (let ((p2 (ignore-errors (rename-package "TEST1" "TEST2" nicknames)))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (equal (package-name p2) "TEST2") - (equal - (sort (copy-list (package-nicknames p2)) - #'string<) - (sort (mapcar #'(lambda (c) - (make-string 1 :initial-element c)) - nicknames) - #'string<))) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (equal (package-name p2) "TEST2") + (equal + (sort (copy-list (package-nicknames p2)) + #'string<) + (sort (mapcar #'(lambda (c) + (make-string 1 :initial-element c)) + nicknames) + #'string<))) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t))) t) (deftest rename-package.4 @@ -91,22 +91,22 @@ (safely-delete-package "G") (safely-delete-package "TEST2") (let ((p (make-package "G")) - (nicknames nil)) + (nicknames nil)) (unless (packagep p) (return nil)) (let ((p2 (ignore-errors (rename-package #\G "TEST2" nicknames)))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (equal (package-name p2) "TEST2") - (null (set-exclusive-or nicknames - (package-nicknames p2) - :test #'equal))) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (ignore-errors (safely-delete-package p2)) - t))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (equal (package-name p2) "TEST2") + (null (set-exclusive-or nicknames + (package-nicknames p2) + :test #'equal))) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (ignore-errors (safely-delete-package p2)) + t))) t) (deftest rename-package.5 @@ -114,22 +114,22 @@ (safely-delete-package "TEST1") (safely-delete-package "G") (let ((p (make-package "TEST1")) - (nicknames nil)) + (nicknames nil)) (unless (packagep p) (return nil)) (let ((p2 (ignore-errors (rename-package "TEST1" #\G nicknames)))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (equal (package-name p2) "G") - (null (set-exclusive-or nicknames - (package-nicknames p2) - :test #'equal))) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (equal (package-name p2) "G") + (null (set-exclusive-or nicknames + (package-nicknames p2) + :test #'equal))) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t))) t) (deftest rename-package.6 @@ -139,98 +139,98 @@ (safely-delete-package '|M|) (safely-delete-package '|N|) (let ((p (make-package '|TEST1|)) - (nicknames (copy-list '(|M| |N|)))) + (nicknames (copy-list '(|M| |N|)))) (unless (packagep p) (return nil)) (let ((p2 (ignore-errors (rename-package - '|TEST1| '|TEST2| nicknames)))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (equal (package-name p2) "TEST2") - (equal - (sort (copy-list (package-nicknames p2)) - #'string<) - (sort (mapcar #'symbol-name nicknames) - #'string<))) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t))) + '|TEST1| '|TEST2| nicknames)))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (equal (package-name p2) "TEST2") + (equal + (sort (copy-list (package-nicknames p2)) + #'string<) + (sort (mapcar #'symbol-name nicknames) + #'string<))) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t))) t) (deftest rename-package.7 (block nil (let ((name1 (make-array '(5) :element-type 'base-char - :initial-contents "TEST1")) - (name2 (make-array '(5) :element-type 'base-char - :initial-contents "TEST2"))) + :initial-contents "TEST1")) + (name2 (make-array '(5) :element-type 'base-char + :initial-contents "TEST2"))) (safely-delete-package name1) (safely-delete-package name2) (let ((p (make-package name1))) - (unless (packagep p) (return nil)) - (let ((p2 (rename-package name1 name2))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (equal (package-name p2) name2)) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t)))) + (unless (packagep p) (return nil)) + (let ((p2 (rename-package name1 name2))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (equal (package-name p2) name2)) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t)))) t) (deftest rename-package.8 (block nil (let ((name1 (make-array '(10) :element-type 'base-char - :fill-pointer 5 - :initial-contents "TEST1 ")) - (name2 (make-array '(9) :element-type 'character - :fill-pointer 5 - :initial-contents "TEST2XXXX"))) + :fill-pointer 5 + :initial-contents "TEST1 ")) + (name2 (make-array '(9) :element-type 'character + :fill-pointer 5 + :initial-contents "TEST2XXXX"))) (safely-delete-package name1) (safely-delete-package name2) (let ((p (make-package "TEST1"))) - (unless (packagep p) (return nil)) - (let ((p2 (rename-package name1 name2))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (string= (package-name p2) "TEST2")) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t)))) + (unless (packagep p) (return nil)) + (let ((p2 (rename-package name1 name2))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (string= (package-name p2) "TEST2")) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t)))) t) (deftest rename-package.9 (block nil (let ((name1 (make-array '(5) :element-type 'character - :adjustable t - :initial-contents "TEST1")) - (name2 (make-array '(5) :element-type 'base-char - :adjustable t - :initial-contents "TEST2"))) + :adjustable t + :initial-contents "TEST1")) + (name2 (make-array '(5) :element-type 'base-char + :adjustable t + :initial-contents "TEST2"))) (safely-delete-package name1) (safely-delete-package name2) (let ((p (make-package "TEST1"))) - (unless (packagep p) (return nil)) - (let ((p2 (rename-package name1 name2))) - (unless (packagep p2) - (safely-delete-package p) - (return p2)) - (unless (and (eqt p p2) - (string= (package-name p2) "TEST2")) - (safely-delete-package p) - (safely-delete-package p2) - (return nil)) - (safely-delete-package p2) - t)))) + (unless (packagep p) (return nil)) + (let ((p2 (rename-package name1 name2))) + (unless (packagep p2) + (safely-delete-package p) + (return p2)) + (unless (and (eqt p p2) + (string= (package-name p2) "TEST2")) + (safely-delete-package p) + (safely-delete-package p2) + (return nil)) + (safely-delete-package p2) + t)))) t) diff --git a/ansi-tests/replace.lsp b/ansi-tests/replace.lsp index aed081d5..94e18d5c 100644 --- a/ansi-tests/replace.lsp +++ b/ansi-tests/replace.lsp @@ -7,42 +7,42 @@ (deftest replace-list.1 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z)))) + (result (replace x '(x y z)))) (values (eqt x result) result)) t (x y z d e f g)) (deftest replace-list.2 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 1))) + (result (replace x '(x y z) :start1 1))) (values (eqt x result) result)) t (a x y z e f g)) (deftest replace-list.3 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 4))) + (result (replace x '(x y z) :start1 4))) (values (eqt x result) result)) t (a b c d x y z)) (deftest replace-list.4 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 5))) + (result (replace x '(x y z) :start1 5))) (values (eqt x result) result)) t (a b c d e x y)) (deftest replace-list.5 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 6))) + (result (replace x '(x y z) :start1 6))) (values (eqt x result) result)) t (a b c d e f x)) (deftest replace-list.6 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x #(x y z) :start1 2))) + (result (replace x #(x y z) :start1 2))) (values (eqt x result) result)) t (a b x y z f g)) @@ -53,21 +53,21 @@ (deftest replace-list.8 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :end1 1))) + (result (replace x '(x y z) :end1 1))) (values (eqt x result) result)) t (x b c d e f g)) (deftest replace-list.9 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 3 :end1 4))) + (result (replace x '(x y z) :start1 3 :end1 4))) (values (eqt x result) result)) t (a b c x e f g)) (deftest replace-list.10 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 0 :end1 5))) + (result (replace x '(x y z) :start1 0 :end1 5))) (values (eqt x result) result)) t (x y z d e f g)) @@ -75,75 +75,75 @@ (deftest replace-list.11 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start2 1))) + (result (replace x '(x y z) :start2 1))) (values (eqt x result) result)) t (y z c d e f g)) (deftest replace-list.12 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start2 1 :end1 nil))) + (result (replace x '(x y z) :start2 1 :end1 nil))) (values (eqt x result) result)) t (y z c d e f g)) (deftest replace-list.13 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start2 1 :end2 nil))) + (result (replace x '(x y z) :start2 1 :end2 nil))) (values (eqt x result) result)) t (y z c d e f g)) (deftest replace-list.14 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start2 1 :end2 2))) + (result (replace x '(x y z) :start2 1 :end2 2))) (values (eqt x result) result)) t (y b c d e f g)) (deftest replace-list.15 (let* ((x (copy-seq '(a b c d e f g))) - (result (replace x '(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) + (result (replace x '(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) (values (eqt x result) result)) t (a b c d y f g)) (deftest replace-list.16 (let* ((x (copy-seq '(a b c d e f))) - (y #(1 2 3)) - (result (replace x y :start1 1))) + (y #(1 2 3)) + (result (replace x y :start1 1))) (values (eqt x result) result)) t (a 1 2 3 e f)) (deftest replace-list.17 (let* ((x (copy-seq '(a b c d e f))) - (y (make-array '(3) :initial-contents '(1 2 3) - :fill-pointer t)) - (result (replace x y :start1 1))) + (y (make-array '(3) :initial-contents '(1 2 3) + :fill-pointer t)) + (result (replace x y :start1 1))) (values (eqt x result) result)) t (a 1 2 3 e f)) (deftest replace-list.18 (let* ((x (copy-seq '(a b c d e f))) - (y (make-array '(6) :initial-contents '(1 2 3 4 5 6) - :fill-pointer 3)) - (result (replace x y :start1 1))) + (y (make-array '(6) :initial-contents '(1 2 3 4 5 6) + :fill-pointer 3)) + (result (replace x y :start1 1))) (values (eqt x result) result)) t (a 1 2 3 e f)) (deftest replace-list.19 (let* ((x (copy-seq '(a b c d e f))) - (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) + (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) (values (eqt x result) result)) t (b c d d e f)) (deftest replace-list.20 (let* ((x (copy-seq '(a b c d e f))) - (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) + (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) (values (eqt x result) result)) t (a a b c e f)) @@ -153,42 +153,42 @@ (deftest replace-vector.1 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z)))) + (result (replace x #(x y z)))) (values (eqt x result) result)) t #(x y z d e f g)) (deftest replace-vector.2 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 1))) + (result (replace x #(x y z) :start1 1))) (values (eqt x result) result)) t #(a x y z e f g)) (deftest replace-vector.3 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 4))) + (result (replace x #(x y z) :start1 4))) (values (eqt x result) result)) t #(a b c d x y z)) (deftest replace-vector.4 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 5))) + (result (replace x #(x y z) :start1 5))) (values (eqt x result) result)) t #(a b c d e x y)) (deftest replace-vector.5 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 6))) + (result (replace x #(x y z) :start1 6))) (values (eqt x result) result)) t #(a b c d e f x)) (deftest replace-vector.6 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x '(x y z) :start1 2))) + (result (replace x '(x y z) :start1 2))) (values (eqt x result) result)) t #(a b x y z f g)) @@ -199,21 +199,21 @@ (deftest replace-vector.8 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :end1 1))) + (result (replace x #(x y z) :end1 1))) (values (eqt x result) result)) t #(x b c d e f g)) (deftest replace-vector.9 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 3 :end1 4))) + (result (replace x #(x y z) :start1 3 :end1 4))) (values (eqt x result) result)) t #(a b c x e f g)) (deftest replace-vector.10 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 0 :end1 5))) + (result (replace x #(x y z) :start1 0 :end1 5))) (values (eqt x result) result)) t #(x y z d e f g)) @@ -221,75 +221,75 @@ (deftest replace-vector.11 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start2 1))) + (result (replace x #(x y z) :start2 1))) (values (eqt x result) result)) t #(y z c d e f g)) (deftest replace-vector.12 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start2 1 :end1 nil))) + (result (replace x #(x y z) :start2 1 :end1 nil))) (values (eqt x result) result)) t #(y z c d e f g)) (deftest replace-vector.13 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start2 1 :end2 nil))) + (result (replace x #(x y z) :start2 1 :end2 nil))) (values (eqt x result) result)) t #(y z c d e f g)) (deftest replace-vector.14 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start2 1 :end2 2))) + (result (replace x #(x y z) :start2 1 :end2 2))) (values (eqt x result) result)) t #(y b c d e f g)) (deftest replace-vector.15 (let* ((x (copy-seq #(a b c d e f g))) - (result (replace x #(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) + (result (replace x #(x y z) :start1 4 :end1 5 :start2 1 :end2 2))) (values (eqt x result) result)) t #(a b c d y f g)) (deftest replace-vector.16 (let* ((x (copy-seq #(a b c d e f))) - (y '(1 2 3)) - (result (replace x y :start1 1))) + (y '(1 2 3)) + (result (replace x y :start1 1))) (values (eqt x result) result)) t #(a 1 2 3 e f)) (deftest replace-vector.17 (let* ((x (copy-seq #(a b c d e f))) - (y (make-array '(3) :initial-contents '(1 2 3) - :fill-pointer t)) - (result (replace x y :start1 1))) + (y (make-array '(3) :initial-contents '(1 2 3) + :fill-pointer t)) + (result (replace x y :start1 1))) (values (eqt x result) result)) t #(a 1 2 3 e f)) (deftest replace-vector.18 (let* ((x (copy-seq #(a b c d e f))) - (y (make-array '(6) :initial-contents '(1 2 3 4 5 6) - :fill-pointer 3)) - (result (replace x y :start1 1))) + (y (make-array '(6) :initial-contents '(1 2 3 4 5 6) + :fill-pointer 3)) + (result (replace x y :start1 1))) (values (eqt x result) result)) t #(a 1 2 3 e f)) (deftest replace-vector.19 (let* ((x (copy-seq #(a b c d e f))) - (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) + (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) (values (eqt x result) result)) t #(b c d d e f)) (deftest replace-vector.21 (let* ((x (copy-seq #(a b c d e f))) - (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) + (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) (values (eqt x result) result)) t #(a a b c e f)) @@ -298,42 +298,42 @@ (deftest replace-bit-vector.1 (let* ((x (copy-seq #*1101001)) - (result (replace x #*011))) + (result (replace x #*011))) (values (eqt x result) result)) t #*0111001) (deftest replace-bit-vector.2 (let* ((x (copy-seq #*1101001)) - (result (replace x #*011 :start1 1))) + (result (replace x #*011 :start1 1))) (values (eqt x result) result)) t #*1011001) (deftest replace-bit-vector.3 (let* ((x (copy-seq #*1101001)) - (result (replace x #*011 :start1 4))) + (result (replace x #*011 :start1 4))) (values (eqt x result) result)) t #*1101011) (deftest replace-bit-vector.4 (let* ((x (copy-seq #*0000000)) - (result (replace x #*111 :start1 5))) + (result (replace x #*111 :start1 5))) (values (eqt x result) result)) t #*0000011) (deftest replace-bit-vector.5 (let* ((x (copy-seq #*0000000)) - (result (replace x #*100 :start1 6))) + (result (replace x #*100 :start1 6))) (values (eqt x result) result)) t #*0000001) (deftest replace-bit-vector.6 (let* ((x (copy-seq #*0000000)) - (result (replace x '(1 1 1) :start1 2))) + (result (replace x '(1 1 1) :start1 2))) (values (eqt x result) result)) t #*0011100) @@ -344,21 +344,21 @@ (deftest replace-bit-vector.8 (let* ((x (copy-seq #*0000000)) - (result (replace x #*111 :end1 1))) + (result (replace x #*111 :end1 1))) (values (eqt x result) result)) t #*1000000) (deftest replace-bit-vector.9 (let* ((x (copy-seq #*0000000)) - (result (replace x #*110 :start1 3 :end1 4))) + (result (replace x #*110 :start1 3 :end1 4))) (values (eqt x result) result)) t #*0001000) (deftest replace-bit-vector.10 (let* ((x (copy-seq #*0000000)) - (result (replace x #*111 :start1 0 :end1 5))) + (result (replace x #*111 :start1 0 :end1 5))) (values (eqt x result) result)) t #*1110000) @@ -366,76 +366,76 @@ (deftest replace-bit-vector.11 (let* ((x (copy-seq #*0000000)) - (result (replace x #*011 :start2 1))) + (result (replace x #*011 :start2 1))) (values (eqt x result) result)) t #*1100000) (deftest replace-bit-vector.12 (let* ((x (copy-seq #*0000000)) - (result (replace x #*011 :start2 1 :end1 nil))) + (result (replace x #*011 :start2 1 :end1 nil))) (values (eqt x result) result)) t #*1100000) (deftest replace-bit-vector.13 (let* ((x (copy-seq #*0000000)) - (result (replace x #*011 :start2 1 :end2 nil))) + (result (replace x #*011 :start2 1 :end2 nil))) (values (eqt x result) result)) t #*1100000) (deftest replace-bit-vector.14 (let* ((x (copy-seq #*0000000)) - (result (replace x #*011 :start2 1 :end2 2))) + (result (replace x #*011 :start2 1 :end2 2))) (values (eqt x result) result)) t #*1000000) (deftest replace-bit-vector.15 (let* ((x (copy-seq #*0000000)) - (result (replace x #*011 :start1 4 :end1 5 :start2 1 :end2 2))) + (result (replace x #*011 :start1 4 :end1 5 :start2 1 :end2 2))) (values (eqt x result) result)) t #*0000100) (deftest replace-bit-vector.16 (let* ((x (copy-seq #*001011)) - (y '(1 0 1)) - (result (replace x y :start1 1))) + (y '(1 0 1)) + (result (replace x y :start1 1))) (values (eqt x result) result)) t #*010111) (deftest replace-bit-vector.17 (let* ((x (copy-seq #*001011)) - (y (make-array '(3) :initial-contents '(1 0 1) - :fill-pointer t :element-type 'bit)) - (result (replace x y :start1 1))) + (y (make-array '(3) :initial-contents '(1 0 1) + :fill-pointer t :element-type 'bit)) + (result (replace x y :start1 1))) (values (eqt x result) result)) t #*010111) (deftest replace-bit-vector.18 (let* ((x (copy-seq #*001011)) - (y (make-array '(6) :initial-contents '(1 0 1 0 0 1) - :fill-pointer 3 - :element-type 'bit)) - (result (replace x y :start1 1))) + (y (make-array '(6) :initial-contents '(1 0 1 0 0 1) + :fill-pointer 3 + :element-type 'bit)) + (result (replace x y :start1 1))) (values (eqt x result) result)) t #*010111) (deftest replace-bit-vector.19 (let* ((x (copy-seq #*001011)) - (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) + (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) (values (eqt x result) result)) t #*010011) (deftest replace-bit-vector.21 (let* ((x (copy-seq #*001011)) - (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) + (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) (values (eqt x result) result)) t #*000111) @@ -444,42 +444,42 @@ (deftest replace-string.1 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz"))) + (result (replace x "xyz"))) (values (eqt x result) result)) t "xyzdefg") (deftest replace-string.2 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 1))) + (result (replace x "xyz" :start1 1))) (values (eqt x result) result)) t "axyzefg") (deftest replace-string.3 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 4))) + (result (replace x "xyz" :start1 4))) (values (eqt x result) result)) t "abcdxyz") (deftest replace-string.4 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 5))) + (result (replace x "xyz" :start1 5))) (values (eqt x result) result)) t "abcdexy") (deftest replace-string.5 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 6))) + (result (replace x "xyz" :start1 6))) (values (eqt x result) result)) t "abcdefx") (deftest replace-string.6 (let* ((x (copy-seq "abcdefg")) - (result (replace x '(#\x #\y #\z) :start1 2))) + (result (replace x '(#\x #\y #\z) :start1 2))) (values (eqt x result) result)) t "abxyzfg") @@ -490,21 +490,21 @@ (deftest replace-string.8 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :end1 1))) + (result (replace x "xyz" :end1 1))) (values (eqt x result) result)) t "xbcdefg") (deftest replace-string.9 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 3 :end1 4))) + (result (replace x "xyz" :start1 3 :end1 4))) (values (eqt x result) result)) t "abcxefg") (deftest replace-string.10 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 0 :end1 5))) + (result (replace x "xyz" :start1 0 :end1 5))) (values (eqt x result) result)) t "xyzdefg") @@ -512,76 +512,76 @@ (deftest replace-string.11 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start2 1))) + (result (replace x "xyz" :start2 1))) (values (eqt x result) result)) t "yzcdefg") (deftest replace-string.12 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start2 1 :end1 nil))) + (result (replace x "xyz" :start2 1 :end1 nil))) (values (eqt x result) result)) t "yzcdefg") (deftest replace-string.13 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start2 1 :end2 nil))) + (result (replace x "xyz" :start2 1 :end2 nil))) (values (eqt x result) result)) t "yzcdefg") (deftest replace-string.14 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start2 1 :end2 2))) + (result (replace x "xyz" :start2 1 :end2 2))) (values (eqt x result) result)) t "ybcdefg") (deftest replace-string.15 (let* ((x (copy-seq "abcdefg")) - (result (replace x "xyz" :start1 4 :end1 5 :start2 1 :end2 2))) + (result (replace x "xyz" :start1 4 :end1 5 :start2 1 :end2 2))) (values (eqt x result) result)) t "abcdyfg") (deftest replace-string.16 (let* ((x (copy-seq "abcdef")) - (y (coerce "123" 'list)) - (result (replace x y :start1 1))) + (y (coerce "123" 'list)) + (result (replace x y :start1 1))) (values (eqt x result) result)) t "a123ef") (deftest replace-string.17 (let* ((x (copy-seq "abcdef")) - (y (make-array '(3) :initial-contents '(#\1 #\2 #\3) - :fill-pointer t :element-type 'character)) - (result (replace x y :start1 1))) + (y (make-array '(3) :initial-contents '(#\1 #\2 #\3) + :fill-pointer t :element-type 'character)) + (result (replace x y :start1 1))) (values (eqt x result) result)) t "a123ef") (deftest replace-string.18 (let* ((x (copy-seq "abcdef")) - (y (make-array '(6) :initial-contents "123456" - :fill-pointer 3 - :element-type 'character)) - (result (replace x y :start1 1))) + (y (make-array '(6) :initial-contents "123456" + :fill-pointer 3 + :element-type 'character)) + (result (replace x y :start1 1))) (values (eqt x result) result)) t "a123ef") (deftest replace-string.19 (let* ((x (copy-seq "abcdef")) - (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) + (result (replace x x :start1 0 :end1 3 :start2 1 :end2 4))) (values (eqt x result) result)) t "bcddef") (deftest replace-string.21 (let* ((x (copy-seq "abcdef")) - (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) + (result (replace x x :start1 1 :end1 4 :start2 0 :end2 3))) (values (eqt x result) result)) t "aabcef") @@ -631,7 +631,7 @@ (let ((i 0) a b) (values (replace (progn (setf a (incf i)) (list 'a 'b 'c)) - (progn (setf b (incf i)) (list 'e 'f))) + (progn (setf b (incf i)) (list 'e 'f))) i a b)) (e f c) 2 1 2) @@ -639,12 +639,12 @@ (let ((i 0) a b c d e f) (values (replace (progn (setf a (incf i)) (list 'a 'b 'c)) - (progn (setf b (incf i)) (list 'e 'f)) - :start1 (progn (setf c (incf i)) 1) - :end1 (progn (setf d (incf i)) 3) - :start2 (progn (setf e (incf i)) 0) - :end2 (progn (setf f (incf i)) 2) - ) + (progn (setf b (incf i)) (list 'e 'f)) + :start1 (progn (setf c (incf i)) 1) + :end1 (progn (setf d (incf i)) 3) + :start2 (progn (setf e (incf i)) 0) + :end2 (progn (setf f (incf i)) 2) + ) i a b c d e f)) (a e f) 6 1 2 3 4 5 6) @@ -652,12 +652,12 @@ (let ((i 0) a b c d e f) (values (replace (progn (setf a (incf i)) (list 'a 'b 'c)) - (progn (setf b (incf i)) (list 'e 'f)) - :end2 (progn (setf c (incf i)) 2) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) 3) - :start1 (progn (setf f (incf i)) 1) - ) + (progn (setf b (incf i)) (list 'e 'f)) + :end2 (progn (setf c (incf i)) 2) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) 3) + :start1 (progn (setf f (incf i)) 1) + ) i a b c d e f)) (a e f) 6 1 2 3 4 5 6) @@ -681,7 +681,7 @@ (deftest replace.allow-other-keys.5 (replace (copy-seq "abcdefg") "xyz" :bad1 t :allow-other-keys t - :bad2 t :allow-other-keys nil :bad3 nil) + :bad2 t :allow-other-keys nil :bad3 nil) "xyzdefg") (deftest replace.allow-other-keys.6 @@ -690,7 +690,7 @@ (deftest replace.keywords.7 (replace (copy-seq "abcdefg") "xyz" :start1 0 :start2 0 :end1 3 :end2 3 - :start1 1 :start2 1 :end1 2 :end1 2) + :start1 1 :start2 1 :end1 2 :end1 2) "xyzdefg") diff --git a/ansi-tests/restart-bind.lsp b/ansi-tests/restart-bind.lsp index c8af54a7..152fb91e 100644 --- a/ansi-tests/restart-bind.lsp +++ b/ansi-tests/restart-bind.lsp @@ -11,7 +11,7 @@ (deftest restart-bind.2 (restart-bind () (values))) - + (deftest restart-bind.3 (restart-bind () (values 'a 'b 'c 'd 'e 'f)) a b c d e f) @@ -36,28 +36,28 @@ (deftest restart-bind.7 (block done (restart-bind ((foo #'(lambda () (return-from done 'good)))) - (invoke-restart 'foo) - 'bad)) + (invoke-restart 'foo) + 'bad)) good) (deftest restart-bind.8 (block done (restart-bind ((foo #'(lambda () (return-from done 'good)))) - (let ((restart (find-restart 'foo))) - (and (typep restart 'restart) - (invoke-restart restart))) - 'bad)) + (let ((restart (find-restart 'foo))) + (and (typep restart 'restart) + (invoke-restart restart))) + 'bad)) good) (deftest restart-bind.9 (restart-bind ((foo #'(lambda (a b c) (list c a b)))) - (invoke-restart 'foo 1 2 3)) + (invoke-restart 'foo 1 2 3)) (3 1 2)) (deftest restart-bind.10 (flet ((%f () (invoke-restart 'foo 'x 'y 'z))) (restart-bind ((foo #'(lambda (a b c) (list c a b)))) - (%f))) + (%f))) (z x y)) (deftest restart-bind.11 @@ -91,11 +91,11 @@ (let ((x 10) (y nil)) (restart-bind ((foo #'(lambda () - (when (> x 0) - (push 'a y) - (decf x) - (invoke-restart 'foo)) - y))) + (when (> x 0) + (push 'a y) + (decf x) + (invoke-restart 'foo)) + y))) (invoke-restart 'foo))) (a a a a a a a a a a)) @@ -103,9 +103,9 @@ (block done (let ((i 0)) (restart-bind ((foo (progn (incf i) - #'(lambda () (return-from done i))))) - (invoke-restart 'foo) - 'bad))) + #'(lambda () (return-from done i))))) + (invoke-restart 'foo) + 'bad))) 1) (deftest restart-bind.16 @@ -114,11 +114,11 @@ (with-output-to-string (s) (restart-bind - ((foo #'(lambda () nil) - :report-function (progn (incf i) - #'(lambda (s) (format s "A report"))))) - (let ((*print-escape* nil)) - (format s "~A" (find-restart 'foo))))) + ((foo #'(lambda () nil) + :report-function (progn (incf i) + #'(lambda (s) (format s "A report"))))) + (let ((*print-escape* nil)) + (format s "~A" (find-restart 'foo))))) i)) "A report" 1) @@ -153,10 +153,10 @@ (let ((c (make-condition 'error))) (restart-bind ((foo #'(lambda () 'bad) - :test-function #'(lambda (c1) (not (eq c c1)))) + :test-function #'(lambda (c1) (not (eq c c1)))) (foo #'(lambda () 'good) - :test-function #'(lambda (c2) (or (null c2) - (eq c c2))))) + :test-function #'(lambda (c2) (or (null c2) + (eq c c2))))) (invoke-restart (find-restart 'foo c)))) good) |# @@ -165,19 +165,19 @@ (let ((c (make-condition 'error))) (restart-bind ((foo #'(lambda () 'bad) - :test-function #'(lambda (c1) nil)) + :test-function #'(lambda (c1) nil)) (foo #'(lambda () 'good) - :test-function #'(lambda (c2) t))) + :test-function #'(lambda (c2) t))) (invoke-restart (find-restart 'foo c)))) good) (deftest restart-bind.22 (let ((c (make-condition 'error)) - (i 0)) + (i 0)) (values (restart-bind ((foo #'(lambda () 'good) - :test-function (progn (incf i) #'(lambda (c2) t)))) + :test-function (progn (incf i) #'(lambda (c2) t)))) (invoke-restart (find-restart 'foo c))) i)) good @@ -220,9 +220,9 @@ (values (restart-bind ((foo - #'(lambda (x y z) (list z y x)) - :interactive-function (progn (incf i) - #'(lambda () (list 'a 'b 'c))))) + #'(lambda (x y z) (list z y x)) + :interactive-function (progn (incf i) + #'(lambda () (list 'a 'b 'c))))) (invoke-restart-interactively 'foo)) i)) (c b a) diff --git a/ansi-tests/restart-case.lsp b/ansi-tests/restart-case.lsp index 0c452d5e..4137ca73 100644 --- a/ansi-tests/restart-case.lsp +++ b/ansi-tests/restart-case.lsp @@ -18,12 +18,12 @@ (deftest restart-case.4 (restart-case (progn (invoke-restart 'foo) 'bad) - (foo () 'good)) + (foo () 'good)) good) (deftest restart-case.5 (restart-case (progn (invoke-restart 'foo) 'bad) - (foo ())) + (foo ())) nil) (deftest restart-case.6 @@ -67,7 +67,7 @@ (deftest restart-case.12 (restart-case (restart-case (invoke-restart 'foo 1) - (foo (x) (invoke-restart 'foo (1+ x)))) + (foo (x) (invoke-restart 'foo (1+ x)))) (foo (y) (+ 4 y))) 6) @@ -75,7 +75,7 @@ (let ((i 10)) (values (restart-case (progn (invoke-restart 'foo) 'bad) - (foo () (incf i 100) 'good)) + (foo () (incf i 100) 'good)) i)) good 110) @@ -83,18 +83,18 @@ (restart-case (invoke-restart 'foo 1 2) (foo (x y) - (declare (type fixnum x)) - (declare (type fixnum y)) - (+ x y))) + (declare (type fixnum x)) + (declare (type fixnum y)) + (+ x y))) 3) (deftest restart-case.15 (restart-case (invoke-restart 'foo 1 2) (foo (x y) - (declare (ignore x y)) - (declare (type fixnum x)) - (declare (type fixnum y)))) + (declare (ignore x y)) + (declare (type fixnum x)) + (declare (type fixnum y)))) nil) (deftest restart-case.16 @@ -126,7 +126,7 @@ (s) (restart-case (let ((restart (find-restart 'foo)) - (*print-escape* nil)) + (*print-escape* nil)) (format s "~A" restart)) (foo () :report "A report"))) "A report") @@ -137,8 +137,8 @@ (flet ((%f (s2) (format s2 "A report"))) (restart-case (let ((restart (find-restart 'foo)) - (*print-escape* nil)) - (format s "~A" restart)) + (*print-escape* nil)) + (format s "~A" restart)) (foo () :report %f)))) "A report") @@ -147,7 +147,7 @@ (s) (restart-case (let ((restart (find-restart 'foo)) - (*print-escape* nil)) + (*print-escape* nil)) (format s "~A" restart)) (foo () :report (lambda (s2) (format s2 "A report"))))) "A report") @@ -231,8 +231,8 @@ ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case - (%m "Boo!") - (foo () 'bad)) + (%m "Boo!") + (foo () 'bad)) (foo () 'good))))) good) @@ -244,24 +244,24 @@ ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) (restart-case (restart-case - %s - (foo () 'bad)) + %s + (foo () 'bad)) (foo () 'good))))) good) (deftest restart-case.31 (macrolet ((%m2 (&rest args) (cons 'error args))) (macrolet ((%m (&rest args &environment env) - (macroexpand (cons '%m2 args) env))) + (macroexpand (cons '%m2 args) env))) (handler-bind ((error #'(lambda (c2) (invoke-restart (find-restart 'foo c2))))) (handler-bind - ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) - (restart-case - (restart-case - (%m "Boo!") - (foo () 'bad)) - (foo () 'good)))))) + ((error #'(lambda (c) (declare (ignore c)) (error "Blah")))) + (restart-case + (restart-case + (%m "Boo!") + (foo () 'bad)) + (foo () 'good)))))) good) (deftest restart-case.32 @@ -274,8 +274,8 @@ (restart-case (invoke-restart-interactively 'foo) (foo (w x y z) - :interactive (lambda () (list 'a 'b 'c 'd)) - (list x w z y))) + :interactive (lambda () (list 'a 'b 'c 'd)) + (list x w z y))) (b a d c)) (deftest restart-case.34 @@ -283,15 +283,15 @@ (restart-case (invoke-restart-interactively 'foo) (foo (w x y z) - :interactive %f - (list x w z y)))) + :interactive %f + (list x w z y)))) (b a d c)) (deftest restart-case.35 (restart-case (loop for i from 1 to 4 - for r in (compute-restarts) - collect (restart-name r)) + for r in (compute-restarts) + collect (restart-name r)) (foo () t) (bar () t) (foo () 'a) @@ -305,6 +305,6 @@ (restart-case (invoke-restart 'foo) (foo (&aux (y x)) - (declare (special x)) - y)))) - :good) \ No newline at end of file + (declare (special x)) + y)))) + :good) diff --git a/ansi-tests/return.lsp b/ansi-tests/return.lsp index bc033c62..b8bb1654 100644 --- a/ansi-tests/return.lsp +++ b/ansi-tests/return.lsp @@ -10,16 +10,16 @@ (deftest return.error.1 (signals-error (funcall (macro-function 'return)) program-error) t) - + (deftest return.error.2 (signals-error (funcall (macro-function 'return) '(return nil)) - program-error) + program-error) t) (deftest return.error.3 (signals-error (funcall (macro-function 'return) - '(return nil) nil nil) - program-error) + '(return nil) nil nil) + program-error) t) ;;; diff --git a/ansi-tests/revappend.lsp b/ansi-tests/revappend.lsp index ba18db90..028059fb 100644 --- a/ansi-tests/revappend.lsp +++ b/ansi-tests/revappend.lsp @@ -9,16 +9,16 @@ (deftest revappend.1 (let* ((x (list 'a 'b 'c)) - (y (list 'd 'e 'f)) - (xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y)) - ) + (y (list 'd 'e 'f)) + (xcopy (make-scaffold-copy x)) + (ycopy (make-scaffold-copy y)) + ) (let ((result (revappend x y))) - (and - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy) - (eqt (cdddr result) y) - result))) + (and + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy) + (eqt (cdddr result) y) + result))) (c b a d e f)) (deftest revappend.2 @@ -37,7 +37,7 @@ (let ((i 0) x y) (values (revappend (progn (setf x (incf i)) (copy-list '(a b c))) - (progn (setf y (incf i)) (copy-list '(d e f)))) + (progn (setf y (incf i)) (copy-list '(d e f)))) i x y)) (c b a d e f) 2 1 2) diff --git a/ansi-tests/reverse.lsp b/ansi-tests/reverse.lsp index db2411b2..a6a2cf9c 100644 --- a/ansi-tests/reverse.lsp +++ b/ansi-tests/reverse.lsp @@ -32,16 +32,16 @@ (deftest reverse-vector.4 (let* ((x (make-array 5 :initial-contents '(1 2 3 4 5) - :fill-pointer t :adjustable t)) - (y (reverse x))) + :fill-pointer t :adjustable t)) + (y (reverse x))) (values y x)) #(5 4 3 2 1) #(1 2 3 4 5)) (deftest reverse-vector.5 (let* ((x (make-array 10 :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 5)) - (y (reverse x))) + :fill-pointer 5)) + (y (reverse x))) y) #(5 4 3 2 1)) @@ -70,31 +70,31 @@ (deftest reverse-vector.8 (let ((len 10)) (loop for etype in '(short-float single-float double-float long-float rational) - for vals = (loop for i from 1 to len collect (coerce i etype)) - for vec = (make-array len :element-type etype :initial-contents vals) - for nvec = (reverse vec) - unless (and (eql (length nvec) len) - (typep nvec 'simple-array) - (not (eql vec nvec)) - (every #'eql (reverse vals) nvec) - (every #'eql vals vec)) - collect (list etype vals vec nvec))) + for vals = (loop for i from 1 to len collect (coerce i etype)) + for vec = (make-array len :element-type etype :initial-contents vals) + for nvec = (reverse vec) + unless (and (eql (length nvec) len) + (typep nvec 'simple-array) + (not (eql vec nvec)) + (every #'eql (reverse vals) nvec) + (every #'eql vals vec)) + collect (list etype vals vec nvec))) nil) (deftest reverse-vector.9 (let ((len 10)) (loop for cetype in '(short-float single-float double-float long-float rational integer) - for etype = `(complex ,cetype) - for vals = (loop for i from 1 to len collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for vec = (make-array len :element-type etype :initial-contents vals) - for nvec = (reverse vec) - unless (and (eql (length nvec) len) - (typep nvec 'simple-array) - (not (eql vec nvec)) - (every #'eql (reverse vals) nvec) - (every #'eql vals vec)) - collect (list etype vals vec nvec))) + for etype = `(complex ,cetype) + for vals = (loop for i from 1 to len collect (complex (coerce i cetype) + (coerce (- i) cetype))) + for vec = (make-array len :element-type etype :initial-contents vals) + for nvec = (reverse vec) + unless (and (eql (length nvec) len) + (typep nvec 'simple-array) + (not (eql vec nvec)) + (every #'eql (reverse vals) nvec) + (every #'eql vals vec)) + collect (list etype vals vec nvec))) nil) ;;; Bit vectors @@ -111,9 +111,9 @@ (deftest reverse-bit-vector.3 (let* ((x (make-array 10 :initial-contents '(0 0 0 1 1 0 1 0 1 0) - :fill-pointer 5 - :element-type 'bit)) - (y (reverse x))) + :fill-pointer 5 + :element-type 'bit)) + (y (reverse x))) y) #*11000) @@ -131,17 +131,17 @@ (deftest reverse-string.3 (let* ((x (make-array 10 :initial-contents "abcdefghij" - :fill-pointer 5 - :element-type 'character)) - (y (reverse x))) + :fill-pointer 5 + :element-type 'character)) + (y (reverse x))) y) "edcba") (deftest reverse-string.4 (let* ((x (make-array 10 :initial-contents "abcdefghij" - :fill-pointer 5 - :element-type 'base-char)) - (y (reverse x))) + :fill-pointer 5 + :element-type 'base-char)) + (y (reverse x))) y) "edcba") diff --git a/ansi-tests/room.lsp b/ansi-tests/room.lsp index 16d54632..ef09eb76 100644 --- a/ansi-tests/room.lsp +++ b/ansi-tests/room.lsp @@ -7,29 +7,29 @@ (deftest room.1 (let ((s (with-output-to-string - (*standard-output*) - (room)))) + (*standard-output*) + (room)))) (not (zerop (length s)))) t) (deftest room.2 (let ((s (with-output-to-string - (*standard-output*) - (room nil)))) + (*standard-output*) + (room nil)))) (not (zerop (length s)))) t) (deftest room.3 (let ((s (with-output-to-string - (*standard-output*) - (room :default)))) + (*standard-output*) + (room :default)))) (not (zerop (length s)))) t) (deftest room.4 (let ((s (with-output-to-string - (*standard-output*) - (room t)))) + (*standard-output*) + (room t)))) (not (zerop (length s)))) t) diff --git a/ansi-tests/rotatef.lsp b/ansi-tests/rotatef.lsp index bc226629..76af0ddf 100644 --- a/ansi-tests/rotatef.lsp +++ b/ansi-tests/rotatef.lsp @@ -7,7 +7,7 @@ (deftest rotatef-order.1 (let ((x (vector 'a 'b 'c 'd 'e 'f)) - (i 2)) + (i 2)) (values (rotatef (aref x (incf i)) (aref x (incf i))) x i)) @@ -17,7 +17,7 @@ (deftest rotatef-order.2 (let ((x (vector 'a 'b 'c 'd 'e 'f)) - (i 2)) + (i 2)) (values (rotatef (aref x (incf i)) (aref x (incf i)) (aref x (incf i))) x i)) @@ -37,15 +37,15 @@ (let ((x (vector 0 1 2 3 4 5 6 7 8 9))) (values (rotatef (aref x (aref x 0)) - (aref x (aref x 1)) - (aref x (aref x 2)) - (aref x (aref x 3)) - (aref x (aref x 4)) - (aref x (aref x 5)) - (aref x (aref x 6)) - (aref x (aref x 7)) - (aref x (aref x 8)) - (aref x (aref x 9))) + (aref x (aref x 1)) + (aref x (aref x 2)) + (aref x (aref x 3)) + (aref x (aref x 4)) + (aref x (aref x 5)) + (aref x (aref x 6)) + (aref x (aref x 7)) + (aref x (aref x 8)) + (aref x (aref x 9))) x)) nil #(1 2 3 4 5 6 7 8 9 0)) @@ -66,79 +66,79 @@ (let ((x 'a) (y 'b)) (values x y (rotatef x y) x y)) a b nil b a) - + ;;; ROTATEF is a good testbed for finding conflicts in setf expansions ;;; These tests apply rotatef to various accessors (deftest rotatef.6 (let* ((x (list 'a 'b)) - (y (list 'c 'd)) - (z 'e)) + (y (list 'c 'd)) + (z 'e)) (rotatef (car x) (car y) z) (values x y z)) (c b) (e d) a) (deftest rotatef.7 (let* ((x (list 'a 'b)) - (y (list 'c 'd)) - (z 'e)) + (y (list 'c 'd)) + (z 'e)) (rotatef (first x) (first y) z) (values x y z)) (c b) (e d) a) (deftest rotatef.8 (let* ((x (list 'a 'b)) - (y (list 'c 'd)) - (z '(e))) + (y (list 'c 'd)) + (z '(e))) (rotatef (cdr x) (cdr y) z) (values x y z)) (a d) (c e) (b)) (deftest rotatef.9 (let* ((x (list 'a 'b)) - (y (list 'c 'd)) - (z '(e))) + (y (list 'c 'd)) + (z '(e))) (rotatef (rest x) (rest y) z) (values x y z)) (a d) (c e) (b)) (deftest rotatef.10 (let* ((x (list 'a 'b)) - (y (list 'c 'd)) - (z 'e)) + (y (list 'c 'd)) + (z 'e)) (rotatef (cadr x) (cadr y) z) (values x y z)) (a d) (c e) b) (deftest rotatef.11 (let* ((x (list 'a 'b)) - (y (list 'c 'd)) - (z 'e)) + (y (list 'c 'd)) + (z 'e)) (rotatef (second x) (second y) z) (values x y z)) (a d) (c e) b) (deftest rotatef.12 (let* ((x (list 'a 'b 'c)) - (y (list 'd 'e 'f)) - (z (list 'g))) + (y (list 'd 'e 'f)) + (z (list 'g))) (rotatef (cddr x) (cddr y) z) (values x y z)) (a b f) (d e g) (c)) (deftest rotatef.13 (let* ((x (list (list 'a))) - (y (list (list 'c))) - (z 'e)) + (y (list (list 'c))) + (z 'e)) (rotatef (caar x) (caar y) z) (values x y z)) ((c)) ((e)) a) (deftest rotatef.14 (let* ((x (list (list 'a 'b))) - (y (list (list 'c 'd))) - (z (list 'e))) + (y (list (list 'c 'd))) + (z (list 'e))) (rotatef (cdar x) (cdar y) z) (values x y z)) ((a d)) ((c e)) (b)) @@ -148,67 +148,67 @@ (deftest rotatef.15 (let* ((x (vector 'a 'b)) - (y (vector 'c 'd)) - (z 'e)) + (y (vector 'c 'd)) + (z 'e)) (rotatef (aref x 0) (aref y 0) z) (values x y z)) #(c b) #(e d) a) (deftest rotatef.16 (let* ((x (vector 'a 'b)) - (y (vector 'c 'd)) - (z 'e)) + (y (vector 'c 'd)) + (z 'e)) (rotatef (svref x 0) (svref y 0) z) (values x y z)) #(c b) #(e d) a) (deftest rotatef.17 (let* ((x (copy-seq #*11000)) - (y (copy-seq #*11100)) - (z 1)) + (y (copy-seq #*11100)) + (z 1)) (rotatef (bit x 1) (bit y 3) z) (values x y z)) #*10000 #*11110 1) (deftest rotatef.18 (let* ((x (copy-seq "abcde")) - (y (copy-seq "fghij")) - (z #\X)) + (y (copy-seq "fghij")) + (z #\X)) (rotatef (char x 1) (char y 2) z) (values x y z)) "ahcde" "fgXij" #\b) (deftest rotatef.21 (let* ((x (copy-seq #*11000)) - (y (copy-seq #*11100)) - (z 1)) + (y (copy-seq #*11100)) + (z 1)) (rotatef (bit x 1) (bit y 3) z) (values x y z)) - #*10000 #*11110 1) + #*10000 #*11110 1) (deftest rotatef.22 (let* ((x (copy-seq "abcde")) - (y (copy-seq "fghij")) - (z #\X)) + (y (copy-seq "fghij")) + (z #\X)) (rotatef (char x 1) (char y 2) z) (values x y z)) "ahcde" "fgXij" #\b) (deftest rotatef.23 (let* ((x (copy-seq '(a b c d e))) - (y (copy-seq '(f g h i j))) - (z 'k)) + (y (copy-seq '(f g h i j))) + (z 'k)) (rotatef (elt x 1) (elt y 2) z) (values x y z)) (a h c d e) (f g k i j) b) (deftest rotatef.24 (let ((x #b01010101) - (y #b1111) - (z 0)) + (y #b1111) + (z 0)) (rotatef (ldb (byte 4 2) x) - (ldb (byte 4 1) y) - z) + (ldb (byte 4 1) y) + z) (values x y z)) #b01011101 1 @@ -216,31 +216,31 @@ (deftest rotatef.25 (let* ((f1 (gensym)) - (f2 (gensym)) - (fn1 (constantly :foo)) - (fn2 (constantly :bar)) - (fn3 (constantly :zzz))) + (f2 (gensym)) + (fn1 (constantly :foo)) + (fn2 (constantly :bar)) + (fn3 (constantly :zzz))) (setf (fdefinition f1) fn1 - (fdefinition f2) fn2) + (fdefinition f2) fn2) (rotatef (fdefinition f1) - (fdefinition f2) - fn3) + (fdefinition f2) + fn3) (values (funcall f1) (funcall f2) (funcall fn3))) :bar :zzz :foo) (deftest rotatef.26 (let* ((a1 (make-array '(10) :fill-pointer 5)) - (a2 (make-array '(20) :fill-pointer 7)) - (z 3)) + (a2 (make-array '(20) :fill-pointer 7)) + (z 3)) (rotatef (fill-pointer a1) (fill-pointer a2) z) (values (fill-pointer a1) (fill-pointer a2) z)) 7 3 5) (deftest rotatef.27 (let* ((x (list 'a 'b 'c 'd)) - (y (list 'd 'e 'f 'g)) - (n1 1) (n2 2) - (z 'h)) + (y (list 'd 'e 'f 'g)) + (n1 1) (n2 2) + (z 'h)) (rotatef (nth n1 x) (nth n2 y) z) (values x y z)) (a f c d) @@ -249,48 +249,48 @@ (deftest rotatef.28 (let* ((f1 (gensym)) - (f2 (gensym)) - (fn1 (constantly :foo)) - (fn2 (constantly :bar)) - (fn3 (constantly :zzz))) + (f2 (gensym)) + (fn1 (constantly :foo)) + (fn2 (constantly :bar)) + (fn3 (constantly :zzz))) (setf (symbol-function f1) fn1 - (symbol-function f2) fn2) + (symbol-function f2) fn2) (rotatef (symbol-function f1) (symbol-function f2) fn3) (values (funcall f1) (funcall f2) (funcall fn3))) :bar :zzz :foo) (deftest rotatef.29 (let* ((s1 (gensym)) - (s2 (gensym)) - (z 1)) + (s2 (gensym)) + (z 1)) (setf (symbol-value s1) :foo - (symbol-value s2) :bar) + (symbol-value s2) :bar) (rotatef (symbol-value s1) - (symbol-value s2) - z) + (symbol-value s2) + z) (values (symbol-value s1) (symbol-value s2) z)) :bar 1 :foo) (deftest rotatef.30 (let* ((s1 (gensym)) - (s2 (gensym)) - (v1 (list :foo 1)) - (v2 (list :bar 2)) - (z nil)) + (s2 (gensym)) + (v1 (list :foo 1)) + (v2 (list :bar 2)) + (z nil)) (setf (symbol-plist s1) v1 - (symbol-plist s2) v2) + (symbol-plist s2) v2) (rotatef (symbol-plist s1) (symbol-plist s2) z) (values (symbol-plist s1) (symbol-plist s2) z)) (:bar 2) nil (:foo 1)) (deftest rotatef.31 (let* ((x (list 'a 'b 'c 'd 'e)) - (y (list 'f 'g 'h 'i 'j)) - (p1 1) (p2 2) (len 3) - (z '(10 11 12))) + (y (list 'f 'g 'h 'i 'j)) + (p1 1) (p2 2) (len 3) + (z '(10 11 12))) (rotatef (subseq x p1 (+ p1 len)) - (subseq y p2 (+ p2 len)) - z) + (subseq y p2 (+ p2 len)) + z) (values x y z)) (a h i j e) (f g 10 11 12) @@ -298,12 +298,12 @@ (deftest rotatef.32 (let* ((x (gensym)) - (y (gensym)) - (k1 :foo) - (k2 :bar) - (v1 1) - (v2 2) - (z 17)) + (y (gensym)) + (k1 :foo) + (k2 :bar) + (v1 1) + (v2 2) + (z 17)) (setf (get x k1) v1 (get y k2) v2) (rotatef (get x k1) (get y k2) z) (values (symbol-plist x) (symbol-plist y) z)) @@ -311,12 +311,12 @@ (deftest rotatef.33 (let* ((x nil) - (y nil) - (k1 :foo) - (k2 :bar) - (v1 1) - (v2 2) - (z 21)) + (y nil) + (k1 :foo) + (k2 :bar) + (v1 1) + (v2 2) + (z 21)) (setf (getf x k1) v1 (getf y k2) v2) (rotatef (getf x k1) (getf y k2) z) (values x y z)) @@ -324,28 +324,28 @@ (deftest rotatef.34 (let* ((ht1 (make-hash-table)) - (ht2 (make-hash-table)) - (k1 :foo) (v1 1) - (k2 :bar) (v2 2) - (z 3)) + (ht2 (make-hash-table)) + (k1 :foo) (v1 1) + (k2 :bar) (v2 2) + (z 3)) (setf (gethash k1 ht1) v1 - (gethash k2 ht2) v2) + (gethash k2 ht2) v2) (rotatef z (gethash k1 ht1) (gethash k2 ht2)) (values z (gethash k1 ht1) (gethash k2 ht2))) 1 2 3) (deftest rotatef.35 (let ((n1 (gensym)) - (n2 (gensym)) - (n3 (gensym)) - (n4 (gensym))) + (n2 (gensym)) + (n3 (gensym)) + (n4 (gensym))) (eval `(defclass ,n1 () ())) (eval `(defclass ,n2 () ())) (setf (find-class n3) (find-class n1) - (find-class n4) (find-class n2)) + (find-class n4) (find-class n2)) (rotatef (find-class n3) (find-class n4)) (values (eqlt (find-class n1) (find-class n4)) - (eqlt (find-class n2) (find-class n3)))) + (eqlt (find-class n2) (find-class n3)))) t t) ;;; Test that explicit calls to macroexpand in subforms diff --git a/ansi-tests/round-aux.lsp b/ansi-tests/round-aux.lsp index 93fcb296..5eb4a44f 100644 --- a/ansi-tests/round-aux.lsp +++ b/ansi-tests/round-aux.lsp @@ -7,107 +7,107 @@ (defun round.1-fn () (loop for n = (- (random 2000000000) - 1000000000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (round n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (integerp r) - (<= (- (/ d 2)) r (/ d 2))) - unless (or (not (= (abs r) (/ d 2))) - (evenp q)) - collect (list n d q r n2))) + 1000000000) + for d = (1+ (random 10000)) + for vals = (multiple-value-list (round n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (= n n2) + (integerp r) + (<= (- (/ d 2)) r (/ d 2))) + unless (or (not (= (abs r) (/ d 2))) + (evenp q)) + collect (list n d q r n2))) (defun round.2-fn () (loop for num = (random 1000000000) - for denom = (1+ (random 1000)) - for n = (/ num denom) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (round n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (<= (- (/ d 2)) r (/ d 2)) - (or (not (= (abs r) (/ d 2))) - (evenp q)) - (= n n2)) - collect (list n d q r n2))) + for denom = (1+ (random 1000)) + for n = (/ num denom) + for d = (1+ (random 10000)) + for vals = (multiple-value-list (round n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (<= (- (/ d 2)) r (/ d 2)) + (or (not (= (abs r) (/ d 2))) + (evenp q)) + (= n n2)) + collect (list n d q r n2))) (defun round.3-fn (width) (loop for n = (- (random width) (/ width 2)) - for vals = (multiple-value-list (round n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (<= -1/2 r 1/2) - (or (not (= (abs r) 1/2)) - (evenp q)) - ) - collect (list n q r n2))) + for vals = (multiple-value-list (round n)) + for (q r) = vals + for n2 = (+ q r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (= n n2) + (<= -1/2 r 1/2) + (or (not (= (abs r) 1/2)) + (evenp q)) + ) + collect (list n q r n2))) (defun round.7-fn () (loop for numerator = (- (random 10000000000) 5000000000) - for denominator = (1+ (random 100000)) - for n = (/ numerator denominator) - for vals = (multiple-value-list (round n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (= n n2) - (<= -1/2 r 1/2) - (or (not (= (abs r) 1/2)) - (evenp q)) - ) - collect (list n q r n2))) + for denominator = (1+ (random 100000)) + for n = (/ numerator denominator) + for vals = (multiple-value-list (round n)) + for (q r) = vals + for n2 = (+ q r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (rationalp r) + (= n n2) + (<= -1/2 r 1/2) + (or (not (= (abs r) 1/2)) + (evenp q)) + ) + collect (list n q r n2))) (defun round.8-fn () (loop for num1 = (- (random 10000000000) 5000000000) - for den1 = (1+ (random 100000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000))) - for den2 = (1+ (random 1000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (round n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (<= (/ d 2) r (- (/ d 2))) - (or (not (= (abs r) (- (/ d 2)))) - (evenp q)) - (= n n2)) - collect (list n q d r n2))) + for den1 = (1+ (random 100000)) + for n = (/ num1 den1) + for num2 = (- (1+ (random 1000000))) + for den2 = (1+ (random 1000000)) + for d = (/ num2 den2) + for vals = (multiple-value-list (round n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (rationalp r) + (<= (/ d 2) r (- (/ d 2))) + (or (not (= (abs r) (- (/ d 2)))) + (evenp q)) + (= n n2)) + collect (list n q d r n2))) (defun round.9-fn () (loop for num1 = (- (random 1000000000000000) 500000000000000) - for den1 = (1+ (random 10000000000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000000))) - for den2 = (1+ (random 10000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (round n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (<= (/ d 2) r (- (/ d 2))) - (or (not (= (abs r) (- (/ d 2)))) - (evenp q)) - (= n n2)) - collect (list n q d r n2))) + for den1 = (1+ (random 10000000000)) + for n = (/ num1 den1) + for num2 = (- (1+ (random 1000000000))) + for den2 = (1+ (random 10000000)) + for d = (/ num2 den2) + for vals = (multiple-value-list (round n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (rationalp r) + (<= (/ d 2) r (- (/ d 2))) + (or (not (= (abs r) (- (/ d 2)))) + (evenp q)) + (= n n2)) + collect (list n q d r n2))) diff --git a/ansi-tests/round.lsp b/ansi-tests/round.lsp index 2b505858..94668a25 100644 --- a/ansi-tests/round.lsp +++ b/ansi-tests/round.lsp @@ -56,118 +56,118 @@ (deftest round.10 (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (round x x)) - unless (and (eql q 1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) + for (q r) = (multiple-value-list (round x x)) + unless (and (eql q 1) + (zerop r) + (if (rationalp x) (eql r 0) + (eql r (float 0 x)))) + collect x) nil) (deftest round.11 (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (round (- x) x)) - unless (and (eql q -1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) + for (q r) = (multiple-value-list (round (- x) x)) + unless (and (eql q -1) + (zerop r) + (if (rationalp x) (eql r 0) + (eql r (float 0 x)))) + collect x) nil) (deftest round.12 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 0.5s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 0.5s0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (round x)) + unless (and (eql q i) + (eql r rrad)) + collect (list i x q r))) nil) (deftest round.13 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 0.5s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 0.5s0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r (- rrad))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (round x)) + unless (and (eql q i) + (eql r (- rrad))) + collect (list i x q r))) nil) (deftest round.14 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 0.5f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 0.5f0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (round x)) + unless (and (eql q i) + (eql r rrad)) + collect (list i x q r))) nil) (deftest round.15 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 0.5f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 0.5f0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r (- rrad))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (round x)) + unless (and (eql q i) + (eql r (- rrad))) + collect (list i x q r))) nil) (deftest round.16 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 0.5d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 0.5d0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (round x)) + unless (and (eql q i) + (eql r rrad)) + collect (list i x q r))) nil) (deftest round.17 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 0.5d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 0.5d0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r (- rrad))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (round x)) + unless (and (eql q i) + (eql r (- rrad))) + collect (list i x q r))) nil) (deftest round.18 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 0.5l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 0.5l0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (round x)) + unless (and (eql q i) + (eql r rrad)) + collect (list i x q r))) nil) (deftest round.19 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 0.5l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 0.5l0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (round x)) - unless (and (eql q i) - (eql r (- rrad))) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (round x)) + unless (and (eql q i) + (eql r (- rrad))) + collect (list i x q r))) nil) (deftest round.20 diff --git a/ansi-tests/row-major-aref.lsp b/ansi-tests/row-major-aref.lsp index f54dd04f..01506015 100644 --- a/ansi-tests/row-major-aref.lsp +++ b/ansi-tests/row-major-aref.lsp @@ -51,7 +51,7 @@ (deftest row-major-aref.8 (let ((a (make-array '(4) :element-type 'base-char - :initial-element #\x))) + :initial-element #\x))) (values (aref a 0) (aref a 1) @@ -65,7 +65,7 @@ (deftest row-major-aref.9 (let ((a (make-array '(4) :initial-element 0 - :element-type 'bit))) + :element-type 'bit))) (values (aref a 0) (aref a 1) @@ -79,8 +79,8 @@ (deftest row-major-aref.10 (let ((a (make-array '(2 3 4) - :initial-contents '(((a b c d)(e f g h)(i j k l)) - ((m n o p)(q r s t)(u v w x)))))) + :initial-contents '(((a b c d)(e f g h)(i j k l)) + ((m n o p)(q r s t)(u v w x)))))) (loop for i from 0 to 23 collect (row-major-aref a i))) (a b c d e f g h i j k l m n o p q r s t u v w x)) @@ -95,7 +95,7 @@ (deftest row-major-aref.order.2 (let ((i 0) x y z - (a (copy-seq #(a b c d e f)))) + (a (copy-seq #(a b c d e f)))) (values (setf (row-major-aref diff --git a/ansi-tests/rplaca.lsp b/ansi-tests/rplaca.lsp index cb7c43d4..195bb6ef 100644 --- a/ansi-tests/rplaca.lsp +++ b/ansi-tests/rplaca.lsp @@ -11,17 +11,17 @@ (let ((x (cons 'a 'b))) (let ((y x)) (and (eqt (rplaca x 'c) y) - (eqt x y) - (eqt (car x) 'c) - (eqt (cdr x) 'b)))) + (eqt x y) + (eqt (car x) 'c) + (eqt (cdr x) 'b)))) t) (deftest rplaca.order.1 (let ((x (cons 'a 'b)) - (i 0) a b) + (i 0) a b) (values (rplaca (progn (setf a (incf i)) x) - (progn (setf b (incf i)) 'c)) + (progn (setf b (incf i)) 'c)) i a b)) (c . b) 2 1 2) diff --git a/ansi-tests/rplacd.lsp b/ansi-tests/rplacd.lsp index bf53c10b..6dd3e438 100644 --- a/ansi-tests/rplacd.lsp +++ b/ansi-tests/rplacd.lsp @@ -11,17 +11,17 @@ (let ((x (cons 'a 'b))) (let ((y x)) (and (eqt (rplacd x 'd) y) - (eqt x y) - (eqt (car x) 'a) - (eqt (cdr x) 'd)))) + (eqt x y) + (eqt (car x) 'a) + (eqt (cdr x) 'd)))) t) (deftest rplacd.order.1 (let ((x (cons 'a 'b)) - (i 0) a b) + (i 0) a b) (values (rplacd (progn (setf a (incf i)) x) - (progn (setf b (incf i)) 'c)) + (progn (setf b (incf i)) 'c)) i a b)) (a . c) 2 1 2) diff --git a/ansi-tests/rt-package.lsp b/ansi-tests/rt-package.lsp index fc7c00a8..ba0eb876 100644 --- a/ansi-tests/rt-package.lsp +++ b/ansi-tests/rt-package.lsp @@ -27,32 +27,32 @@ )) |# (let* ((name (symbol-name :regression-test)) - (pkg (find-package name))) + (pkg (find-package name))) (unless pkg (setq pkg (make-package name - :nicknames (mapcar #'symbol-name '(:rtest #-lispworks :rt)) - :use '(#-wcl :cl #+wcl :lisp) - ))) + :nicknames (mapcar #'symbol-name '(:rtest #-lispworks :rt)) + :use '(#-wcl :cl #+wcl :lisp) + ))) (let ((*package* pkg)) (export (mapcar #'intern - (mapcar #'symbol-name - '(#:*compile-tests* - #:*do-tests-when-defined* - #:*test* - #:continue-testing - #:deftest - #:do-test - #:do-tests - #:do-extended-tests - #:get-test - #:pending-tests - #:rem-all-tests - #:rem-test - #:defnote - #:my-aref - #:*catch-errors* - #:*passed-tests* - #:*failed-tests* - #:disable-note)))))) + (mapcar #'symbol-name + '(#:*compile-tests* + #:*do-tests-when-defined* + #:*test* + #:continue-testing + #:deftest + #:do-test + #:do-tests + #:do-extended-tests + #:get-test + #:pending-tests + #:rem-all-tests + #:rem-test + #:defnote + #:my-aref + #:*catch-errors* + #:*passed-tests* + #:*failed-tests* + #:disable-note)))))) ;; ) ;; (in-package :regression-test) diff --git a/ansi-tests/rt-test.lsp b/ansi-tests/rt-test.lsp index acde732c..60c9a96a 100644 --- a/ansi-tests/rt-test.lsp +++ b/ansi-tests/rt-test.lsp @@ -37,26 +37,26 @@ (defmacro with-blank-tests (&body body) `(let ((regression-test::*entries* (list nil)) - (regression-test::*entries-table* (make-hash-table :test #'equal)) - (*test* nil) - (regression-test::*in-test* nil)) + (regression-test::*entries-table* (make-hash-table :test #'equal)) + (*test* nil) + (regression-test::*in-test* nil)) (let ((regression-test::*entries-tail* regression-test::*entries*)) ,@body))) (defun do-setup (form) (with-blank-tests (let ((*do-tests-when-defined* nil) - (regression-test::*debug* t) - result) - (deftest t1 4 4) - (deftest (t 2) 4 3) - (values-list - (cons (normalize - (with-output-to-string (*standard-output*) - (setq result - (multiple-value-list - (catch 'regression-test::*debug* (eval form)))))) - result))))) + (regression-test::*debug* t) + result) + (deftest t1 4 4) + (deftest (t 2) 4 3) + (values-list + (cons (normalize + (with-output-to-string (*standard-output*) + (setq result + (multiple-value-list + (catch 'regression-test::*debug* (eval form)))))) + result))))) (defun normalize (string) (with-input-from-string (s string) @@ -66,10 +66,10 @@ (defun get-file-name () (loop (if *file-name* (return *file-name*)) - (format *error-output* - "~%Type a string representing naming of a scratch disk file: ") - (setq *file-name* (read)) - (if (not (stringp *file-name*)) (setq *file-name* nil)))) + (format *error-output* + "~%Type a string representing naming of a scratch disk file: ") + (setq *file-name* (read)) + (if (not (stringp *file-name*)) (setq *file-name* nil)))) (get-file-name) @@ -80,15 +80,15 @@ (defun get-file-output (f) (prog1 (with-open-file (in f) - (normalize-stream in)) - (delete-file f))) + (normalize-stream in)) + (delete-file f))) (defun normalize-stream (s) (let ((l nil)) (loop (push (read-line s nil s) l) - (when (eq (car l) s) - (setq l (nreverse (cdr l))) - (return nil))) + (when (eq (car l) s) + (setq l (nreverse (cdr l))) + (return nil))) (delete "" l :test #'equal))) (rem-all-tests) @@ -135,7 +135,7 @@ (deftest get-test-4 (setup (deftest t3 1 1) (get-test)) () (t3 1 1)) -(deftest get-test-5 +(deftest get-test-5 (setup (get-test 't0)) ("No test with name RT-TESTS::T0.") nil) @@ -146,7 +146,7 @@ (setup (values (rem-test '(t 2)) (pending-tests))) () (t 2) (t1)) (deftest rem-test-3 - (setup (let ((*test* '(t 2))) (rem-test)) (pending-tests)) + (setup (let ((*test* '(t 2))) (rem-test)) (pending-tests)) () (t1)) (deftest rem-test-4 (setup (values (rem-test 't0) (pending-tests))) @@ -160,11 +160,11 @@ () nil nil) (deftest rem-all-tests-2 (setup (rem-all-tests) (rem-all-tests) (pending-tests)) - () nil) + () nil) (deftest do-tests-1 (setup (let ((*print-case* :downcase)) - (values (do-tests) (continue-testing) (do-tests)))) + (values (do-tests) (continue-testing) (do-tests)))) ("Doing 2 pending tests of 2 tests total." " RT-TESTS::T1" "Test (T 2) failed" @@ -191,8 +191,8 @@ (deftest do-tests-2 (setup (rem-test '(t 2)) - (deftest (t 2) 3 3) - (values (do-tests) (continue-testing) (do-tests))) + (deftest (t 2) 3 3) + (values (do-tests) (continue-testing) (do-tests))) ("Doing 2 pending tests of 2 tests total." " RT-TESTS::T1 (T 2)" "No tests failed." diff --git a/ansi-tests/rt.system b/ansi-tests/rt.system index e0cce972..c30eea73 100644 --- a/ansi-tests/rt.system +++ b/ansi-tests/rt.system @@ -6,13 +6,13 @@ (mk::defsystem "rt" :source-pathname #.(directory-namestring *LOAD-TRUENAME*) :binary-pathname #.(mk::append-directories - (directory-namestring *LOAD-TRUENAME*) - "binary/") + (directory-namestring *LOAD-TRUENAME*) + "binary/") :source-extension "lsp" :binary-extension - #+CMU #.(C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) - #+ALLEGRO "fasl" - #+(OR AKCL GCL) "o" + #+CMU #.(C::BACKEND-FASL-FILE-TYPE C::*TARGET-BACKEND*) + #+ALLEGRO "fasl" + #+(OR AKCL GCL) "o" #+CLISP "fas" #-(OR CMU ALLEGRO AKCL GCL CLISP) #.(pathname-type (compile-file-pathname "foo.lisp")) diff --git a/ansi-tests/sbit.lsp b/ansi-tests/sbit.lsp index e11beea3..4775afe2 100644 --- a/ansi-tests/sbit.lsp +++ b/ansi-tests/sbit.lsp @@ -12,9 +12,9 @@ (deftest sbit.2 (let ((a #*00000000)) (loop for i from 0 below (length a) - collect (let ((b (copy-seq a))) - (setf (sbit b i) 1) - b))) + collect (let ((b (copy-seq a))) + (setf (sbit b i) 1) + b))) (#*10000000 #*01000000 #*00100000 @@ -27,9 +27,9 @@ (deftest sbit.3 (let ((a #*11111111)) (loop for i from 0 below (length a) - collect (let ((b (copy-seq a))) - (setf (sbit b i) 0) - b))) + collect (let ((b (copy-seq a))) + (setf (sbit b i) 0) + b))) (#*01111111 #*10111111 #*11011111 @@ -73,17 +73,17 @@ (let ((i 0) a b) (values (sbit (progn (setf a (incf i)) #*001001) - (progn (setf b (incf i)) 1)) + (progn (setf b (incf i)) 1)) i a b)) 0 2 1 2) (deftest sbit.order.2 (let ((i 0) a b c - (v (copy-seq #*001001))) + (v (copy-seq #*001001))) (values (setf (sbit (progn (setf a (incf i)) v) - (progn (setf b (incf i)) 1)) - (progn (setf c (incf i)) 1)) + (progn (setf b (incf i)) 1)) + (progn (setf c (incf i)) 1)) v i a b c)) 1 #*011001 3 1 2 3) @@ -91,5 +91,5 @@ (signals-error (sbit) program-error) t) - - \ No newline at end of file + + diff --git a/ansi-tests/search-aux.lsp b/ansi-tests/search-aux.lsp index 691c780b..c2e6c579 100644 --- a/ansi-tests/search-aux.lsp +++ b/ansi-tests/search-aux.lsp @@ -14,13 +14,13 @@ (remove-duplicates (let* ((s *searched-list*) (len (length s))) (loop for x from 0 to 8 nconc - (loop for y from 0 to (- len x) - collect (subseq s y (+ y x))))) + (loop for y from 0 to (- len x) + collect (subseq s y (+ y x))))) :test #'equal)) (defparameter *searched-vector* (make-array (length *searched-list*) - :initial-contents *searched-list*)) + :initial-contents *searched-list*)) (defparameter *pattern-subvectors* (mapcar #'(lambda (x) (apply #'vector x)) *pattern-sublists*)) @@ -32,8 +32,8 @@ (remove-duplicates (let* ((s *searched-bitvector*) (len (length s))) (loop for x from 0 to 8 nconc - (loop for y from 0 to (- len x) - collect (subseq s y (+ y x))))) + (loop for y from 0 to (- len x) + collect (subseq s y (+ y x))))) :test #'equalp)) (defparameter *searched-string* @@ -43,8 +43,8 @@ (remove-duplicates (let* ((s *searched-string*) (len (length s))) (loop for x from 0 to 8 nconc - (loop for y from 0 to (- len x) - collect (subseq s y (+ y x))))) + (loop for y from 0 to (- len x) + collect (subseq s y (+ y x))))) :test #'equalp)) (defun subseq-equalp (seq1 seq2 start1 start2 len &key (test #'equalp)) @@ -57,18 +57,18 @@ (setq test (coerce test 'function)) (if (and (listp seq1) (listp seq2)) (loop for i from 0 to (1- len) - for e1 in (nthcdr start1 seq1) - for e2 in (nthcdr start2 seq2) - always (funcall test e1 e2)) + for e1 in (nthcdr start1 seq1) + for e2 in (nthcdr start2 seq2) + always (funcall test e1 e2)) (loop for i from 0 to (1- len) - always - (funcall (the function test) - (elt seq1 (+ start1 i)) - (elt seq2 (+ start2 i)))))) + always + (funcall (the function test) + (elt seq1 (+ start1 i)) + (elt seq2 (+ start2 i)))))) (defun search-check (pattern searched pos - &key (start1 0) (end1 nil) (start2 0) (end2 nil) - key from-end (test #'equalp)) + &key (start1 0) (end1 nil) (start2 0) (end2 nil) + key from-end (test #'equalp)) (unless end1 (setq end1 (length pattern))) (unless end2 (setq end2 (length searched))) (assert (<= start1 end1)) @@ -78,16 +78,16 @@ (setq pattern (map 'list key pattern)) (setq searched (map 'list key searched))) (if pos - (and - (subseq-equalp searched pattern pos start1 plen :test test) - (if from-end - (loop for i from (1+ pos) to (- end2 plen) - never - (subseq-equalp searched pattern i start1 plen :test test)) - (loop for i from start2 to (1- pos) - never - (subseq-equalp searched pattern i start1 plen :test test)))) + (and + (subseq-equalp searched pattern pos start1 plen :test test) + (if from-end + (loop for i from (1+ pos) to (- end2 plen) + never + (subseq-equalp searched pattern i start1 plen :test test)) + (loop for i from start2 to (1- pos) + never + (subseq-equalp searched pattern i start1 plen :test test)))) (loop for i from start2 to (- end2 plen) - never (subseq-equalp searched pattern i start1 plen :test test))))) + never (subseq-equalp searched pattern i start1 plen :test test))))) diff --git a/ansi-tests/search-bitvector.lsp b/ansi-tests/search-bitvector.lsp index f73d47e7..404fdbaf 100644 --- a/ansi-tests/search-bitvector.lsp +++ b/ansi-tests/search-bitvector.lsp @@ -9,147 +9,147 @@ (deftest search-bitvector.1 (let ((target *searched-bitvector*) - (pat #*0)) + (pat #*0)) (loop for i from 0 to (1- (length target)) - for tail = (subseq target i) - always - (let ((pos (search pat tail))) - (search-check pat tail pos)))) + for tail = (subseq target i) + always + (let ((pos (search pat tail))) + (search-check pat tail pos)))) t) (deftest search-bitvector.2 (let ((target *searched-bitvector*) - (pat #*0)) + (pat #*0)) (loop for i from 1 to (length target) - always - (let ((pos (search pat target :end2 i :from-end t))) - (search-check pat target pos :end2 i :from-end t)))) + always + (let ((pos (search pat target :end2 i :from-end t))) + (search-check pat target pos :end2 i :from-end t)))) t) (deftest search-bitvector.3 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* - for pos = (search pat target) - unless (search-check pat target pos) - collect pat)) + for pos = (search pat target) + unless (search-check pat target pos) + collect pat)) nil) (deftest search-bitvector.4 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :from-end t) - unless (search-check pat target pos :from-end t) - collect pat)) + for pos = (search pat target :from-end t) + unless (search-check pat target pos :from-end t) + collect pat)) nil) (deftest search-bitvector.5 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :start2 25 :end2 75) - unless (search-check pat target pos :start2 25 :end2 75) - collect pat)) + for pos = (search pat target :start2 25 :end2 75) + unless (search-check pat target pos :start2 25 :end2 75) + collect pat)) nil) (deftest search-bitvector.6 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :from-end t :start2 25 :end2 75) - unless (search-check pat target pos :from-end t - :start2 25 :end2 75) - collect pat)) + for pos = (search pat target :from-end t :start2 25 :end2 75) + unless (search-check pat target pos :from-end t + :start2 25 :end2 75) + collect pat)) nil) (deftest search-bitvector.7 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :start2 20) - unless (search-check pat target pos :start2 20) - collect pat)) + for pos = (search pat target :start2 20) + unless (search-check pat target pos :start2 20) + collect pat)) nil) (deftest search-bitvector.8 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :from-end t :start2 20) - unless (search-check pat target pos :from-end t - :start2 20) - collect pat)) + for pos = (search pat target :from-end t :start2 20) + unless (search-check pat target pos :from-end t + :start2 20) + collect pat)) nil) (deftest search-bitvector.9 (let ((target *searched-bitvector*)) (loop for pat in (mapcar #'(lambda (x) - (map 'vector - #'(lambda (y) - (sublis '((a . 2) (b . 3)) y)) - x)) - *pattern-sublists*) - for pos = (search pat target :start2 20 :key #'evenp) - unless (search-check pat target pos :start2 20 :key #'evenp) - collect pat)) + (map 'vector + #'(lambda (y) + (sublis '((a . 2) (b . 3)) y)) + x)) + *pattern-sublists*) + for pos = (search pat target :start2 20 :key #'evenp) + unless (search-check pat target pos :start2 20 :key #'evenp) + collect pat)) nil) (deftest search-bitvector.10 (let ((target *searched-bitvector*)) (loop for pat in (mapcar #'(lambda (x) - (map 'vector - #'(lambda (y) - (sublis '((a . 2) (b . 3)) y)) - x)) - *pattern-sublists*) - for pos = (search pat target :from-end t :start2 20 :key 'oddp) - unless (search-check pat target pos :from-end t - :start2 20 :key 'oddp) - collect pat)) + (map 'vector + #'(lambda (y) + (sublis '((a . 2) (b . 3)) y)) + x)) + *pattern-sublists*) + for pos = (search pat target :from-end t :start2 20 :key 'oddp) + unless (search-check pat target pos :from-end t + :start2 20 :key 'oddp) + collect pat)) nil) (deftest search-bitvector.11 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :start2 20 :test (complement #'eql)) - unless (search-check pat target pos :start2 20 - :test (complement #'eql)) - collect pat)) + for pos = (search pat target :start2 20 :test (complement #'eql)) + unless (search-check pat target pos :start2 20 + :test (complement #'eql)) + collect pat)) nil) (deftest search-bitvector.12 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* - for pos = (search pat target :from-end t :start2 20 :test-not #'eql) - unless (search-check pat target pos :from-end t - :start2 20 :test (complement #'eql)) - collect pat)) + for pos = (search pat target :from-end t :start2 20 :test-not #'eql) + unless (search-check pat target pos :from-end t + :start2 20 :test (complement #'eql)) + collect pat)) nil) (deftest search-bitvector.13 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* - when (and (> (length pat) 0) - (let ((pos (search pat target :start1 1 - :test (complement #'eql)))) - (not (search-check pat target pos - :start1 1 - :test (complement #'eql))))) - collect pat)) + when (and (> (length pat) 0) + (let ((pos (search pat target :start1 1 + :test (complement #'eql)))) + (not (search-check pat target pos + :start1 1 + :test (complement #'eql))))) + collect pat)) nil) (deftest search-bitvector.14 (let ((target *searched-bitvector*)) (loop for pat in *pattern-subbitvectors* - when (let ((len (length pat))) - (and (> len 0) - (let ((pos (search pat target :end1 (1- len) - :test (complement #'eql)))) - (not (search-check pat target pos - :end1 (1- len) - :test (complement #'eql)))))) - collect pat)) + when (let ((len (length pat))) + (and (> len 0) + (let ((pos (search pat target :end1 (1- len) + :test (complement #'eql)))) + (not (search-check pat target pos + :end1 (1- len) + :test (complement #'eql)))))) + collect pat)) nil) (deftest search-bitvector.15 (let ((a (make-array '(10) :initial-contents '(0 1 1 0 0 0 1 0 1 1) - :fill-pointer 5 - :element-type 'bit))) + :fill-pointer 5 + :element-type 'bit))) (values (search #*0 a) (search #*0 a :from-end t) @@ -161,8 +161,8 @@ (deftest search-bitvector.16 (let ((pat (make-array '(3) :initial-contents '(0 1 0) - :fill-pointer 1)) - (a #*01100)) + :fill-pointer 1)) + (a #*01100)) (values (search pat a) (search pat a :from-end t) @@ -180,13 +180,13 @@ (deftest search-bitvector.17 (let ((pat #*10) - (target #*000011)) + (target #*000011)) (search pat target :test #'<=)) 4) (deftest search-bitvector.18 (let ((pat #*10) - (target #*000011)) + (target #*000011)) (search pat target :test-not #'>)) 4) diff --git a/ansi-tests/search-list.lsp b/ansi-tests/search-list.lsp index 34cd16da..2f57c063 100644 --- a/ansi-tests/search-list.lsp +++ b/ansi-tests/search-list.lsp @@ -9,144 +9,144 @@ (deftest search-list.1 (let ((target *searched-list*) - (pat '(a))) + (pat '(a))) (loop for i from 0 to (1- (length target)) - for tail on target - always - (let ((pos (search pat tail))) - (search-check pat tail pos)))) + for tail on target + always + (let ((pos (search pat tail))) + (search-check pat tail pos)))) t) (deftest search-list.2 (let ((target *searched-list*) - (pat '(a))) + (pat '(a))) (loop for i from 1 to (length target) - always - (let ((pos (search pat target :end2 i :from-end t))) - (search-check pat target pos :end2 i :from-end t)))) + always + (let ((pos (search pat target :end2 i :from-end t))) + (search-check pat target pos :end2 i :from-end t)))) t) (deftest search-list.3 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* - for pos = (search pat target) - unless (search-check pat target pos) - collect pat)) + for pos = (search pat target) + unless (search-check pat target pos) + collect pat)) nil) (deftest search-list.4 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* - for pos = (search pat target :from-end t) - unless (search-check pat target pos :from-end t) - collect pat)) + for pos = (search pat target :from-end t) + unless (search-check pat target pos :from-end t) + collect pat)) nil) (deftest search-list.5 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* - for pos = (search pat target :start2 25 :end2 75) - unless (search-check pat target pos :start2 25 :end2 75) - collect pat)) + for pos = (search pat target :start2 25 :end2 75) + unless (search-check pat target pos :start2 25 :end2 75) + collect pat)) nil) (deftest search-list.6 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* - for pos = (search pat target :from-end t :start2 25 :end2 75) - unless (search-check pat target pos :from-end t - :start2 25 :end2 75) - collect pat)) + for pos = (search pat target :from-end t :start2 25 :end2 75) + unless (search-check pat target pos :from-end t + :start2 25 :end2 75) + collect pat)) nil) (deftest search-list.7 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* - for pos = (search pat target :start2 20) - unless (search-check pat target pos :start2 20) - collect pat)) + for pos = (search pat target :start2 20) + unless (search-check pat target pos :start2 20) + collect pat)) nil) (deftest search-list.8 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* - for pos = (search pat target :from-end t :start2 20) - unless (search-check pat target pos :from-end t - :start2 20) - collect pat)) + for pos = (search pat target :from-end t :start2 20) + unless (search-check pat target pos :from-end t + :start2 20) + collect pat)) nil) (deftest search-list.9 (let ((target (sublis '((a . 1) (b . 2)) *searched-list*))) (loop for pat in (sublis '((a . 3) (b . 4)) *pattern-sublists*) - for pos = (search pat target :start2 20 :key #'evenp) - unless (search-check pat target pos :start2 20 :key #'evenp) - collect pat)) + for pos = (search pat target :start2 20 :key #'evenp) + unless (search-check pat target pos :start2 20 :key #'evenp) + collect pat)) nil) (deftest search-list.10 (let ((target (sublis '((a . 1) (b . 2)) *searched-list*))) (loop for pat in (sublis '((a . 3) (b . 4)) *pattern-sublists*) - for pos = (search pat target :from-end t :start2 20 :key 'oddp) - unless (search-check pat target pos :from-end t - :start2 20 :key 'oddp) - collect pat)) + for pos = (search pat target :from-end t :start2 20 :key 'oddp) + unless (search-check pat target pos :from-end t + :start2 20 :key 'oddp) + collect pat)) nil) (deftest search-list.11 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* - for pos = (search pat target :start2 20 :test (complement #'eql)) - unless (search-check pat target pos :start2 20 - :test (complement #'eql)) - collect pat)) + for pos = (search pat target :start2 20 :test (complement #'eql)) + unless (search-check pat target pos :start2 20 + :test (complement #'eql)) + collect pat)) nil) (deftest search-list.12 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* - for pos = (search pat target :from-end t :start2 20 :test-not #'eql) - unless (search-check pat target pos :from-end t - :start2 20 :test (complement #'eql)) - collect pat)) + for pos = (search pat target :from-end t :start2 20 :test-not #'eql) + unless (search-check pat target pos :from-end t + :start2 20 :test (complement #'eql)) + collect pat)) nil) (deftest search-list.13 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* - when (and (> (length pat) 0) - (let ((pos (search pat target :start1 1 - :test (complement #'eql)))) - (not (search-check pat target pos - :start1 1 - :test (complement #'eql))))) - collect pat)) + when (and (> (length pat) 0) + (let ((pos (search pat target :start1 1 + :test (complement #'eql)))) + (not (search-check pat target pos + :start1 1 + :test (complement #'eql))))) + collect pat)) nil) (deftest search-list.14 (let ((target *searched-list*)) (loop for pat in *pattern-sublists* - when (let ((len (length pat))) - (and (> len 0) - (let ((pos (search pat target :end1 (1- len) - :test (complement #'eql)))) - (not (search-check pat target pos - :end1 (1- len) - :test (complement #'eql)))))) - collect pat)) + when (let ((len (length pat))) + (and (> len 0) + (let ((pos (search pat target :end1 (1- len) + :test (complement #'eql)))) + (not (search-check pat target pos + :end1 (1- len) + :test (complement #'eql)))))) + collect pat)) nil) ;; Order of test, test-not (deftest search-list.15 (let ((pat '(10)) - (target '(1 4 6 10 15 20))) + (target '(1 4 6 10 15 20))) (search pat target :test #'<)) 4) (deftest search-list.16 (let ((pat '(10)) - (target '(1 4 6 10 15 20))) + (target '(1 4 6 10 15 20))) (search pat target :test-not #'>=)) 4) @@ -195,12 +195,12 @@ (deftest search.allow-other-keys.5 (search '(c d) '(a b c d c d e) :bad1 1 :allow-other-keys t :bad2 2 - :allow-other-keys nil :bad3 3) + :allow-other-keys nil :bad3 3) 2) (deftest search.allow-other-keys.6 (search '(c d) '(a b c d c d e) :allow-other-keys 'foo - :from-end t) + :from-end t) 4) (deftest search.allow-other-keys.7 @@ -209,7 +209,7 @@ (deftest search.keywords.8 (search '(c d) '(a b c d c d e) :start1 0 :start2 0 :start1 1 - :start2 6 :from-end t :from-end nil) + :start2 6 :from-end t :from-end nil) 4) @@ -289,4 +289,4 @@ :from-end (progn (setf j (incf i)) t) ) i a b c d e f g h j)) - 4 9 1 2 3 4 5 6 7 8 9) \ No newline at end of file + 4 9 1 2 3 4 5 6 7 8 9) diff --git a/ansi-tests/search-string.lsp b/ansi-tests/search-string.lsp index a0fcfda6..c498395b 100644 --- a/ansi-tests/search-string.lsp +++ b/ansi-tests/search-string.lsp @@ -13,130 +13,130 @@ #| (deftest search-string.1 (let ((target *searched-string*) - (pat #(a))) + (pat #(a))) (loop for i from 0 to (1- (length target)) - for tail on target - always - (let ((pos (search pat tail))) - (search-check pat tail pos)))) + for tail on target + always + (let ((pos (search pat tail))) + (search-check pat tail pos)))) t) |# (deftest search-string.2 (let ((target *searched-string*) - (pat #(a))) + (pat #(a))) (loop for i from 1 to (length target) - always - (let ((pos (search pat target :end2 i :from-end t))) - (search-check pat target pos :end2 i :from-end t)))) + always + (let ((pos (search pat target :end2 i :from-end t))) + (search-check pat target pos :end2 i :from-end t)))) t) (deftest search-string.3 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* - for pos = (search pat target) - unless (search-check pat target pos) - collect pat)) + for pos = (search pat target) + unless (search-check pat target pos) + collect pat)) nil) (deftest search-string.4 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* - for pos = (search pat target :from-end t) - unless (search-check pat target pos :from-end t) - collect pat)) + for pos = (search pat target :from-end t) + unless (search-check pat target pos :from-end t) + collect pat)) nil) (deftest search-string.5 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* - for pos = (search pat target :start2 25 :end2 75) - unless (search-check pat target pos :start2 25 :end2 75) - collect pat)) + for pos = (search pat target :start2 25 :end2 75) + unless (search-check pat target pos :start2 25 :end2 75) + collect pat)) nil) (deftest search-string.6 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* - for pos = (search pat target :from-end t :start2 25 :end2 75) - unless (search-check pat target pos :from-end t - :start2 25 :end2 75) - collect pat)) + for pos = (search pat target :from-end t :start2 25 :end2 75) + unless (search-check pat target pos :from-end t + :start2 25 :end2 75) + collect pat)) nil) (deftest search-string.7 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* - for pos = (search pat target :start2 20) - unless (search-check pat target pos :start2 20) - collect pat)) + for pos = (search pat target :start2 20) + unless (search-check pat target pos :start2 20) + collect pat)) nil) (deftest search-string.8 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* - for pos = (search pat target :from-end t :start2 20) - unless (search-check pat target pos :from-end t - :start2 20) - collect pat)) + for pos = (search pat target :from-end t :start2 20) + unless (search-check pat target pos :from-end t + :start2 20) + collect pat)) nil) (deftest search-string.9 (flet ((%f (x) (case x ((#\0 a) 'c) ((#\1 b) 'd) (t nil)))) (let ((target *searched-string*)) (loop for pat in *pattern-sublists* - for pos = (search pat target :start2 20 :key #'%f) - unless (search-check pat target pos :start2 20 :key #'%f) - collect pat))) + for pos = (search pat target :start2 20 :key #'%f) + unless (search-check pat target pos :start2 20 :key #'%f) + collect pat))) nil) (deftest search-string.10 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* - for pos = (search pat target :start2 20 :test (complement #'eql)) - unless (search-check pat target pos :start2 20 - :test (complement #'eql)) - collect pat)) + for pos = (search pat target :start2 20 :test (complement #'eql)) + unless (search-check pat target pos :start2 20 + :test (complement #'eql)) + collect pat)) nil) (deftest search-string.11 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* - for pos = (search pat target :from-end t :start2 20 :test-not #'eql) - unless (search-check pat target pos :from-end t - :start2 20 :test (complement #'eql)) - collect pat)) + for pos = (search pat target :from-end t :start2 20 :test-not #'eql) + unless (search-check pat target pos :from-end t + :start2 20 :test (complement #'eql)) + collect pat)) nil) (deftest search-string.13 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* - when (and (> (length pat) 0) - (let ((pos (search pat target :start1 1 - :test (complement #'eql)))) - (not (search-check pat target pos - :start1 1 - :test (complement #'eql))))) - collect pat)) + when (and (> (length pat) 0) + (let ((pos (search pat target :start1 1 + :test (complement #'eql)))) + (not (search-check pat target pos + :start1 1 + :test (complement #'eql))))) + collect pat)) nil) (deftest search-string.14 (let ((target *searched-string*)) (loop for pat in *pattern-substrings* - when (let ((len (length pat))) - (and (> len 0) - (let ((pos (search pat target :end1 (1- len) - :test (complement #'eql)))) - (not (search-check pat target pos - :end1 (1- len) - :test (complement #'eql)))))) - collect pat)) + when (let ((len (length pat))) + (and (> len 0) + (let ((pos (search pat target :end1 (1- len) + :test (complement #'eql)))) + (not (search-check pat target pos + :end1 (1- len) + :test (complement #'eql)))))) + collect pat)) nil) (deftest search-string.15 (let ((a (make-array '(10) :initial-contents "abbaaababb" - :fill-pointer 5 - :element-type 'character))) + :fill-pointer 5 + :element-type 'character))) (values (search "a" a) (search "a" a :from-end t) @@ -148,8 +148,8 @@ (deftest search-string.16 (let ((pat (make-array '(3) :initial-contents '(#\a #\b #\a) - :fill-pointer 1)) - (a "abbaa")) + :fill-pointer 1)) + (a "abbaa")) (values (search pat a) (search pat a :from-end t) @@ -167,13 +167,13 @@ (deftest search-string.17 (let ((pat "m") - (target '"adgmnpq")) + (target '"adgmnpq")) (search pat target :test #'char<)) 4) (deftest search-string.18 (let ((pat "m") - (target '"adgmnpq")) + (target '"adgmnpq")) (search pat target :test-not #'char>=)) 4) diff --git a/ansi-tests/search-vector.lsp b/ansi-tests/search-vector.lsp index d2723efd..d441c35a 100644 --- a/ansi-tests/search-vector.lsp +++ b/ansi-tests/search-vector.lsp @@ -9,148 +9,148 @@ (deftest search-vector.1 (let ((target *searched-vector*) - (pat #(a))) + (pat #(a))) (loop for i from 0 to (1- (length target)) - for tail = (subseq target i) - always - (let ((pos (search pat tail))) - (search-check pat tail pos)))) + for tail = (subseq target i) + always + (let ((pos (search pat tail))) + (search-check pat tail pos)))) t) (deftest search-vector.2 (let ((target *searched-vector*) - (pat #(a))) + (pat #(a))) (loop for i from 1 to (length target) - always - (let ((pos (search pat target :end2 i :from-end t))) - (search-check pat target pos :end2 i :from-end t)))) + always + (let ((pos (search pat target :end2 i :from-end t))) + (search-check pat target pos :end2 i :from-end t)))) t) (deftest search-vector.3 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* - for pos = (search pat target) - unless (search-check pat target pos) - collect pat)) + for pos = (search pat target) + unless (search-check pat target pos) + collect pat)) nil) (deftest search-vector.4 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* - for pos = (search pat target :from-end t) - unless (search-check pat target pos :from-end t) - collect pat)) + for pos = (search pat target :from-end t) + unless (search-check pat target pos :from-end t) + collect pat)) nil) (deftest search-vector.5 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* - for pos = (search pat target :start2 25 :end2 75) - unless (search-check pat target pos :start2 25 :end2 75) - collect pat)) + for pos = (search pat target :start2 25 :end2 75) + unless (search-check pat target pos :start2 25 :end2 75) + collect pat)) nil) (deftest search-vector.6 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* - for pos = (search pat target :from-end t :start2 25 :end2 75) - unless (search-check pat target pos :from-end t - :start2 25 :end2 75) - collect pat)) + for pos = (search pat target :from-end t :start2 25 :end2 75) + unless (search-check pat target pos :from-end t + :start2 25 :end2 75) + collect pat)) nil) (deftest search-vector.7 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* - for pos = (search pat target :start2 20) - unless (search-check pat target pos :start2 20) - collect pat)) + for pos = (search pat target :start2 20) + unless (search-check pat target pos :start2 20) + collect pat)) nil) (deftest search-vector.8 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* - for pos = (search pat target :from-end t :start2 20) - unless (search-check pat target pos :from-end t - :start2 20) - collect pat)) + for pos = (search pat target :from-end t :start2 20) + unless (search-check pat target pos :from-end t + :start2 20) + collect pat)) nil) (deftest search-vector.9 (let ((target (map 'vector #'(lambda (x) (sublis '((a . 1) (b . 2)) x)) - *searched-list*))) + *searched-list*))) (loop for pat in (mapcar #'(lambda (x) - (map 'vector - #'(lambda (y) - (sublis '((a . 3) (b . 4)) y)) - x)) - *pattern-sublists*) - for pos = (search pat target :start2 20 :key #'evenp) - unless (search-check pat target pos :start2 20 :key #'evenp) - collect pat)) + (map 'vector + #'(lambda (y) + (sublis '((a . 3) (b . 4)) y)) + x)) + *pattern-sublists*) + for pos = (search pat target :start2 20 :key #'evenp) + unless (search-check pat target pos :start2 20 :key #'evenp) + collect pat)) nil) (deftest search-vector.10 (let ((target (map 'vector #'(lambda (x) (sublis '((a . 1) (b . 2)) x)) - *searched-list*))) + *searched-list*))) (loop for pat in (mapcar #'(lambda (x) - (map 'vector - #'(lambda (y) - (sublis '((a . 3) (b . 4)) y)) - x)) - *pattern-sublists*) - for pos = (search pat target :from-end t :start2 20 :key 'oddp) - unless (search-check pat target pos :from-end t - :start2 20 :key 'oddp) - collect pat)) + (map 'vector + #'(lambda (y) + (sublis '((a . 3) (b . 4)) y)) + x)) + *pattern-sublists*) + for pos = (search pat target :from-end t :start2 20 :key 'oddp) + unless (search-check pat target pos :from-end t + :start2 20 :key 'oddp) + collect pat)) nil) (deftest search-vector.11 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* - for pos = (search pat target :start2 20 :test (complement #'eql)) - unless (search-check pat target pos :start2 20 - :test (complement #'eql)) - collect pat)) + for pos = (search pat target :start2 20 :test (complement #'eql)) + unless (search-check pat target pos :start2 20 + :test (complement #'eql)) + collect pat)) nil) (deftest search-vector.12 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* - for pos = (search pat target :from-end t :start2 20 :test-not #'eql) - unless (search-check pat target pos :from-end t - :start2 20 :test (complement #'eql)) - collect pat)) + for pos = (search pat target :from-end t :start2 20 :test-not #'eql) + unless (search-check pat target pos :from-end t + :start2 20 :test (complement #'eql)) + collect pat)) nil) (deftest search-vector.13 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* - when (and (> (length pat) 0) - (let ((pos (search pat target :start1 1 - :test (complement #'eql)))) - (not (search-check pat target pos - :start1 1 - :test (complement #'eql))))) - collect pat)) + when (and (> (length pat) 0) + (let ((pos (search pat target :start1 1 + :test (complement #'eql)))) + (not (search-check pat target pos + :start1 1 + :test (complement #'eql))))) + collect pat)) nil) (deftest search-vector.14 (let ((target *searched-vector*)) (loop for pat in *pattern-subvectors* - when (let ((len (length pat))) - (and (> len 0) - (let ((pos (search pat target :end1 (1- len) - :test (complement #'eql)))) - (not (search-check pat target pos - :end1 (1- len) - :test (complement #'eql)))))) - collect pat)) + when (let ((len (length pat))) + (and (> len 0) + (let ((pos (search pat target :end1 (1- len) + :test (complement #'eql)))) + (not (search-check pat target pos + :end1 (1- len) + :test (complement #'eql)))))) + collect pat)) nil) (deftest search-vector.15 (let ((a (make-array '(10) :initial-contents '(a b b a a a b a b b) - :fill-pointer 5))) + :fill-pointer 5))) (values (search '(a) a) (search '(a) a :from-end t) @@ -162,8 +162,8 @@ (deftest search-vector.16 (let ((pat (make-array '(3) :initial-contents '(a b a) - :fill-pointer 1)) - (a #(a b b a a))) + :fill-pointer 1)) + (a #(a b b a a))) (values (search pat a) (search pat a :from-end t) @@ -181,12 +181,12 @@ (deftest search-vector.17 (let ((pat #(10)) - (target #(1 4 6 10 15 20))) + (target #(1 4 6 10 15 20))) (search pat target :test #'<)) 4) (deftest search-vector.18 (let ((pat #(10)) - (target #(1 4 6 10 15 20))) + (target #(1 4 6 10 15 20))) (search pat target :test-not #'>=)) - 4) \ No newline at end of file + 4) diff --git a/ansi-tests/set-difference.lsp b/ansi-tests/set-difference.lsp index 6bb8359f..9216417e 100644 --- a/ansi-tests/set-difference.lsp +++ b/ansi-tests/set-difference.lsp @@ -13,13 +13,13 @@ (deftest set-difference.2 (let ((result - (set-difference-with-check '(a b c) nil))) + (set-difference-with-check '(a b c) nil))) (check-set-difference '(a b c) nil result)) t) (deftest set-difference.3 (let ((result - (set-difference-with-check '(a b c d e f) '(f b d)))) + (set-difference-with-check '(a b c d e f) '(f b d)))) (check-set-difference '(a b c d e f) '(f b d) result)) t) @@ -27,7 +27,7 @@ (sort (copy-list (set-difference-with-check (shuffle '(1 2 3 4 5 6 7 8)) - '(10 101 4 74 2 1391 7 17831))) + '(10 101 4 74 2 1391 7 17831))) #'<) (1 3 5 6 8)) @@ -37,7 +37,7 @@ (deftest set-difference.6 (set-difference-with-check '(a b c d e) '(d a b e) - :key nil) + :key nil) (c)) (deftest set-difference.7 @@ -54,17 +54,17 @@ (deftest set-difference.10 (set-difference-with-check '(a b c d e) '(d a b e) - :test 'eq) + :test 'eq) (c)) (deftest set-difference.11 (set-difference-with-check '(a b c d e) '(d a b e) - :test 'eql) + :test 'eql) (c)) (deftest set-difference.12 (set-difference-with-check '(a b c d e) '(d a b e) - :test 'equal) + :test 'equal) (c)) (deftest set-difference.13 @@ -73,14 +73,14 @@ (deftest set-difference.14 (set-difference-with-check '((a . 1) (b . 2) (c . 3)) - '((a . 1) (c . 3)) - :key 'car) + '((a . 1) (c . 3)) + :key 'car) ((b . 2))) (deftest set-difference.15 (set-difference-with-check '((a . 1) (b . 2) (c . 3)) - '((a . 1) (c . 3)) - :key #'car) + '((a . 1) (c . 3)) + :key #'car) ((b . 2))) ;; @@ -94,10 +94,10 @@ (set-difference-with-check '(1 2 3 4) '(e f g h) :test #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (eqt x y)))) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (eqt x y)))) #'<)) (1 2 3 4)) @@ -109,10 +109,10 @@ '(1 2 3 4) '(e f g h) :key #'identity :test #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (eqt x y)))) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (eqt x y)))) #'<)) (1 2 3 4)) @@ -124,10 +124,10 @@ '(1 2 3 4) '(e f g h) :test-not #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (not (eqt x y))))) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (not (eqt x y))))) #'<)) (1 2 3 4)) @@ -139,10 +139,10 @@ '(1 2 3 4) '(e f g h) :test-not #'(lambda (x y) - (when (or (member x '(e f g h)) - (member y '(1 2 3 4))) - (return-from fail 'fail)) - (not (eqt x y))))) + (when (or (member x '(e f g h)) + (member y '(1 2 3 4))) + (return-from fail 'fail)) + (not (eqt x y))))) #'<)) (1 2 3 4)) @@ -158,7 +158,7 @@ (let ((i 0) x y) (values (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4))) + (progn (setf y (incf i)) (list 2 3 4))) i x y)) (1) 2 1 2) @@ -166,9 +166,9 @@ (let ((i 0) x y z) (values (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4)) - :test (progn (setf z (incf i)) - #'(lambda (x y) (= x (1- y))))) + (progn (setf y (incf i)) (list 2 3 4)) + :test (progn (setf z (incf i)) + #'(lambda (x y) (= x (1- y))))) i x y z)) (4) 3 1 2 3) @@ -176,10 +176,10 @@ (let ((i 0) x y z w) (values (set-difference (progn (setf x (incf i)) (list 1 2 3 4)) - (progn (setf y (incf i)) (list 2 3 4)) - :test (progn (setf z (incf i)) - #'(lambda (x y) (= x (1- y)))) - :key (progn (setf w (incf i)) nil)) + (progn (setf y (incf i)) (list 2 3 4)) + :test (progn (setf z (incf i)) + #'(lambda (x y) (= x (1- y)))) + :key (progn (setf w (incf i)) nil)) i x y z w)) (4) 4 1 2 3 4) diff --git a/ansi-tests/set-exclusive-or.lsp b/ansi-tests/set-exclusive-or.lsp index 0d7575a3..fa508d5c 100644 --- a/ansi-tests/set-exclusive-or.lsp +++ b/ansi-tests/set-exclusive-or.lsp @@ -13,13 +13,13 @@ (deftest set-exclusive-or.2 (let ((result - (set-exclusive-or-with-check '(a b c) nil))) + (set-exclusive-or-with-check '(a b c) nil))) (check-set-exclusive-or '(a b c) nil result)) t) (deftest set-exclusive-or.3 (let ((result - (set-exclusive-or-with-check '(a b c d e f) '(f b d)))) + (set-exclusive-or-with-check '(a b c d e f) '(f b d)))) (check-set-exclusive-or '(a b c d e f) '(f b d) result)) t) @@ -27,7 +27,7 @@ (sort (copy-list (set-exclusive-or-with-check (shuffle '(1 2 3 4 5 6 7 8)) - '(10 101 4 74 2 1391 7 17831))) + '(10 101 4 74 2 1391 7 17831))) #'<) (1 3 5 6 8 10 74 101 1391 17831)) @@ -40,7 +40,7 @@ (deftest set-exclusive-or.6 (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :key nil) + :key nil) (c)) (deftest set-exclusive-or.7 @@ -61,7 +61,7 @@ (deftest set-exclusive-or.8-b (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :test-not (complement #'eql)) + :test-not (complement #'eql)) (c)) (deftest set-exclusive-or.9 @@ -70,17 +70,17 @@ (deftest set-exclusive-or.10 (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'eq) + :test 'eq) (c)) (deftest set-exclusive-or.11 (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'eql) + :test 'eql) (c)) (deftest set-exclusive-or.12 (set-exclusive-or-with-check '(a b c d e) '(d a b e) - :test 'equal) + :test 'equal) (c)) ;;; (deftest set-exclusive-or.13 @@ -89,21 +89,21 @@ (deftest set-exclusive-or.14 (set-exclusive-or-with-check '((a . 1) (b . 2) (c . 3012)) - '((a . 10) (c . 3)) - :key 'car) + '((a . 10) (c . 3)) + :key 'car) ((b . 2))) (deftest set-exclusive-or.15 (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) - '((a . 1) (c . 3313)) - :key #'car) + '((a . 1) (c . 3313)) + :key #'car) ((b . 2))) (deftest set-exclusive-or.16 (set-exclusive-or-with-check '((a . xx) (b . 2) (c . 3)) - '((a . 1) (c . 3313)) - :key #'car - :test-not (complement #'eql)) + '((a . 1) (c . 3313)) + :key #'car + :test-not (complement #'eql)) ((b . 2))) ;; @@ -112,69 +112,69 @@ ;; (deftest set-exclusive-or.17 (let ((list1 '(a b c d)) - (list2 '(e f g h))) + (list2 '(e f g h))) (block fail (notnot-mv (set-exclusive-or-with-check - list1 list2 - :test #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed))))))) + list1 list2 + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed))))))) t) (deftest set-exclusive-or.17-a (let ((list1 '(a b c d)) - (list2 '(e f g h))) + (list2 '(e f g h))) (block fail (notnot-mv (set-exclusive-or-with-check - list1 list2 - :key #'identity - :test #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed))))))) + list1 list2 + :key #'identity + :test #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed))))))) t) (deftest set-exclusive-or.18 (let ((list1 '(a b c d)) - (list2 '(e f g h))) + (list2 '(e f g h))) (block fail (notnot-mv (set-exclusive-or-with-check - list1 list2 - :test-not - #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed)) - t))))) + list1 list2 + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t))))) t) (deftest set-exclusive-or.18-a (let ((list1 '(a b c d)) - (list2 '(e f g h))) + (list2 '(e f g h))) (block fail (notnot-mv (set-exclusive-or-with-check - list1 list2 - :key #'identity - :test-not - #'(lambda (s1 s2) - (when (or (member s1 list2) - (member s2 list1)) - (return-from fail 'failed)) - t))))) + list1 list2 + :key #'identity + :test-not + #'(lambda (s1 s2) + (when (or (member s1 list2) + (member s2 list1)) + (return-from fail 'failed)) + t))))) t) (defharmless set-exclusive-or.test-and-test-not.1 (set-exclusive-or (list 1 2 3 4) (list 1 7 3 8) - :test #'eql :test-not #'eql)) + :test #'eql :test-not #'eql)) (defharmless set-exclusive-or.test-and-test-not.2 (set-exclusive-or (list 1 2 3 4) (list 1 7 3 8) - :test-not #'eql :test #'eql)) + :test-not #'eql :test #'eql)) ;;; Order of argument evaluation tests @@ -184,9 +184,9 @@ (values (sort (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10))) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10))) #'<) i x y)) (2 4 6 10) 2 1 2) @@ -196,11 +196,11 @@ (values (sort (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :test (progn (setf z (incf i)) - #'eql)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :test (progn (setf z (incf i)) + #'eql)) #'<) i x y z)) (2 4 6 10) 3 1 2 3) @@ -210,12 +210,12 @@ (values (sort (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :test (progn (setf z (incf i)) - #'eql) - :key (progn (setf w (incf i)) nil)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :test (progn (setf z (incf i)) + #'eql) + :key (progn (setf w (incf i)) nil)) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) @@ -225,12 +225,12 @@ (values (sort (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :key (progn (setf z (incf i)) nil) - :test (progn (setf w (incf i)) - #'eql)) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :key (progn (setf z (incf i)) nil) + :test (progn (setf w (incf i)) + #'eql)) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) @@ -240,12 +240,12 @@ (values (sort (set-exclusive-or (progn (setf x (incf i)) - (list 1 2 3 4)) - (progn (setf y (incf i)) - (list 1 3 6 10)) - :key (progn (setf z (incf i)) nil) - :key (progn (setf w (incf i)) - (complement #'eql))) + (list 1 2 3 4)) + (progn (setf y (incf i)) + (list 1 3 6 10)) + :key (progn (setf z (incf i)) nil) + :key (progn (setf w (incf i)) + (complement #'eql))) #'<) i x y z w)) (2 4 6 10) 4 1 2 3 4) @@ -255,62 +255,62 @@ (deftest set-exclusive.allow-other-keys.1 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :bad t :allow-other-keys t) - #'<) + :bad t :allow-other-keys t) + #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.2 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t :bad t) - #'<) + :allow-other-keys t :bad t) + #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.3 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t :bad t - :test #'(lambda (x y) (= x (1- y)))) - #'<) + :allow-other-keys t :bad t + :test #'(lambda (x y) (= x (1- y)))) + #'<) (1 6)) (deftest set-exclusive.allow-other-keys.4 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t) - #'<) + :allow-other-keys t) + #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.5 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys nil) - #'<) + :allow-other-keys nil) + #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.6 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t - :allow-other-keys nil) - #'<) + :allow-other-keys t + :allow-other-keys nil) + #'<) (1 2 5 6)) (deftest set-exclusive.allow-other-keys.7 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :allow-other-keys t - :allow-other-keys nil - '#:x 1) - #'<) + :allow-other-keys t + :allow-other-keys nil + '#:x 1) + #'<) (1 2 5 6)) (deftest set-exclusive.keywords.8 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :test #'eql - :test #'/=) - #'<) + :test #'eql + :test #'/=) + #'<) (1 2 5 6)) (deftest set-exclusive.keywords.9 (sort (set-exclusive-or (list 1 2 3 4) (list 3 4 5 6) - :test #'/= - :test #'eql) - #'<) + :test #'/= + :test #'eql) + #'<) nil) (def-fold-test set-exclusive-or.fold.1 (set-exclusive-or '(a b c d e f) '(b x e y z c))) diff --git a/ansi-tests/set-macro-character.lsp b/ansi-tests/set-macro-character.lsp index 0d7c33d3..c62cc37f 100644 --- a/ansi-tests/set-macro-character.lsp +++ b/ansi-tests/set-macro-character.lsp @@ -7,40 +7,40 @@ (def-syntax-test set-macro-character.1 (let ((*readtable* (copy-readtable)) - (*package* (find-package :cl-test))) + (*package* (find-package :cl-test))) (let ((v1 (read-from-string "?!"))) (assert (eql v1 '?!)) (flet ((%f (stream char) - (declare (ignore stream)) - (assert (eql char #\?)) - 17)) - (let ((fn #'%f)) - (assert (equal (multiple-value-list - (set-macro-character #\? fn nil)) - '(t))) - (values - (multiple-value-list (read-from-string "?!")) - (multiple-value-list (read-from-string "!?"))))))) + (declare (ignore stream)) + (assert (eql char #\?)) + 17)) + (let ((fn #'%f)) + (assert (equal (multiple-value-list + (set-macro-character #\? fn nil)) + '(t))) + (values + (multiple-value-list (read-from-string "?!")) + (multiple-value-list (read-from-string "!?"))))))) (17 1) (! 1)) (def-syntax-test set-macro-character.2 (let ((rt (copy-readtable)) - (*package* (find-package :cl-test))) + (*package* (find-package :cl-test))) (let ((v1 (read-from-string "?!"))) (assert (eql v1 '?!)) (flet ((%f (stream char) - (declare (ignore stream)) - (assert (eql char #\?)) - 17)) - (let ((fn #'%f)) - (assert (equal (multiple-value-list - (set-macro-character #\? fn t rt)) - '(t))) - (let ((*readtable* rt)) - (values - (multiple-value-list (read-from-string "?!")) - (multiple-value-list (read-from-string "!?")))))))) + (declare (ignore stream)) + (assert (eql char #\?)) + 17)) + (let ((fn #'%f)) + (assert (equal (multiple-value-list + (set-macro-character #\? fn t rt)) + '(t))) + (let ((*readtable* rt)) + (values + (multiple-value-list (read-from-string "?!")) + (multiple-value-list (read-from-string "!?")))))))) (17 1) (!? 2)) @@ -51,13 +51,13 @@ (def-syntax-test set-macro-character.3 (let ((*readtable* (copy-readtable)) - (*package* (find-package :cl-test))) + (*package* (find-package :cl-test))) (let ((v1 (read-from-string "?!")) - (fn 'set-macro-character.3-test-fn)) + (fn 'set-macro-character.3-test-fn)) (assert (eql v1 '?!)) (assert (equal (multiple-value-list - (set-macro-character #\? fn nil)) - '(t))) + (set-macro-character #\? fn nil)) + '(t))) (values (multiple-value-list (read-from-string "?!")) (multiple-value-list (read-from-string "!?"))))) diff --git a/ansi-tests/set-syntax-from-char.lsp b/ansi-tests/set-syntax-from-char.lsp index d6f1512c..90f3ecec 100644 --- a/ansi-tests/set-syntax-from-char.lsp +++ b/ansi-tests/set-syntax-from-char.lsp @@ -11,8 +11,8 @@ `(deftest ,name (with-standard-io-syntax (let ((*readtable* (copy-readtable nil))) - (setf (readtable-case *readtable*) :preserve) - ,form)) + (setf (readtable-case *readtable*) :preserve) + ,form)) ,@expected-values)) ;;; Test that constituent traits are not altered when a constituent character @@ -20,30 +20,30 @@ (defmacro def-set-syntax-from-char-trait-test (c test-form expected-value) (setq c (typecase c - (character c) - ((or string symbol) (name-char (string c))) - (t nil))) + (character c) + ((or string symbol) (name-char (string c))) + (t nil))) (when c ;; (format t "~A ~A~%" c (char-name c)) `(def-set-syntax-from-char-test ,(intern (concatenate 'string "SET-SYNTAX-FROM-CHAR-TRAIT-X-" (or (char-name c) - (string c))) - :cl-test) + (string c))) + :cl-test) (let ((c ,c)) - (values - (set-syntax-from-char c #\X) - ,test-form)) + (values + (set-syntax-from-char c #\X) + ,test-form)) t ,expected-value))) (defmacro def-set-syntax-from-char-alphabetic-trait-test (c) `(def-set-syntax-from-char-trait-test ,c (let* ((*package* (find-package "CL-TEST")) - (sym (read-from-string (string c)))) + (sym (read-from-string (string c)))) (list (let ((sym2 (find-symbol (string c)))) - (or (eqt sym sym2) - (list sym sym2))) - (or (equalt (symbol-name sym) (string c)) - (list (symbol-name sym) (string c))))) + (or (eqt sym sym2) + (list sym sym2))) + (or (equalt (symbol-name sym) (string c)) + (list (symbol-name sym) (string c))))) (t t))) (loop for c across "\\|!\"#$%&'()*,;<=>?@[]^_`~{}+-/abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ" @@ -56,8 +56,8 @@ `(def-set-syntax-from-char-trait-test ,c (handler-case (let* ((*package* (find-package "CL-TEST")) - (sym (read-from-string (concatenate 'string (string c) "Z")))) - sym) + (sym (read-from-string (concatenate 'string (string c) "Z")))) + sym) (reader-error (c) (declare (ignore c)) :good)) :good)) @@ -68,145 +68,145 @@ (deftest set-syntax-from-char.single-escape.1 (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) - (let ((results - (list - (set-syntax-from-char c #\\) - (read-from-string (concatenate 'string (list c #\Z)))))) - (unless (equal results '(t |Z|)) - (list (list c results))))))) + nconc + (with-standard-io-syntax + (let ((*readtable* (copy-readtable nil)) + (*package* (find-package "CL-TEST"))) + (let ((results + (list + (set-syntax-from-char c #\\) + (read-from-string (concatenate 'string (list c #\Z)))))) + (unless (equal results '(t |Z|)) + (list (list c results))))))) nil) (deftest set-syntax-from-char.single-escape.2 (loop for c across +standard-chars+ - unless (eql c #\") - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) - (let ((results - (list - (set-syntax-from-char c #\\) - (read-from-string (concatenate 'string - (list #\" c #\" #\")))))) - (unless (equal results '(t "\"")) - (list (list c results))))))) + unless (eql c #\") + nconc + (with-standard-io-syntax + (let ((*readtable* (copy-readtable nil)) + (*package* (find-package "CL-TEST"))) + (let ((results + (list + (set-syntax-from-char c #\\) + (read-from-string (concatenate 'string + (list #\" c #\" #\")))))) + (unless (equal results '(t "\"")) + (list (list c results))))))) nil) (deftest set-syntax-from-char.multiple-escape (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) - (let ((results - (list - (set-syntax-from-char c #\|) - (handler-case - (read-from-string (concatenate 'string (list c #\Z c))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c #\z #\|))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list #\| #\Z c))) - (error (c) c))))) - (unless (or (eql c #\Z) (eql c #\z) (equal results '(t |Z| |z| |Z|))) - (list (list c results))))))) + nconc + (with-standard-io-syntax + (let ((*readtable* (copy-readtable nil)) + (*package* (find-package "CL-TEST"))) + (let ((results + (list + (set-syntax-from-char c #\|) + (handler-case + (read-from-string (concatenate 'string (list c #\Z c))) + (error (c) c)) + (handler-case + (read-from-string (concatenate 'string (list c #\z #\|))) + (error (c) c)) + (handler-case + (read-from-string (concatenate 'string (list #\| #\Z c))) + (error (c) c))))) + (unless (or (eql c #\Z) (eql c #\z) (equal results '(t |Z| |z| |Z|))) + (list (list c results))))))) nil) (deftest set-syntax-from-char.semicolon (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (expected (if (eql c #\0) '1 '0)) - (c2 (if (eql c #\0) #\1 #\0))) - (let ((results - (list - (set-syntax-from-char c #\;) - (handler-case - (read-from-string (concatenate 'string (list c2 c #\2))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c2 c #\2 #\Newline #\3))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c #\2 #\Newline c2))) - (error (c) c))))) - (unless (equal results (list t expected expected expected)) - (list (list c results))))))) + nconc + (with-standard-io-syntax + (let ((*readtable* (copy-readtable nil)) + (*package* (find-package "CL-TEST")) + (expected (if (eql c #\0) '1 '0)) + (c2 (if (eql c #\0) #\1 #\0))) + (let ((results + (list + (set-syntax-from-char c #\;) + (handler-case + (read-from-string (concatenate 'string (list c2 c #\2))) + (error (c) c)) + (handler-case + (read-from-string (concatenate 'string (list c2 c #\2 #\Newline #\3))) + (error (c) c)) + (handler-case + (read-from-string (concatenate 'string (list c #\2 #\Newline c2))) + (error (c) c))))) + (unless (equal results (list t expected expected expected)) + (list (list c results))))))) nil) (deftest set-syntax-from-char.left-paren (loop for c across +standard-chars+ - unless (find c ")") - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (expected (if (eql c #\0) '(1) '(0))) - (c2 (if (eql c #\0) #\1 #\0))) - (let ((results - (list - (set-syntax-from-char c #\() - (handler-case - (read-from-string (concatenate 'string (list c) ")")) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c c2) ")2" (list #\Newline #\3))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c c2) ")")) - (error (c) c))))) - (unless (equal results (list t nil expected expected)) - (list (list c results))))))) + unless (find c ")") + nconc + (with-standard-io-syntax + (let ((*readtable* (copy-readtable nil)) + (*package* (find-package "CL-TEST")) + (expected (if (eql c #\0) '(1) '(0))) + (c2 (if (eql c #\0) #\1 #\0))) + (let ((results + (list + (set-syntax-from-char c #\() + (handler-case + (read-from-string (concatenate 'string (list c) ")")) + (error (c) c)) + (handler-case + (read-from-string (concatenate 'string (list c c2) ")2" (list #\Newline #\3))) + (error (c) c)) + (handler-case + (read-from-string (concatenate 'string (list c c2) ")")) + (error (c) c))))) + (unless (equal results (list t nil expected expected)) + (list (list c results))))))) nil) (deftest set-syntax-from-char.right-paren (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST"))) - (let ((results - (list - (set-syntax-from-char c #\)) - (handler-case - (read-from-string (string c) nil nil) - (reader-error (c) :good) - (error (c) c))))) - (unless (equal results '(t :good)) - (list (list c results))))))) + nconc + (with-standard-io-syntax + (let ((*readtable* (copy-readtable nil)) + (*package* (find-package "CL-TEST"))) + (let ((results + (list + (set-syntax-from-char c #\)) + (handler-case + (read-from-string (string c) nil nil) + (reader-error (c) :good) + (error (c) c))))) + (unless (equal results '(t :good)) + (list (list c results))))))) nil) (deftest set-syntax-from-char.single-quote (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (expected (if (eql c #\0) ''1 ''0)) - (c2 (if (eql c #\0) #\1 #\0))) - (let ((results - (list - (set-syntax-from-char c #\') - (handler-case - (read-from-string (concatenate 'string (list c c2))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c c2) " 2")) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c c2) ")")) - (error (c) c))))) - (unless (equal results (list t expected expected expected)) - (list (list c results))))))) + nconc + (with-standard-io-syntax + (let ((*readtable* (copy-readtable nil)) + (*package* (find-package "CL-TEST")) + (expected (if (eql c #\0) ''1 ''0)) + (c2 (if (eql c #\0) #\1 #\0))) + (let ((results + (list + (set-syntax-from-char c #\') + (handler-case + (read-from-string (concatenate 'string (list c c2))) + (error (c) c)) + (handler-case + (read-from-string (concatenate 'string (list c c2) " 2")) + (error (c) c)) + (handler-case + (read-from-string (concatenate 'string (list c c2) ")")) + (error (c) c))))) + (unless (equal results (list t expected expected expected)) + (list (list c results))))))) nil) ;;; I do not test that setting syntax from #\" allows the character to be @@ -215,259 +215,259 @@ (deftest set-syntax-from-char.double-quote (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (expected (if (eql c #\0) "1" "0")) - (c2 (if (eql c #\0) #\1 #\0))) - (let ((results - (list - (set-syntax-from-char c #\") - (handler-case - (read-from-string - (concatenate 'string (list c c2 c))) - (error (c) c)) - (handler-case - (read-from-string - (concatenate 'string (list c c2 c #\2))) - (error (c) c)) - (handler-case - (read-from-string (concatenate 'string (list c c2 c) ")")) - (error (c) c))))) - (unless (equal results (list t expected expected expected)) - (list (list c results))))))) + nconc + (with-standard-io-syntax + (let ((*readtable* (copy-readtable nil)) + (*package* (find-package "CL-TEST")) + (expected (if (eql c #\0) "1" "0")) + (c2 (if (eql c #\0) #\1 #\0))) + (let ((results + (list + (set-syntax-from-char c #\") + (handler-case + (read-from-string + (concatenate 'string (list c c2 c))) + (error (c) c)) + (handler-case + (read-from-string + (concatenate 'string (list c c2 c #\2))) + (error (c) c)) + (handler-case + (read-from-string (concatenate 'string (list c c2 c) ")")) + (error (c) c))))) + (unless (equal results (list t expected expected expected)) + (list (list c results))))))) nil) (deftest set-syntax-from-char.backquote (loop for c across +standard-chars+ - unless (find c ",x") - nconc - (with-standard-io-syntax - (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (c2 (if (eql c #\Space) #\Newline #\Space)) - (results - (list - (set-syntax-from-char c #\`) - (handler-case - (eval `(let ((x 0)) - ,(read-from-string - (concatenate 'string (list c #\, #\x))))) - (error (c) c)) - (handler-case - (eval `(let ((x 0)) - ,(read-from-string - (concatenate 'string (list c #\, #\x c2))))) - (error (c) c)) - (handler-case - (eval `(let ((x 0)) - ,(read-from-string - (concatenate 'string (list c c2 #\, #\x c2))))) - (error (c) c))))) - (unless (equal results '(t 0 0 0)) - (list (list c results)))))) + unless (find c ",x") + nconc + (with-standard-io-syntax + (let* ((*readtable* (copy-readtable nil)) + (*package* (find-package "CL-TEST")) + (c2 (if (eql c #\Space) #\Newline #\Space)) + (results + (list + (set-syntax-from-char c #\`) + (handler-case + (eval `(let ((x 0)) + ,(read-from-string + (concatenate 'string (list c #\, #\x))))) + (error (c) c)) + (handler-case + (eval `(let ((x 0)) + ,(read-from-string + (concatenate 'string (list c #\, #\x c2))))) + (error (c) c)) + (handler-case + (eval `(let ((x 0)) + ,(read-from-string + (concatenate 'string (list c c2 #\, #\x c2))))) + (error (c) c))))) + (unless (equal results '(t 0 0 0)) + (list (list c results)))))) nil) (deftest set-syntax-from-char.comma (loop for c across +standard-chars+ - unless (find c "`x") - nconc - (with-standard-io-syntax - (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (c2 (if (eql c #\Space) #\Newline #\Space)) - (results - (list - (set-syntax-from-char c #\,) - (handler-case - (read-from-string (string c)) - (reader-error (c) :good) - (error (c) c)) - (handler-case - (eval `(let ((x 0)) - ,(read-from-string - (concatenate 'string "`" (list c) "x")))) - (error (c) c))))) - (unless (equal results '(t :good 0)) - (list (list c results)))))) + unless (find c "`x") + nconc + (with-standard-io-syntax + (let* ((*readtable* (copy-readtable nil)) + (*package* (find-package "CL-TEST")) + (c2 (if (eql c #\Space) #\Newline #\Space)) + (results + (list + (set-syntax-from-char c #\,) + (handler-case + (read-from-string (string c)) + (reader-error (c) :good) + (error (c) c)) + (handler-case + (eval `(let ((x 0)) + ,(read-from-string + (concatenate 'string "`" (list c) "x")))) + (error (c) c))))) + (unless (equal results '(t :good 0)) + (list (list c results)))))) nil) - + ;;; Tests of set-syntax-from-char on #\# (deftest set-syntax-from-char.sharp.1 (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (results - (list - (set-syntax-from-char c #\#) - (if (not (eql c #\Space)) - (handler-case - (read-from-string - (concatenate 'string (list c #\Space))) - (reader-error () :good) - (error (c) c)) - :good) - (if (not (find c "'X")) - (handler-case - (read-from-string - (concatenate 'string (list c) "'X")) - (error (c) c)) - '#'|X|) - (if (not (find c "(X)")) - (handler-case - (read-from-string - (concatenate 'string (list c) "(X)")) - (error (c) c)) - #(|X|)) - (if (not (find c ")")) - (handler-case - (read-from-string - (concatenate 'string (list c) ")")) - (reader-error (c) :good) - (error (c) c)) - :good) - (if (not (find c "*")) - (handler-case - (read-from-string - (concatenate 'string (list c #\*))) - (error (c) c)) - #*) - (if (not (find c ":|")) - (handler-case - (let ((sym (read-from-string - (concatenate 'string (list c) ":||")))) - (and (symbolp sym) - (null (symbol-package sym)) - (symbol-name sym))) - (error (c) c)) - "") - (handler-case - (read-from-string - (concatenate 'string (list c #\<))) - (reader-error (c) :good) - (error (c) c)) - (handler-case - (read-from-string - (concatenate 'string (list c #\\ #\X))) - (error (c) c)) - (if (not (find c "1")) - (handler-case - (read-from-string - (concatenate 'string (list c) "|1111|#1")) - (error (c) c)) - 1) - (if (not (find c "1")) - (handler-case - (read-from-string - (concatenate 'string (list c) "|11#|111|#11|#1")) - (error (c) c)) - 1) - ))) - (unless (equalp results '(t :good #'|X| #(|X|) :good #* "" :good #\X 1 1)) - (list (list c results)))))) + nconc + (with-standard-io-syntax + (let* ((*readtable* (copy-readtable nil)) + (*package* (find-package "CL-TEST")) + (results + (list + (set-syntax-from-char c #\#) + (if (not (eql c #\Space)) + (handler-case + (read-from-string + (concatenate 'string (list c #\Space))) + (reader-error () :good) + (error (c) c)) + :good) + (if (not (find c "'X")) + (handler-case + (read-from-string + (concatenate 'string (list c) "'X")) + (error (c) c)) + '#'|X|) + (if (not (find c "(X)")) + (handler-case + (read-from-string + (concatenate 'string (list c) "(X)")) + (error (c) c)) + #(|X|)) + (if (not (find c ")")) + (handler-case + (read-from-string + (concatenate 'string (list c) ")")) + (reader-error (c) :good) + (error (c) c)) + :good) + (if (not (find c "*")) + (handler-case + (read-from-string + (concatenate 'string (list c #\*))) + (error (c) c)) + #*) + (if (not (find c ":|")) + (handler-case + (let ((sym (read-from-string + (concatenate 'string (list c) ":||")))) + (and (symbolp sym) + (null (symbol-package sym)) + (symbol-name sym))) + (error (c) c)) + "") + (handler-case + (read-from-string + (concatenate 'string (list c #\<))) + (reader-error (c) :good) + (error (c) c)) + (handler-case + (read-from-string + (concatenate 'string (list c #\\ #\X))) + (error (c) c)) + (if (not (find c "1")) + (handler-case + (read-from-string + (concatenate 'string (list c) "|1111|#1")) + (error (c) c)) + 1) + (if (not (find c "1")) + (handler-case + (read-from-string + (concatenate 'string (list c) "|11#|111|#11|#1")) + (error (c) c)) + 1) + ))) + (unless (equalp results '(t :good #'|X| #(|X|) :good #* "" :good #\X 1 1)) + (list (list c results)))))) nil) (deftest set-syntax-from-char.sharp.2 (loop for c across +standard-chars+ - nconc - (with-standard-io-syntax - (let* ((*readtable* (copy-readtable nil)) - (*package* (find-package "CL-TEST")) - (results - (list - (set-syntax-from-char c #\#) - (if (not (find c "+XC ")) - (handler-case - (let ((*features* (cons ':X *features*))) - (read-from-string - (concatenate 'string (list c) "+X C"))) - (error (c) c)) - 'c) - (if (not (find c "-(OR)")) - (handler-case - (read-from-string - (concatenate 'string (list c) "-(OR)R")) - (error (c) c)) - 'r) - (if (not (find c ".1")) - (handler-case - (read-from-string - (concatenate 'string (list c) ".1")) - (error (c) c)) - 1) - (if (not (find c "01aA")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "0a1")) - (read-from-string - (concatenate 'string (list c) "0A1"))) - (error (c) c)) - '(#0a1 #0a1)) - (if (not (find c "01bB")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "b101")) - (read-from-string - (concatenate 'string (list c) "B011"))) - (error (c) c)) - '(5 3)) - (if (not (find c "cC()12 ")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "c(1 2)")) - (read-from-string - (concatenate 'string (list c) "C(2 1)"))) - (error (c) c)) - '(#c(1 2) #c(2 1))) - (if (not (find c "oO0127")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "o172")) - (read-from-string - (concatenate 'string (list c) "O7721"))) - (error (c) c)) - '(#o172 #o7721)) - (if (not (find c "pP\"")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "p\"\"")) - (read-from-string - (concatenate 'string (list c) "P\"\""))) - (error (c) c)) - '(#p"" #p"")) - (if (not (find c "rR0123")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "3r210")) - (read-from-string - (concatenate 'string (list c) "3R1111"))) - (error (c) c)) - '(#3r210 #3r1111)) - ;;; Add #s test here - (if (not (find c "xX04dF")) - (handler-case - (list - (read-from-string - (concatenate 'string (list c) "x40Fd")) - (read-from-string - (concatenate 'string (list c) "XFd04"))) - (error (c) c)) - '(#x40fd #xfd04)) - ))) - (unless (equalp results - '(t c r 1 (#0a1 #0a1) (5 3) (#c(1 2) #c(2 1)) - (#o172 #o7721) (#p"" #p"") (#3r210 #3r1111) - (#x40fd #xfd04))) - (list (list c results))) - ))) + nconc + (with-standard-io-syntax + (let* ((*readtable* (copy-readtable nil)) + (*package* (find-package "CL-TEST")) + (results + (list + (set-syntax-from-char c #\#) + (if (not (find c "+XC ")) + (handler-case + (let ((*features* (cons ':X *features*))) + (read-from-string + (concatenate 'string (list c) "+X C"))) + (error (c) c)) + 'c) + (if (not (find c "-(OR)")) + (handler-case + (read-from-string + (concatenate 'string (list c) "-(OR)R")) + (error (c) c)) + 'r) + (if (not (find c ".1")) + (handler-case + (read-from-string + (concatenate 'string (list c) ".1")) + (error (c) c)) + 1) + (if (not (find c "01aA")) + (handler-case + (list + (read-from-string + (concatenate 'string (list c) "0a1")) + (read-from-string + (concatenate 'string (list c) "0A1"))) + (error (c) c)) + '(#0a1 #0a1)) + (if (not (find c "01bB")) + (handler-case + (list + (read-from-string + (concatenate 'string (list c) "b101")) + (read-from-string + (concatenate 'string (list c) "B011"))) + (error (c) c)) + '(5 3)) + (if (not (find c "cC()12 ")) + (handler-case + (list + (read-from-string + (concatenate 'string (list c) "c(1 2)")) + (read-from-string + (concatenate 'string (list c) "C(2 1)"))) + (error (c) c)) + '(#c(1 2) #c(2 1))) + (if (not (find c "oO0127")) + (handler-case + (list + (read-from-string + (concatenate 'string (list c) "o172")) + (read-from-string + (concatenate 'string (list c) "O7721"))) + (error (c) c)) + '(#o172 #o7721)) + (if (not (find c "pP\"")) + (handler-case + (list + (read-from-string + (concatenate 'string (list c) "p\"\"")) + (read-from-string + (concatenate 'string (list c) "P\"\""))) + (error (c) c)) + '(#p"" #p"")) + (if (not (find c "rR0123")) + (handler-case + (list + (read-from-string + (concatenate 'string (list c) "3r210")) + (read-from-string + (concatenate 'string (list c) "3R1111"))) + (error (c) c)) + '(#3r210 #3r1111)) + ;;; Add #s test here + (if (not (find c "xX04dF")) + (handler-case + (list + (read-from-string + (concatenate 'string (list c) "x40Fd")) + (read-from-string + (concatenate 'string (list c) "XFd04"))) + (error (c) c)) + '(#x40fd #xfd04)) + ))) + (unless (equalp results + '(t c r 1 (#0a1 #0a1) (5 3) (#c(1 2) #c(2 1)) + (#o172 #o7721) (#p"" #p"") (#3r210 #3r1111) + (#x40fd #xfd04))) + (list (list c results))) + ))) nil) diff --git a/ansi-tests/set.lsp b/ansi-tests/set.lsp index 474490a2..991dbe02 100644 --- a/ansi-tests/set.lsp +++ b/ansi-tests/set.lsp @@ -7,7 +7,7 @@ (deftest set.1 (let ((*var-used-in-set-tests* 'a) - (var '*var-used-in-set-tests*)) + (var '*var-used-in-set-tests*)) (declare (special *var-used-in-set-tests*)) (values *var-used-in-set-tests* @@ -17,7 +17,7 @@ (deftest set.2 (let ((*var-used-in-set-tests* 'a) - (var '*var-used-in-set-tests*)) + (var '*var-used-in-set-tests*)) (declare (special *var-used-in-set-tests*)) (values (let ((*var-used-in-set-tests* 'c)) diff --git a/ansi-tests/shadow.lsp b/ansi-tests/shadow.lsp index 7b3f7ef8..5269b5c3 100644 --- a/ansi-tests/shadow.lsp +++ b/ansi-tests/shadow.lsp @@ -12,37 +12,37 @@ (deftest shadow.1 (prog1 (progn - (safely-delete-package "TEST5") - (safely-delete-package "TEST4") - (handler-case - (let* ((p1 (prog1 - (make-package "TEST4" :use nil) - (export (intern "A" "TEST4") "TEST4"))) - (p2 (make-package "TEST5" :use '("TEST4"))) - (r1 (package-shadowing-symbols "TEST4")) - (r2 (package-shadowing-symbols "TEST5"))) - (multiple-value-bind* (s1 kind1) - (find-symbol "A" p1) - (multiple-value-bind* (s2 kind2) - (find-symbol "A" p2) - (let ((r3 (shadow "A" p2))) - (multiple-value-bind* (s3 kind3) - (find-symbol "A" p2) - (list - (package-name p1) - (package-name p2) - r1 r2 - (symbol-name s1) - (package-name (symbol-package s1)) - kind1 - (symbol-name s2) - (package-name (symbol-package s2)) - kind2 - r3 - (symbol-name s3) - (package-name (symbol-package s3)) - kind3)))))) - (error (c) c))) + (safely-delete-package "TEST5") + (safely-delete-package "TEST4") + (handler-case + (let* ((p1 (prog1 + (make-package "TEST4" :use nil) + (export (intern "A" "TEST4") "TEST4"))) + (p2 (make-package "TEST5" :use '("TEST4"))) + (r1 (package-shadowing-symbols "TEST4")) + (r2 (package-shadowing-symbols "TEST5"))) + (multiple-value-bind* (s1 kind1) + (find-symbol "A" p1) + (multiple-value-bind* (s2 kind2) + (find-symbol "A" p2) + (let ((r3 (shadow "A" p2))) + (multiple-value-bind* (s3 kind3) + (find-symbol "A" p2) + (list + (package-name p1) + (package-name p2) + r1 r2 + (symbol-name s1) + (package-name (symbol-package s1)) + kind1 + (symbol-name s2) + (package-name (symbol-package s2)) + kind2 + r3 + (symbol-name s3) + (package-name (symbol-package s3)) + kind3)))))) + (error (c) c))) (safely-delete-package "TEST5") (safely-delete-package "TEST4")) ("TEST4" "TEST5" nil nil "A" "TEST4" :external @@ -56,31 +56,31 @@ (safely-delete-package "G") (handler-case (let* ((p1 (prog1 - (make-package "G" :use nil) - (export (intern "A" "G") "G"))) - (p2 (make-package "H" :use '("G"))) - (r1 (package-shadowing-symbols "G")) - (r2 (package-shadowing-symbols "H"))) + (make-package "G" :use nil) + (export (intern "A" "G") "G"))) + (p2 (make-package "H" :use '("G"))) + (r1 (package-shadowing-symbols "G")) + (r2 (package-shadowing-symbols "H"))) (multiple-value-bind* (s1 kind1) - (find-symbol "A" p1) - (multiple-value-bind* (s2 kind2) - (find-symbol "A" p2) - (let ((r3 (shadow "A" "H"))) - (multiple-value-bind* (s3 kind3) - (find-symbol "A" p2) - (prog1 - (list (package-name p1) (package-name p2) - r1 r2 (symbol-name s1) (package-name (symbol-package s1)) - kind1 (symbol-name s2) (package-name (symbol-package s2)) - kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) - kind3) - (safely-delete-package p2) - (safely-delete-package p1) - )))))) + (find-symbol "A" p1) + (multiple-value-bind* (s2 kind2) + (find-symbol "A" p2) + (let ((r3 (shadow "A" "H"))) + (multiple-value-bind* (s3 kind3) + (find-symbol "A" p2) + (prog1 + (list (package-name p1) (package-name p2) + r1 r2 (symbol-name s1) (package-name (symbol-package s1)) + kind1 (symbol-name s2) (package-name (symbol-package s2)) + kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) + kind3) + (safely-delete-package p2) + (safely-delete-package p1) + )))))) (error (c) - (safely-delete-package "H") - (safely-delete-package "G") - c))) + (safely-delete-package "H") + (safely-delete-package "G") + c))) ("G" "H" nil nil "A" "G" :external "A" "G" :inherited t @@ -94,31 +94,31 @@ (safely-delete-package "G") (handler-case (let* ((p1 (prog1 - (make-package "G" :use nil) - (export (intern "A" "G") "G"))) - (p2 (make-package "H" :use '("G"))) - (r1 (package-shadowing-symbols "G")) - (r2 (package-shadowing-symbols "H"))) + (make-package "G" :use nil) + (export (intern "A" "G") "G"))) + (p2 (make-package "H" :use '("G"))) + (r1 (package-shadowing-symbols "G")) + (r2 (package-shadowing-symbols "H"))) (multiple-value-bind* (s1 kind1) - (find-symbol "A" p1) - (multiple-value-bind* (s2 kind2) - (find-symbol "A" p2) - (let ((r3 (shadow "A" #\H))) - (multiple-value-bind* (s3 kind3) - (find-symbol "A" p2) - (prog1 - (list (package-name p1) (package-name p2) - r1 r2 (symbol-name s1) (package-name (symbol-package s1)) - kind1 (symbol-name s2) (package-name (symbol-package s2)) - kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) - kind3) - (safely-delete-package p2) - (safely-delete-package p1) - )))))) + (find-symbol "A" p1) + (multiple-value-bind* (s2 kind2) + (find-symbol "A" p2) + (let ((r3 (shadow "A" #\H))) + (multiple-value-bind* (s3 kind3) + (find-symbol "A" p2) + (prog1 + (list (package-name p1) (package-name p2) + r1 r2 (symbol-name s1) (package-name (symbol-package s1)) + kind1 (symbol-name s2) (package-name (symbol-package s2)) + kind2 r3 (symbol-name s3) (package-name (symbol-package s3)) + kind3) + (safely-delete-package p2) + (safely-delete-package p1) + )))))) (error (c) - (safely-delete-package "H") - (safely-delete-package "G") - c))) + (safely-delete-package "H") + (safely-delete-package "G") + c))) ("G" "H" nil nil "A" "G" :external "A" "G" :inherited t @@ -130,16 +130,16 @@ (prog1 (handler-case (progn - (safely-delete-package :G) - (make-package :G :use nil) - (let ((s1 (intern "X" :G))) - (shadow "X" :G) - (multiple-value-bind* (s2 kind) - (find-symbol "X" :G) - (list (eqt s1 s2) - (symbol-name s2) - (package-name (symbol-package s2)) - kind)))) + (safely-delete-package :G) + (make-package :G :use nil) + (let ((s1 (intern "X" :G))) + (shadow "X" :G) + (multiple-value-bind* (s2 kind) + (find-symbol "X" :G) + (list (eqt s1 s2) + (symbol-name s2) + (package-name (symbol-package s2)) + kind)))) (error (c) c)) (safely-delete-package "G")) (t "X" "G" :internal)) @@ -150,18 +150,18 @@ (prog1 (handler-case (progn - (safely-delete-package :H) - (safely-delete-package :G) - (make-package :G :use nil) - (export (intern "X" :G) :G) - (make-package :H :use '("G")) - (shadow "X" :H) - (multiple-value-bind* (s1 kind1) - (find-symbol "X" :H) - (shadow "X" :H) - (multiple-value-bind* (s2 kind2) - (find-symbol "X" :H) - (list (eqt s1 s2) kind1 kind2)))) + (safely-delete-package :H) + (safely-delete-package :G) + (make-package :G :use nil) + (export (intern "X" :G) :G) + (make-package :H :use '("G")) + (shadow "X" :H) + (multiple-value-bind* (s1 kind1) + (find-symbol "X" :H) + (shadow "X" :H) + (multiple-value-bind* (s2 kind2) + (find-symbol "X" :H) + (list (eqt s1 s2) kind1 kind2)))) (error (c) c)) (safely-delete-package :H) (safely-delete-package :G)) @@ -173,25 +173,25 @@ (prog1 (handler-case (progn - (safely-delete-package :G) - (make-package :G :use nil) - (shadow '("X" "Y" |Z|) :G) - (let ((results - (append (multiple-value-list - (find-symbol "X" :G)) - (multiple-value-list - (find-symbol "Y" :G)) - (multiple-value-list - (find-symbol "Z" :G)) - nil))) - (list - (symbol-name (first results)) - (second results) - (symbol-name (third results)) - (fourth results) - (symbol-name (fifth results)) - (sixth results) - (length (package-shadowing-symbols :G))))) + (safely-delete-package :G) + (make-package :G :use nil) + (shadow '("X" "Y" |Z|) :G) + (let ((results + (append (multiple-value-list + (find-symbol "X" :G)) + (multiple-value-list + (find-symbol "Y" :G)) + (multiple-value-list + (find-symbol "Z" :G)) + nil))) + (list + (symbol-name (first results)) + (second results) + (symbol-name (third results)) + (fourth results) + (symbol-name (fifth results)) + (sixth results) + (length (package-shadowing-symbols :G))))) (error (c) c)) (safely-delete-package :G)) ("X" :internal "Y" :internal "Z" :internal 3)) @@ -201,23 +201,23 @@ (prog1 (handler-case (let ((i 0) x y) - (safely-delete-package :G) - (make-package :G :use nil) - (shadow (progn (setf x (incf i)) '(#\X #\Y)) - (progn (setf y (incf i)) :G)) - (let ((results - (append (multiple-value-list - (find-symbol "X" :G)) - (multiple-value-list - (find-symbol "Y" :G)) - nil))) - (list - i x y - (symbol-name (first results)) - (second results) - (symbol-name (third results)) - (fourth results) - (length (package-shadowing-symbols :G))))) + (safely-delete-package :G) + (make-package :G :use nil) + (shadow (progn (setf x (incf i)) '(#\X #\Y)) + (progn (setf y (incf i)) :G)) + (let ((results + (append (multiple-value-list + (find-symbol "X" :G)) + (multiple-value-list + (find-symbol "Y" :G)) + nil))) + (list + i x y + (symbol-name (first results)) + (second results) + (symbol-name (third results)) + (fourth results) + (length (package-shadowing-symbols :G))))) (error (c) c)) (safely-delete-package :G)) (2 1 2 "X" :internal "Y" :internal 2)) @@ -228,18 +228,18 @@ (prog1 (handler-case (progn - (safely-delete-package :G) - (make-package :G :use nil) - (let* ((name (make-array '(1) :initial-contents "X" - :element-type 'base-char)) - (s1 (intern name :G))) - (shadow name :G) - (multiple-value-bind* (s2 kind) - (find-symbol "X" :G) - (list (eqt s1 s2) - (symbol-name s2) - (package-name (symbol-package s2)) - kind)))) + (safely-delete-package :G) + (make-package :G :use nil) + (let* ((name (make-array '(1) :initial-contents "X" + :element-type 'base-char)) + (s1 (intern name :G))) + (shadow name :G) + (multiple-value-bind* (s2 kind) + (find-symbol "X" :G) + (list (eqt s1 s2) + (symbol-name s2) + (package-name (symbol-package s2)) + kind)))) (error (c) c)) (safely-delete-package "G")) (t "X" "G" :internal)) @@ -248,19 +248,19 @@ (prog1 (handler-case (progn - (safely-delete-package :G) - (make-package :G :use nil) - (let* ((name (make-array '(3) :initial-contents "XYZ" - :fill-pointer 1 - :element-type 'character)) - (s1 (intern name :G))) - (shadow name :G) - (multiple-value-bind* (s2 kind) - (find-symbol "X" :G) - (list (eqt s1 s2) - (symbol-name s2) - (package-name (symbol-package s2)) - kind)))) + (safely-delete-package :G) + (make-package :G :use nil) + (let* ((name (make-array '(3) :initial-contents "XYZ" + :fill-pointer 1 + :element-type 'character)) + (s1 (intern name :G))) + (shadow name :G) + (multiple-value-bind* (s2 kind) + (find-symbol "X" :G) + (list (eqt s1 s2) + (symbol-name s2) + (package-name (symbol-package s2)) + kind)))) (error (c) c)) (safely-delete-package "G")) (t "X" "G" :internal)) @@ -269,19 +269,19 @@ (prog1 (handler-case (progn - (safely-delete-package :G) - (make-package :G :use nil) - (let* ((name (make-array '(1) :initial-contents "X" - :adjustable t - :element-type 'base-char)) - (s1 (intern name :G))) - (shadow name :G) - (multiple-value-bind* (s2 kind) - (find-symbol "X" :G) - (list (eqt s1 s2) - (symbol-name s2) - (package-name (symbol-package s2)) - kind)))) + (safely-delete-package :G) + (make-package :G :use nil) + (let* ((name (make-array '(1) :initial-contents "X" + :adjustable t + :element-type 'base-char)) + (s1 (intern name :G))) + (shadow name :G) + (multiple-value-bind* (s2 kind) + (find-symbol "X" :G) + (list (eqt s1 s2) + (symbol-name s2) + (package-name (symbol-package s2)) + kind)))) (error (c) c)) (safely-delete-package "G")) (t "X" "G" :internal)) diff --git a/ansi-tests/shadowing-import.lsp b/ansi-tests/shadowing-import.lsp index 2580d120..c3963d50 100644 --- a/ansi-tests/shadowing-import.lsp +++ b/ansi-tests/shadowing-import.lsp @@ -7,83 +7,83 @@ (deftest shadowing-import.1 (let ((name1 "TEST1") - (name2 "TEST2")) + (name2 "TEST2")) (safely-delete-package name1) (safely-delete-package name2) (prog1 - (let* ((p1 (make-package name1 :use nil)) - (p2 (make-package name2)) - (s1 (intern "X" p1)) - (s2 (intern "X" p2))) - (list - (eqt s1 s2) - (eqt (find-symbol "X" p2) s2) - (shadowing-import s1 p2) - (equalt (package-shadowing-symbols p2) (list s1)) - (eqt (find-symbol "X" p2) s1))) + (let* ((p1 (make-package name1 :use nil)) + (p2 (make-package name2)) + (s1 (intern "X" p1)) + (s2 (intern "X" p2))) + (list + (eqt s1 s2) + (eqt (find-symbol "X" p2) s2) + (shadowing-import s1 p2) + (equalt (package-shadowing-symbols p2) (list s1)) + (eqt (find-symbol "X" p2) s1))) (safely-delete-package name1) (safely-delete-package name2))) (nil t t t t)) (deftest shadowing-import.2 (let ((name1 "TEST1") - (name2 "TEST2")) + (name2 "TEST2")) (safely-delete-package name1) (safely-delete-package name2) (prog1 - (let* ((p1 (make-package name1 :use nil)) - (p2 (make-package name2)) - (s1 (intern "X" p1))) - (list - (find-symbol "X" p2) - (shadowing-import s1 p2) - (equalt (package-shadowing-symbols p2) (list s1)) - (eqt (find-symbol "X" p2) s1))) + (let* ((p1 (make-package name1 :use nil)) + (p2 (make-package name2)) + (s1 (intern "X" p1))) + (list + (find-symbol "X" p2) + (shadowing-import s1 p2) + (equalt (package-shadowing-symbols p2) (list s1)) + (eqt (find-symbol "X" p2) s1))) (safely-delete-package name1) (safely-delete-package name2))) (nil t t t)) (deftest shadowing-import.3 (let ((name1 "TEST1") - (name2 "TEST2")) + (name2 "TEST2")) (safely-delete-package name1) (safely-delete-package name2) (prog1 - (let* ((p1 (make-package name1 :use nil)) - (p2 (make-package name2 :use nil)) - (s1 (intern "X" p1)) - (s2 (intern "X" p2))) - (list - (eqt s1 s2) - (eqt (find-symbol "X" p2) s2) - (let ((*package* p2)) - (shadowing-import s1)) - (equalt (package-shadowing-symbols p2) (list s1)) - (eqt (find-symbol "X" p2) s1))) + (let* ((p1 (make-package name1 :use nil)) + (p2 (make-package name2 :use nil)) + (s1 (intern "X" p1)) + (s2 (intern "X" p2))) + (list + (eqt s1 s2) + (eqt (find-symbol "X" p2) s2) + (let ((*package* p2)) + (shadowing-import s1)) + (equalt (package-shadowing-symbols p2) (list s1)) + (eqt (find-symbol "X" p2) s1))) (safely-delete-package name1) (safely-delete-package name2))) (nil t t t t)) (deftest shadowing-import.4 (let ((name1 "TEST1") - (name2 "TEST2") - (name3 "TEST3")) + (name2 "TEST2") + (name3 "TEST3")) (safely-delete-package name1) (safely-delete-package name2) (safely-delete-package name3) (prog1 - (let* ((p1 (make-package name1 :use nil)) - (p3 (make-package name2 :use nil)) - (p2 (make-package name3 :use (list p3))) - (s1 (intern "X" p1)) - (s2 (intern "X" p3))) - (export s2 p3) - (list - (eqt s1 s2) - (eqt (find-symbol "X" p2) s2) - (shadowing-import s1 p2) - (equalt (package-shadowing-symbols p2) (list s1)) - (eqt (find-symbol "X" p2) s1))) + (let* ((p1 (make-package name1 :use nil)) + (p3 (make-package name2 :use nil)) + (p2 (make-package name3 :use (list p3))) + (s1 (intern "X" p1)) + (s2 (intern "X" p3))) + (export s2 p3) + (list + (eqt s1 s2) + (eqt (find-symbol "X" p2) s2) + (shadowing-import s1 p2) + (equalt (package-shadowing-symbols p2) (list s1)) + (eqt (find-symbol "X" p2) s1))) (safely-delete-package name1) (safely-delete-package name3) (safely-delete-package name2))) @@ -96,54 +96,54 @@ (let ((name1 ,name-form)) (safely-delete-package name1) (prog1 - (let* ((p1 (make-package name1 :use nil))) - (list - (find-symbol "T" p1) - (shadowing-import t name1) - (package-shadowing-symbols p1) - (find-symbol "T" p1))) - (safely-delete-package name1))) + (let* ((p1 (make-package name1 :use nil))) + (list + (find-symbol "T" p1) + (shadowing-import t name1) + (package-shadowing-symbols p1) + (find-symbol "T" p1))) + (safely-delete-package name1))) (nil t (t) t))) - + (def-shadowing-import-test shadowing-import.5 (make-array '(5) :initial-contents "TEST1" - :element-type 'base-char)) + :element-type 'base-char)) (def-shadowing-import-test shadowing-import.6 (make-array '(7) :initial-contents "TEST1XX" - :fill-pointer 7 - :element-type 'character)) + :fill-pointer 7 + :element-type 'character)) (def-shadowing-import-test shadowing-import.7 (make-array '(7) :initial-contents "TEST1XX" - :fill-pointer 7 - :element-type 'base-char)) + :fill-pointer 7 + :element-type 'base-char)) (def-shadowing-import-test shadowing-import.8 (make-array '(5) :initial-contents "TEST1" - :adjustable t - :element-type 'base-char)) + :adjustable t + :element-type 'base-char)) (def-shadowing-import-test shadowing-import.9 (make-array '(5) :initial-contents "TEST1" - :adjustable t - :element-type 'character)) + :adjustable t + :element-type 'character)) (def-shadowing-import-test shadowing-import.10 (let* ((etype 'character) - (name2 (make-array '(10) :initial-contents "ABTEST1CDE" - :element-type etype))) + (name2 (make-array '(10) :initial-contents "ABTEST1CDE" + :element-type etype))) (make-array '(5) :element-type etype - :displaced-to name2 - :displaced-index-offset 2))) + :displaced-to name2 + :displaced-index-offset 2))) (def-shadowing-import-test shadowing-import.11 (let* ((etype 'base-char) - (name2 (make-array '(10) :initial-contents "ABTEST1CDE" - :element-type etype))) + (name2 (make-array '(10) :initial-contents "ABTEST1CDE" + :element-type etype))) (make-array '(5) :element-type etype - :displaced-to name2 - :displaced-index-offset 2))) + :displaced-to name2 + :displaced-index-offset 2))) ;;; Error tests @@ -153,5 +153,5 @@ (deftest shadowing-import.error.2 (signals-error (shadowing-import nil *package* nil) - program-error) + program-error) t) diff --git a/ansi-tests/shared-initialize.lsp b/ansi-tests/shared-initialize.lsp index f01ef47c..34ffa8fc 100644 --- a/ansi-tests/shared-initialize.lsp +++ b/ansi-tests/shared-initialize.lsp @@ -139,15 +139,15 @@ ;;; Initforms in the lexical environment of the defclass (declaim (special *shared-init-var-02-init* - *shared-init-var-02-query*)) + *shared-init-var-02-query*)) (declaim (type function *shared-init-var-02-init* *shared-init-var-02-query*)) (let ((ainit 0) (binit 0)) (flet ((%init (a b) (setf ainit a binit b)) - (%query () (list ainit binit))) + (%query () (list ainit binit))) (setf *shared-init-var-02-init* #'%init - *shared-init-var-02-query* #'%query) + *shared-init-var-02-query* #'%query) (defclass shared-init-class-02 () ((a :initform (incf ainit) :initarg :a) (b :initform (incf binit) :initarg :b) @@ -256,12 +256,12 @@ a b c) (defmethod shared-initialize ((obj shared-init-class-03) - slots-to-init - &key - (a nil a-p) - (b nil b-p) - (c nil c-p) - &allow-other-keys) + slots-to-init + &key + (a nil a-p) + (b nil b-p) + (c nil c-p) + &allow-other-keys) (declare (ignore slots-to-init)) ;; (when a-p (setf (slot-value obj 'a) a)) ;; (when b-p (setf (slot-value obj 'b) b)) @@ -367,7 +367,7 @@ (deftest shared-initialize.5.1 (let* ((class (find-class 'shared-init-class-05)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (slot-makunbound obj 'a) (slot-makunbound obj 'b) (values @@ -380,7 +380,7 @@ (deftest shared-initialize.5.2 (let* ((class (find-class 'shared-init-class-05)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (slot-makunbound obj 'a) (slot-makunbound obj 'b) (values @@ -393,8 +393,8 @@ (deftest shared-initialize.5.3 (let* ((class (find-class 'shared-init-class-05)) - (obj (allocate-instance class)) - (obj2 (allocate-instance class))) + (obj (allocate-instance class)) + (obj2 (allocate-instance class))) (slot-makunbound obj 'a) (slot-makunbound obj 'b) (values @@ -409,8 +409,8 @@ (deftest shared-initialize.5.4 (let* ((class (find-class 'shared-init-class-05)) - (obj (allocate-instance class)) - (obj2 (allocate-instance class))) + (obj (allocate-instance class)) + (obj2 (allocate-instance class))) (slot-makunbound obj 'a) (values (setf (slot-value obj 'b) 'bar) @@ -432,7 +432,7 @@ (deftest shared-initialize.6.1 (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil)) @@ -443,7 +443,7 @@ (deftest shared-initialize.6.2 (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj t)) @@ -457,7 +457,7 @@ (deftest shared-initialize.6.3 (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i1 'z)) @@ -470,7 +470,7 @@ (deftest shared-initialize.6.4 (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i2 'z)) @@ -484,7 +484,7 @@ (deftest shared-initialize.6.5 (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i1 'w :i2 'z)) @@ -498,7 +498,7 @@ (deftest shared-initialize.6.6 (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i2 'z :i1 'w)) @@ -512,7 +512,7 @@ (deftest shared-initialize.6.7 (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i2 'z :i2 'w)) @@ -527,7 +527,7 @@ (deftest shared-initialize.6.8 (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :i2 'z :i2 'w :foo t)) @@ -542,11 +542,11 @@ (deftest shared-initialize.6.9 (let* ((class (find-class 'shared-init-class-06)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil :allow-other-keys nil - :i2 'z :i2 'w :foo t)) + :i2 'z :i2 'w :foo t)) (map-slot-boundp* obj '(a b)) (slot-value obj 'a) (slot-value obj 'b))) @@ -568,7 +568,7 @@ (deftest shared-initialize.7.1 (let* ((class (find-class 'shared-init-class-07)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil)) @@ -578,7 +578,7 @@ (deftest shared-initialize.7.2 (let* ((class (find-class 'shared-init-class-07)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj t)) @@ -594,14 +594,14 @@ (b :initform 'y))) (defmethod shared-initialize :around ((obj shared-init-class-08) slot-names - &rest args &key only &allow-other-keys) + &rest args &key only &allow-other-keys) (declare (ignore slot-names args)) (setf (slot-value obj 'a) 'foo) (if only obj (call-next-method))) (deftest shared-initialize.8.1 (let* ((class (find-class 'shared-init-class-08)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj nil)) @@ -614,7 +614,7 @@ (deftest shared-initialize.8.2 (let* ((class (find-class 'shared-init-class-08)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj t)) @@ -628,7 +628,7 @@ (deftest shared-initialize.8.3 (let* ((class (find-class 'shared-init-class-08)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (values (map-slot-boundp* obj '(a b)) (eqt obj (shared-initialize obj t :only t)) @@ -647,7 +647,7 @@ (deftest shared-initialize.9.1 (let* ((class (find-class 'shared-init-class-09)) - (obj (allocate-instance class))) + (obj (allocate-instance class))) (slot-makunbound obj 'a) (values (map-slot-boundp* obj '(a b)) @@ -663,15 +663,15 @@ (deftest shared-initialize.order.1 (let ((obj (allocate-instance (find-class 'shared-init-class-01))) - (i 0) x r y z w q) + (i 0) x r y z w q) (values (eqt obj - (shared-initialize (progn (setf x (incf i)) obj) - (progn (setf r (incf i)) nil) - :b (setf y (incf i)) - :a (setf z (incf i)) - :b (setf w (incf i)) - :c (setf q (incf i)))) + (shared-initialize (progn (setf x (incf i)) obj) + (progn (setf r (incf i)) nil) + :b (setf y (incf i)) + :a (setf z (incf i)) + :b (setf w (incf i)) + :c (setf q (incf i)))) (map-slot-value obj '(a b c)) i x r y z w q)) t (4 3 6) @@ -685,21 +685,21 @@ (deftest shared-initialize.error.2 (signals-error (let ((obj (allocate-instance - (find-class 'shared-init-class-01)))) - (shared-initialize obj)) - program-error) + (find-class 'shared-init-class-01)))) + (shared-initialize obj)) + program-error) t) (deftest shared-initialize.error.3 (signals-error (let ((obj (allocate-instance - (find-class 'shared-init-class-01)))) - (shared-initialize obj nil :a)) - program-error) + (find-class 'shared-init-class-01)))) + (shared-initialize obj nil :a)) + program-error) t) (deftest shared-initialize.error.4 (signals-error (let ((obj (allocate-instance - (find-class 'shared-init-class-01)))) - (shared-initialize obj nil '(a b c) nil)) - program-error) + (find-class 'shared-init-class-01)))) + (shared-initialize obj nil '(a b c) nil)) + program-error) t) diff --git a/ansi-tests/shiftf.lsp b/ansi-tests/shiftf.lsp index 40fa848e..fec210f8 100644 --- a/ansi-tests/shiftf.lsp +++ b/ansi-tests/shiftf.lsp @@ -7,13 +7,13 @@ (deftest shiftf-order.1 (let ((x (vector 'a 'b 'c 'd 'e)) - (i 2)) + (i 2)) (values (shiftf (aref x (incf i)) (incf i)) x i)) d #(a b c 4 e) 4) - + (deftest shiftf-order.2 (let ((x (vector 'a 'b 'c 'd 'e 'f 'g 'h)) - (i 2)) + (i 2)) (values (shiftf (aref x (incf i)) (aref x (incf i)) (incf i)) x i)) d #(a b c e 5 f g h) 5) @@ -34,16 +34,16 @@ a b c a b c d) - + (deftest shiftf.3 (let ((x (vector 0 1 2 3))) (values (copy-seq x) (shiftf (aref x (aref x 0)) - (aref x (aref x 1)) - (aref x (aref x 2)) - (aref x (aref x 3)) - 'foo) + (aref x (aref x 1)) + (aref x (aref x 2)) + (aref x (aref x 3)) + 'foo) (copy-seq x))) #(0 1 2 3) 0 diff --git a/ansi-tests/signum.lsp b/ansi-tests/signum.lsp index c55bdcee..2c80c396 100644 --- a/ansi-tests/signum.lsp +++ b/ansi-tests/signum.lsp @@ -31,25 +31,25 @@ (deftest signum.4 (loop for i in *rationals* - for s = (signum i) - unless (cond - ((zerop i) (eql s 0)) - ((plusp i) (eql s 1)) - (t (eql s -1))) - collect (list i s)) + for s = (signum i) + unless (cond + ((zerop i) (eql s 0)) + ((plusp i) (eql s 1)) + (t (eql s -1))) + collect (list i s)) nil) (deftest signum.5 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - for one = (float 1 x) - for y = (float 13122 x) - for s1 = (signum x) - for s2 = (signum y) - for s3 = (signum (- y)) - unless (and (eql s1 x) - (eql s2 one) - (eql s3 (- one))) - collect (list x one y s1 s2 s3)) + for one = (float 1 x) + for y = (float 13122 x) + for s1 = (signum x) + for s2 = (signum y) + for s3 = (signum (- y)) + unless (and (eql s1 x) + (eql s2 one) + (eql s3 (- one))) + collect (list x one y s1 s2 s3)) nil) (deftest signum.6 @@ -59,12 +59,12 @@ for mz = (- z) nconc (loop for x in (list z mz) - nconc - (loop for y in (list z mz) - for c = (complex z mz) - for s = (signum c) - unless (eql c s) - collect (list c s)))) + nconc + (loop for y in (list z mz) + for c = (complex z mz) + for s = (signum c) + unless (eql c s) + collect (list c s)))) nil) (deftest signum.7 @@ -89,23 +89,23 @@ (deftest signum.8 (let* ((c (complex 0 1)) - (s (signum c))) + (s (signum c))) (or (eqlt c s) - (eqlt s #c(0.0 1.0)))) + (eqlt s #c(0.0 1.0)))) t) (deftest signum.9 (let* ((c (complex 0 -1)) - (s (signum c))) + (s (signum c))) (or (eqlt c s) - (eqlt s #c(0.0 -1.0)))) + (eqlt s #c(0.0 -1.0)))) t) (deftest signum.10 (let* ((c (complex 3/5 4/5)) - (s (signum c))) + (s (signum c))) (or (eqlt c s) - (eqlt s (complex (float 3/5) (float 4/5))))) + (eqlt s (complex (float 3/5) (float 4/5))))) t) (deftest signum.11 diff --git a/ansi-tests/simple-array-t.lsp b/ansi-tests/simple-array-t.lsp index 255f2808..874db743 100644 --- a/ansi-tests/simple-array-t.lsp +++ b/ansi-tests/simple-array-t.lsp @@ -167,7 +167,7 @@ (deftest simple-array-t.8.1 (typep #() '(simple-array t (1))) nil) - + (deftest simple-array-t.8.2 (notnot-mv (typep #() '(simple-array t (0)))) t) @@ -179,7 +179,7 @@ (deftest simple-array-t.8.4 (typep #(a b c) '(simple-array t (2))) nil) - + (deftest simple-array-t.8.5 (notnot-mv (typep #(a b c) '(simple-array t (3)))) t) @@ -207,7 +207,7 @@ (deftest simple-array-t.8.11 (typep "abc" '(simple-array t (2))) nil) - + (deftest simple-array-t.8.12 (typep "abc" '(simple-array t (3))) nil) diff --git a/ansi-tests/simple-array.lsp b/ansi-tests/simple-array.lsp index c6e10995..bbb9f5e3 100644 --- a/ansi-tests/simple-array.lsp +++ b/ansi-tests/simple-array.lsp @@ -221,7 +221,7 @@ (deftest simple-array.8.1 (typep #() '(simple-array * (1))) nil) - + (deftest simple-array.8.2 (notnot-mv (typep #() '(simple-array * (0)))) t) @@ -233,7 +233,7 @@ (deftest simple-array.8.4 (typep #(a b c) '(simple-array * (2))) nil) - + (deftest simple-array.8.5 (notnot-mv (typep #(a b c) '(simple-array * (3)))) t) @@ -261,7 +261,7 @@ (deftest simple-array.8.11 (typep "abc" '(simple-array * (2))) nil) - + (deftest simple-array.8.12 (notnot-mv (typep "abc" '(simple-array * (3)))) t) diff --git a/ansi-tests/simple-bit-vector-p.lsp b/ansi-tests/simple-bit-vector-p.lsp index 6c598dc9..37f9cea4 100644 --- a/ansi-tests/simple-bit-vector-p.lsp +++ b/ansi-tests/simple-bit-vector-p.lsp @@ -8,7 +8,7 @@ (deftest simple-bit-vector-p.2 (notnot-mv (simple-bit-vector-p #*)) t) - + (deftest simple-bit-vector-p.3 (notnot-mv (simple-bit-vector-p #*00101)) t) @@ -43,7 +43,7 @@ (deftest simple-bit-vector-p.11 (simple-bit-vector-p (make-array '(2 2) :element-type 'bit - :initial-element 0)) + :initial-element 0)) nil) (deftest simple-bit-vector-p.12 diff --git a/ansi-tests/simple-bit-vector.lsp b/ansi-tests/simple-bit-vector.lsp index a46fd218..ff56610c 100644 --- a/ansi-tests/simple-bit-vector.lsp +++ b/ansi-tests/simple-bit-vector.lsp @@ -8,7 +8,7 @@ (deftest simple-bit-vector.2 (notnot-mv (typep #* 'simple-bit-vector)) t) - + (deftest simple-bit-vector.3 (notnot-mv (typep #*00101 'simple-bit-vector)) t) @@ -43,8 +43,8 @@ (deftest simple-bit-vector.11 (typep (make-array '(2 2) :element-type 'bit - :initial-element 0) - 'simple-bit-vector) + :initial-element 0) + 'simple-bit-vector) nil) (deftest simple-bit-vector.12 diff --git a/ansi-tests/simple-string-p.lsp b/ansi-tests/simple-string-p.lsp index b7fbca47..46c47dac 100644 --- a/ansi-tests/simple-string-p.lsp +++ b/ansi-tests/simple-string-p.lsp @@ -19,30 +19,30 @@ ;;; (deftest simple-string-p.4 ;;; (simple-string-p (make-array 4 :element-type 'character -;;; :initial-contents '(#\a #\a #\a #\b) -;;; :fill-pointer t)) +;;; :initial-contents '(#\a #\a #\a #\b) +;;; :fill-pointer t)) ;;; nil) (deftest simple-string-p.5 (notnot-mv (simple-string-p (make-array - 4 :element-type 'base-char - :initial-contents '(#\a #\a #\a #\b)))) + 4 :element-type 'base-char + :initial-contents '(#\a #\a #\a #\b)))) t) (deftest simple-string-p.6 (notnot-mv (simple-string-p (make-array - 4 :element-type 'standard-char - :initial-contents '(#\a #\a #\a #\b)))) + 4 :element-type 'standard-char + :initial-contents '(#\a #\a #\a #\b)))) t) ;;; (deftest simple-string-p.7 ;;; (let* ((s (make-array 10 :element-type 'character -;;; :initial-element #\a)) -;;; (s2 (make-array 4 :element-type 'character -;;; :displaced-to s -;;; :displaced-index-offset 2))) +;;; :initial-element #\a)) +;;; (s2 (make-array 4 :element-type 'character +;;; :displaced-to s +;;; :displaced-index-offset 2))) ;;; (simple-string-p s2)) ;;; nil) diff --git a/ansi-tests/sin.lsp b/ansi-tests/sin.lsp index 0b4f2468..8272bff5 100644 --- a/ansi-tests/sin.lsp +++ b/ansi-tests/sin.lsp @@ -7,51 +7,51 @@ (deftest sin.1 (loop for i from -1000 to 1000 - for rlist = (multiple-value-list (sin i)) - for y = (car rlist) - always (and (null (cdr rlist)) - (<= -1 y 1) - (or (rationalp y) (typep y 'single-float)))) + for rlist = (multiple-value-list (sin i)) + for y = (car rlist) + always (and (null (cdr rlist)) + (<= -1 y 1) + (or (rationalp y) (typep y 'single-float)))) t) (deftest sin.2 (loop for x = (- (random 2000.0s0) 1000.0s0) - for rlist = (multiple-value-list (sin x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'short-float))) + for rlist = (multiple-value-list (sin x)) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (<= -1 y 1) + (typep y 'short-float))) t) (deftest sin.3 (loop for x = (- (random 2000.0f0) 1000.0f0) - for rlist = (multiple-value-list (sin x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'single-float))) + for rlist = (multiple-value-list (sin x)) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (<= -1 y 1) + (typep y 'single-float))) t) (deftest sin.4 (loop for x = (- (random 2000.0d0) 1000.0d0) - for rlist = (multiple-value-list (sin x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'double-float))) + for rlist = (multiple-value-list (sin x)) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (<= -1 y 1) + (typep y 'double-float))) t) (deftest sin.5 (loop for x = (- (random 2000.0l0) 1000.0l0) - for rlist = (multiple-value-list (sin x)) - for y = (car rlist) - repeat 1000 - always (and (null (cdr rlist)) - (<= -1 y 1) - (typep y 'long-float))) + for rlist = (multiple-value-list (sin x)) + for y = (car rlist) + repeat 1000 + always (and (null (cdr rlist)) + (<= -1 y 1) + (typep y 'long-float))) t) (deftest sin.6 @@ -77,8 +77,8 @@ (deftest sin.11 (loop for i from 1 to 100 - unless (approx= (sin i) (sin (coerce i 'single-float))) - collect i) + unless (approx= (sin i) (sin (coerce i 'single-float))) + collect i) nil) (deftest sin.12 @@ -115,42 +115,42 @@ (deftest sin.20 (loop for r = (- (random 2000) 1000) - for i = (- (random 20) 10) - for y = (sin (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20) 10) + for y = (sin (complex r i)) + repeat 1000 + always (numberp y)) t) (deftest sin.21 (loop for r = (- (random 2000.0s0) 1000.0s0) - for i = (- (random 20.0s0) 10.0s0) - for y = (sin (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20.0s0) 10.0s0) + for y = (sin (complex r i)) + repeat 1000 + always (numberp y)) t) (deftest sin.22 (loop for r = (- (random 2000.0f0) 1000.0f0) - for i = (- (random 20.0f0) 10.0f0) - for y = (sin (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20.0f0) 10.0f0) + for y = (sin (complex r i)) + repeat 1000 + always (numberp y)) t) (deftest sin.23 (loop for r = (- (random 2000.0d0) 1000.0d0) - for i = (- (random 20.0d0) 10.0d0) - for y = (sin (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20.0d0) 10.0d0) + for y = (sin (complex r i)) + repeat 1000 + always (numberp y)) t) (deftest sin.24 (loop for r = (- (random 2000.0l0) 1000.0l0) - for i = (- (random 20.0l0) 10.0l0) - for y = (sin (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20.0l0) 10.0l0) + for y = (sin (complex r i)) + repeat 1000 + always (numberp y)) t) ;;; FIXME diff --git a/ansi-tests/sinh.lsp b/ansi-tests/sinh.lsp index 0df39b0c..91970caf 100644 --- a/ansi-tests/sinh.lsp +++ b/ansi-tests/sinh.lsp @@ -8,62 +8,62 @@ (deftest sinh.1 (let ((result (sinh 0))) (or (eqlt result 0) - (eqlt result 0.0))) + (eqlt result 0.0))) t) (deftest sinh.2 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - unless (equal (multiple-value-list (sinh zero)) - (list zero)) - collect type) + for zero = (coerce 0 type) + unless (equal (multiple-value-list (sinh zero)) + (list zero)) + collect type) nil) (deftest sinh.3 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 `(complex ,type)) - unless (equal (multiple-value-list (sinh zero)) - (list zero)) - collect type) + for zero = (coerce 0 `(complex ,type)) + unless (equal (multiple-value-list (sinh zero)) + (list zero)) + collect type) nil) (deftest sinh.4 (loop for den = (1+ (random 10000)) - for num = (random (* 10 den)) - for x = (/ num den) - for rlist = (multiple-value-list (sinh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (numberp y)) - collect (list x rlist)) + for num = (random (* 10 den)) + for x = (/ num den) + for rlist = (multiple-value-list (sinh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (numberp y)) + collect (list x rlist)) nil) (deftest sinh.5 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (sinh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) + nconc + (loop + for x = (- (random (coerce 20 type)) 10) + for rlist = (multiple-value-list (sinh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y type)) + collect (list x rlist))) nil) (deftest sinh.6 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 20 type)) 10) - for x2 = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (sinh (complex x1 x2))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 x2 rlist))) + nconc + (loop + for x1 = (- (random (coerce 20 type)) 10) + for x2 = (- (random (coerce 20 type)) 10) + for rlist = (multiple-value-list (sinh (complex x1 x2))) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y `(complex ,type))) + collect (list x1 x2 rlist))) nil) ;;; FIXME @@ -87,6 +87,6 @@ - - - + + + diff --git a/ansi-tests/slot-boundp.lsp b/ansi-tests/slot-boundp.lsp index 72a85361..b6dfb9bf 100644 --- a/ansi-tests/slot-boundp.lsp +++ b/ansi-tests/slot-boundp.lsp @@ -41,10 +41,10 @@ (deftest slot-boundp.order.1 (let ((obj (make-instance 'slot-boundp-class-01)) - (i 0) x y) + (i 0) x y) (values (slot-boundp (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'a)) + (progn (setf y (incf i)) 'a)) i x y)) nil 2 1 2) @@ -56,14 +56,14 @@ (deftest slot-boundp.error.2 (signals-error (let ((obj (make-instance 'slot-boundp-class-01))) - (slot-boundp obj)) - program-error) + (slot-boundp obj)) + program-error) t) (deftest slot-boundp.error.3 (signals-error (let ((obj (make-instance 'slot-boundp-class-01))) - (slot-boundp obj 'a nil)) - program-error) + (slot-boundp obj 'a nil)) + program-error) t) (deftest slot-boundp.error.4 @@ -77,9 +77,9 @@ (deftest slot-boundp.error.5 (let ((built-in-class (find-class 'built-in-class))) (loop for e in *mini-universe* - for class = (class-of e) - when (and (eq (class-of class) built-in-class) - (handler-case (progn (slot-boundp e 'foo) t) - (error () nil))) - collect e)) + for class = (class-of e) + when (and (eq (class-of class) built-in-class) + (handler-case (progn (slot-boundp e 'foo) t) + (error () nil))) + collect e)) nil) diff --git a/ansi-tests/slot-exists-p.lsp b/ansi-tests/slot-exists-p.lsp index c81bf3cc..08a36d71 100644 --- a/ansi-tests/slot-exists-p.lsp +++ b/ansi-tests/slot-exists-p.lsp @@ -14,12 +14,12 @@ (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (notnot-mv (slot-exists-p obj 'a))) t) - + (deftest slot-exists-p.2 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (notnot-mv (slot-exists-p obj 'b))) t) - + (deftest slot-exists-p.3 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))) (notnot-mv (slot-exists-p obj 'c))) @@ -99,7 +99,7 @@ (defstruct (slot-exists-p-struct-02 (:include slot-exists-p-struct-01)) d e) - + (deftest slot-exists-p.13 (let ((obj (make-slot-exists-p-struct-02))) (map-slot-exists-p* obj '(a b c d e f z nil))) @@ -110,7 +110,7 @@ (map-slot-exists-p* obj '(a b c d e f z nil))) (t t t t t nil nil nil)) - + ;;; SLOT-EXISTS-P is supposed to work on condition objects, too ;;; (after all, they are objects, and they have slots) @@ -136,25 +136,25 @@ (let ((i 0) x y) (values (slot-exists-p (progn (setf x (incf i)) 'a) - (progn (setf y (incf i)) (gensym))) + (progn (setf y (incf i)) (gensym))) i x y)) nil 2 1 2) (deftest slot-exists-p.order.2 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))) - (i 0) x y) + (i 0) x y) (values (notnot (slot-exists-p (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'a))) + (progn (setf y (incf i)) 'a))) i x y)) t 2 1 2) (deftest slot-exists-p.order.3 (let ((obj (allocate-instance (find-class 'slot-exists-p-class-01))) - (i 0) x y) + (i 0) x y) (values (notnot (slot-exists-p (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'b))) + (progn (setf y (incf i)) 'b))) i x y)) t 2 1 2) @@ -170,12 +170,12 @@ (deftest slot-exists-p.error.3 (signals-error (slot-exists-p (make-instance 'slot-exists-p-class-01)) - program-error) + program-error) t) (deftest slot-exists-p.error.4 (signals-error (slot-exists-p (make-instance 'slot-exists-p-class-01) 'a nil) - program-error) + program-error) t) diff --git a/ansi-tests/slot-makunbound.lsp b/ansi-tests/slot-makunbound.lsp index 8dcf593e..9ba9b541 100644 --- a/ansi-tests/slot-makunbound.lsp +++ b/ansi-tests/slot-makunbound.lsp @@ -17,48 +17,48 @@ (deftest slot-makunbound.1 (loop for slot-name in '(a b c d e) - unless - (let ((obj (allocate-instance (find-class 'slot-makunbound-class-01)))) - (and - (equalt (multiple-value-list (slot-makunbound obj slot-name)) - (list obj)) - (not (slot-boundp obj slot-name)))) - collect slot-name) + unless + (let ((obj (allocate-instance (find-class 'slot-makunbound-class-01)))) + (and + (equalt (multiple-value-list (slot-makunbound obj slot-name)) + (list obj)) + (not (slot-boundp obj slot-name)))) + collect slot-name) nil) (deftest slot-makunbound.2 (loop for slot-name in '(a b c d e) - for slot-value in '(t t t 10 t '(a)) - unless - (let ((obj (allocate-instance (find-class 'slot-makunbound-class-01)))) - (setf (slot-value obj slot-name) slot-value) - (and - (equalt (multiple-value-list (slot-makunbound obj slot-name)) - (list obj)) - (not (slot-boundp obj slot-name)))) - collect slot-name) + for slot-value in '(t t t 10 t '(a)) + unless + (let ((obj (allocate-instance (find-class 'slot-makunbound-class-01)))) + (setf (slot-value obj slot-name) slot-value) + (and + (equalt (multiple-value-list (slot-makunbound obj slot-name)) + (list obj)) + (not (slot-boundp obj slot-name)))) + collect slot-name) nil) ;;; Order of evaluation test(s) (deftest slot-makunbound.order.1 (let ((obj (make-instance 'slot-makunbound-class-01)) - (i 0) x y) + (i 0) x y) (values (eqt (slot-makunbound (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'a)) - obj) + (progn (setf y (incf i)) 'a)) + obj) i x y)) t 2 1 2) (deftest slot-makunbound.order.2 (let ((obj (make-instance 'slot-makunbound-class-01)) - (i 0) x y) + (i 0) x y) (setf (slot-value obj 'a) t) (values (eqt (slot-makunbound (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'a)) - obj) + (progn (setf y (incf i)) 'a)) + obj) i x y)) t 2 1 2) @@ -70,22 +70,22 @@ (deftest slot-makunbound.error.2 (signals-error (slot-makunbound (make-instance 'slot-makunbound-class-01)) - program-error) + program-error) t) (deftest slot-makunbound.error.3 (signals-error (slot-makunbound (make-instance 'slot-makunbound-class-01) - 'a nil) - program-error) + 'a nil) + program-error) t) (deftest slot-makunbound.error.4 (let ((built-in-class (find-class 'built-in-class))) (loop for e in *mini-universe* - for class = (class-of e) - when (and (eq (class-of class) built-in-class) - (handler-case (progn (slot-makunbound e 'foo) t) - (error () nil))) - collect e)) + for class = (class-of e) + when (and (eq (class-of class) built-in-class) + (handler-case (progn (slot-makunbound e 'foo) t) + (error () nil))) + collect e)) nil) diff --git a/ansi-tests/slot-missing.lsp b/ansi-tests/slot-missing.lsp index d2e00031..65e7f466 100644 --- a/ansi-tests/slot-missing.lsp +++ b/ansi-tests/slot-missing.lsp @@ -10,10 +10,10 @@ (defclass slot-missing-class-01 () (a b c)) (defmethod slot-missing ((class t) (obj slot-missing-class-01) - (slot-name t) (operation t) - &optional (new-value nil new-value-p)) + (slot-name t) (operation t) + &optional (new-value nil new-value-p)) (setf *slot-missing-class-01-var* - (list slot-name operation new-value (notnot new-value-p)))) + (list slot-name operation new-value (notnot new-value-p)))) (deftest slot-missing.1 (let ((obj (make-instance 'slot-missing-class-01))) @@ -59,16 +59,16 @@ (deftest slot-missing.7 (let* ((obj (make-instance 'slot-missing-class-01)) - (val (slot-makunbound obj 'd))) + (val (slot-makunbound obj 'd))) (if (eq val obj) - :good + :good val)) :good) (defmethod slot-missing ((class t) (obj slot-missing-class-01) - (slot-name (eql 'not-there)) - (operation (eql 'slot-boundp)) - &optional new-value) + (slot-name (eql 'not-there)) + (operation (eql 'slot-boundp)) + &optional new-value) (declare (ignore new-value)) (values nil :ignore-this)) diff --git a/ansi-tests/slot-unbound.lsp b/ansi-tests/slot-unbound.lsp index 702eaf35..657c57a9 100644 --- a/ansi-tests/slot-unbound.lsp +++ b/ansi-tests/slot-unbound.lsp @@ -34,11 +34,11 @@ (slot-unbound-class-01 b)) (defmethod slot-unbound ((class t) (obj slot-unbound-class-01) - (slot-name (eql 'e))) + (slot-name (eql 'e))) (values)) (defmethod slot-unbound ((class t) (obj slot-unbound-class-01) - (slot-name (eql 'f))) + (slot-name (eql 'f))) (values 1 2 3)) (deftest slot-unbound.3 diff --git a/ansi-tests/slot-value.lsp b/ansi-tests/slot-value.lsp index 0a66f5a3..001a2594 100644 --- a/ansi-tests/slot-value.lsp +++ b/ansi-tests/slot-value.lsp @@ -34,17 +34,17 @@ (deftest slot-value.1 (let ((obj (make-instance 'slot-value-class-01)) - (slot-names *slot-value-test-slot-names*) - (slot-values *slot-value-test-slot-values*)) + (slot-names *slot-value-test-slot-names*) + (slot-values *slot-value-test-slot-values*)) (loop for name in slot-names - for val in slot-values - unless (and (equal (multiple-value-list - (setf (slot-value obj name) val)) - (list val)) - (equal (multiple-value-list - (slot-value obj name)) - (list val))) - collect name)) + for val in slot-values + unless (and (equal (multiple-value-list + (setf (slot-value obj name) val)) + (list val)) + (equal (multiple-value-list + (slot-value obj name)) + (list val))) + collect name)) nil) (defclass slot-value-class-02 (slot-value-class-01) @@ -66,38 +66,38 @@ (deftest slot-value.2 (let ((obj (make-instance 'slot-value-class-02)) - (slot-names *slot-value-test-slot-names*) - (slot-values *slot-value-test-slot-values*)) + (slot-names *slot-value-test-slot-names*) + (slot-values *slot-value-test-slot-values*)) (loop for name in slot-names - for val in slot-values - unless (and (equal (multiple-value-list - (setf (slot-value obj name) val)) - (list val)) - (equal (multiple-value-list - (slot-value obj name)) - (list val))) - collect name)) + for val in slot-values + unless (and (equal (multiple-value-list + (setf (slot-value obj name) val)) + (list val)) + (equal (multiple-value-list + (slot-value obj name)) + (list val))) + collect name)) nil) ;;; Order of evaluation test(s) (deftest slot-value.order.1 (let ((obj (make-instance 'slot-value-class-01)) - (i 0) x y) + (i 0) x y) (values (setf (slot-value obj 'a) t) (slot-value (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'a)) + (progn (setf y (incf i)) 'a)) i x y)) t t 2 1 2) (deftest slot-value.order.2 (let ((obj (make-instance 'slot-value-class-01)) - (i 0) x y) + (i 0) x y) (values (setf (slot-value (progn (setf x (incf i)) obj) - (progn (setf y (incf i)) 'b)) - t) + (progn (setf y (incf i)) 'b)) + t) (slot-value obj 'b) i x y)) t t 2 1 2) @@ -110,7 +110,7 @@ (deftest slot-value.error.2 (signals-error (slot-value (make-instance 'slot-value-class-01)) - program-error) + program-error) t) (deftest slot-value.error.3 @@ -124,28 +124,28 @@ (deftest slot-value.error.4 (handler-case (progn (slot-value (make-instance 'slot-value-class-01) (gensym)) - :bad) + :bad) (error () :good)) :good) (deftest slot-value.error.5 (let ((built-in-class (find-class 'built-in-class)) - (slot-name (gensym))) + (slot-name (gensym))) (check-predicate #'(lambda (e) - (let ((class (class-of e))) - (or (not (eq (class-of class) built-in-class)) - (handler-case (progn (slot-value e slot-name) nil) - (error () t))))))) + (let ((class (class-of e))) + (or (not (eq (class-of class) built-in-class)) + (handler-case (progn (slot-value e slot-name) nil) + (error () t))))))) nil) (deftest slot-value.error.6 (let ((built-in-class (find-class 'built-in-class)) - (slot-name (gensym))) + (slot-name (gensym))) (check-predicate #'(lambda (e) - (let ((class (class-of e))) - (or (not (eq (class-of class) built-in-class)) - (handler-case (setf (slot-value e slot-name) nil) - (error () t))))))) + (let ((class (class-of e))) + (or (not (eq (class-of class) built-in-class)) + (handler-case (setf (slot-value e slot-name) nil) + (error () t))))))) nil) diff --git a/ansi-tests/some.lsp b/ansi-tests/some.lsp index 0e21c8d4..e9a6715c 100644 --- a/ansi-tests/some.lsp +++ b/ansi-tests/some.lsp @@ -17,7 +17,7 @@ (let ((count 0)) (values (some #'(lambda (x) (incf count) (if (>= x 10) x nil)) - '(1 2 4 13 5 1)) + '(1 2 4 13 5 1)) count)) 13 4) @@ -35,15 +35,15 @@ (deftest some.7 (some #'(lambda (x y) (and x y)) - '(nil t t nil t) #(t nil nil t nil nil)) + '(nil t t nil t) #(t nil nil t nil nil)) nil) (deftest some.8 (let ((x '(1)) - (args nil)) + (args nil)) (loop for i from 1 below (1- (min 100 call-arguments-limit)) - do (push x args) - always (apply #'some #'/= args))) + do (push x args) + always (apply #'some #'/= args))) nil) (deftest some.9 @@ -82,62 +82,62 @@ (deftest some.17 (let ((v (make-array '(10) :initial-contents '(0 0 0 0 1 2 3 4 5 6) - :fill-pointer 4))) + :fill-pointer 4))) (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (some #'plusp v)))) + do (setf (fill-pointer v) j) + collect (notnot (some #'plusp v)))) (nil nil nil nil nil t t t t t)) (deftest some.18 (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents (loop for j in '(0 0 0 0 1 2 3 4 5 6) - collect (mod j (ash 1 i))) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (some #'plusp v))) - '(nil nil nil nil nil t t t t t))) - collect i) + for type = `(unsigned-byte ,i) + unless + (let ((v (make-array '(10) :initial-contents (loop for j in '(0 0 0 0 1 2 3 4 5 6) + collect (mod j (ash 1 i))) + :element-type type + :fill-pointer 4))) + (equal (loop for j from 0 to 9 + do (setf (fill-pointer v) j) + collect (notnot (some #'plusp v))) + '(nil nil nil nil nil t t t t t))) + collect i) nil) (deftest some.19 (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) - :element-type type - :fill-pointer 4))) - (equal (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (some #'minusp v))) - '(nil nil nil nil nil t t t t t))) - collect i) + for type = `(signed-byte ,i) + unless + (let ((v (make-array '(10) :initial-contents '(0 0 0 0 -1 -1 -1 -1 -1 -1) + :element-type type + :fill-pointer 4))) + (equal (loop for j from 0 to 9 + do (setf (fill-pointer v) j) + collect (notnot (some #'minusp v))) + '(nil nil nil nil nil t t t t t))) + collect i) nil) (deftest some.20 (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'character - :fill-pointer 4))) + :element-type 'character + :fill-pointer 4))) (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (some #'digit-char-p v)))) + do (setf (fill-pointer v) j) + collect (notnot (some #'digit-char-p v)))) (nil nil nil nil nil t t t t t)) (deftest some.21 (let ((v (make-array '(10) :initial-contents "abcd012345" - :element-type 'base-char - :fill-pointer 4))) + :element-type 'base-char + :fill-pointer 4))) (loop for j from 0 to 9 - do (setf (fill-pointer v) j) - collect (notnot (some #'digit-char-p v)))) + do (setf (fill-pointer v) j) + collect (notnot (some #'digit-char-p v)))) (nil nil nil nil nil t t t t t)) (deftest some.22 (let ((v (make-array '(5) :initial-contents "abcde" - :element-type 'base-char))) + :element-type 'base-char))) (values (some #'digit-char-p v) (setf (aref v 2) #\0) @@ -146,42 +146,42 @@ (deftest some.23 (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(9) - :element-type type - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) - unless (some #'zerop v) - collect (list type v)) + for v = (make-array '(9) + :element-type type + :initial-contents + (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) + unless (some #'zerop v) + collect (list type v)) nil) (deftest some.24 (loop for type in '(short-float single-float double-float long-float) - for v = (make-array '(9) - :element-type type - :fill-pointer 6 - :initial-contents - (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) - when (some #'zerop v) - collect (list type v)) + for v = (make-array '(9) + :element-type type + :fill-pointer 6 + :initial-contents + (mapcar #'(lambda (x) (coerce x type)) '(1 2 3 4 5 6 0 8 3))) + when (some #'zerop v) + collect (list type v)) nil) (deftest some.25 (loop for type in '(short-float single-float double-float long-float) - for ctype = `(complex ,type) - for v = (make-array '(6) - :element-type ctype - :initial-contents - (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) - when (some (complement #'complexp) v) - collect (list type v)) + for ctype = `(complex ,type) + for v = (make-array '(6) + :element-type ctype + :initial-contents + (mapcar #'(lambda (x) (complex x (coerce x type))) '(1 2 3 4 5 6))) + when (some (complement #'complexp) v) + collect (list type v)) nil) ;;; Displaced vectors (deftest some.26 (let* ((v1 (make-array '(10) :initial-contents '(1 3 2 4 6 8 5 7 9 1))) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2))) + (v2 (make-array '(4) :displaced-to v1 + :displaced-index-offset 2))) (values (notnot (some #'oddp v1)) (some #'oddp v2))) @@ -189,53 +189,53 @@ (deftest some.27 (loop for i from 1 to 40 - for type = `(unsigned-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (some 'oddp v1)) - (not (some #'oddp v2))) - collect i) + for type = `(unsigned-byte ,i) + unless + (let* ((v1 (make-array '(10) :initial-contents '(1 1 0 0 0 0 1 1 1 1) + :element-type type)) + (v2 (make-array '(4) :displaced-to v1 + :displaced-index-offset 2 + :element-type type))) + (and (some 'oddp v1)) + (not (some #'oddp v2))) + collect i) nil) (deftest some.28 (loop for i from 1 to 40 - for type = `(signed-byte ,i) - unless - (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) - :element-type type)) - (v2 (make-array '(4) :displaced-to v1 - :displaced-index-offset 2 - :element-type type))) - (and (some 'oddp v1) - (not (some #'oddp v2)))) - collect i) + for type = `(signed-byte ,i) + unless + (let* ((v1 (make-array '(10) :initial-contents '(-1 -1 0 0 0 0 -1 -1 -1 -1) + :element-type type)) + (v2 (make-array '(4) :displaced-to v1 + :displaced-index-offset 2 + :element-type type))) + (and (some 'oddp v1) + (not (some #'oddp v2)))) + collect i) nil) (deftest some.29 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'character))) (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'character - :displaced-to s1 - :displaced-index-offset i) - collect (notnot (some 'digit-char-p s2)))) + for s2 = (make-array '(2) :element-type 'character + :displaced-to s1 + :displaced-index-offset i) + collect (notnot (some 'digit-char-p s2)))) (t t nil nil t t t)) (deftest some.30 (let* ((s1 (make-array '(8) :initial-contents "12abc345" :element-type 'base-char))) (loop for i from 0 to 6 - for s2 = (make-array '(2) :element-type 'base-char - :displaced-to s1 - :displaced-index-offset i) - collect (notnot (some 'digit-char-p s2)))) + for s2 = (make-array '(2) :element-type 'base-char + :displaced-to s1 + :displaced-index-offset i) + collect (notnot (some 'digit-char-p s2)))) (t t nil nil t t t)) (deftest some.31 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :adjustable t))) + :adjustable t))) (values (some #'minusp v) (progn @@ -245,8 +245,8 @@ (deftest some.32 (let ((v (make-array '(10) :initial-contents '(1 2 3 4 5 6 7 8 9 10) - :fill-pointer 10 - :adjustable t))) + :fill-pointer 10 + :adjustable t))) (values (some #'minusp v) (progn @@ -258,7 +258,7 @@ (let ((i 0) x y) (values (some (progn (setf x (incf i)) #'null) - (progn (setf y (incf i)) '(a b c d))) + (progn (setf y (incf i)) '(a b c d))) i x y)) nil 2 1 2) @@ -266,15 +266,15 @@ (let ((i 0) x y z) (values (some (progn (setf x (incf i)) #'eq) - (progn (setf y (incf i)) '(a b c d)) - (progn (setf z (incf i)) '(e f g h))) + (progn (setf y (incf i)) '(a b c d)) + (progn (setf z (incf i)) '(e f g h))) i x y z)) nil 3 1 2 3) (deftest some.error.1 (check-type-error #'(lambda (x) (some x '(a b c))) - (typef '(or symbol function))) + (typef '(or symbol function))) nil) (deftest some.error.4 diff --git a/ansi-tests/sort-aux.lsp b/ansi-tests/sort-aux.lsp index d2b940bb..96119fd5 100644 --- a/ansi-tests/sort-aux.lsp +++ b/ansi-tests/sort-aux.lsp @@ -10,8 +10,8 @@ (if (null (cdr list)) list (let* ((len2 (ash (length list) -1)) - (l1 (my-numeric-sort (subseq list 0 len2))) - (l2 (my-numeric-sort (subseq list len2)))) + (l1 (my-numeric-sort (subseq list 0 len2))) + (l2 (my-numeric-sort (subseq list len2)))) (my-numeric-merge l1 l2)))) (defun my-numeric-merge (l1 l2) @@ -31,7 +31,7 @@ for i below reps for list = (generate-random-sort-test (random n) m) unless (equal (my-numeric-sort list) - (sort (copy-seq list) #'<)) + (sort (copy-seq list) #'<)) collect list)) (defun random-stable-sort-test (n m reps) @@ -39,5 +39,5 @@ for i below reps for list = (generate-random-sort-test (random n) m) unless (equal (my-numeric-sort list) - (stable-sort (copy-seq list) #'<)) + (stable-sort (copy-seq list) #'<)) collect list)) diff --git a/ansi-tests/sort.lsp b/ansi-tests/sort.lsp index 9ef42fd9..3785f548 100644 --- a/ansi-tests/sort.lsp +++ b/ansi-tests/sort.lsp @@ -30,14 +30,14 @@ repeat 100 always (let ((a (list 1 2 3 4 5 6 7 8 9 0)) - (cmp (make-array '(10 10)))) + (cmp (make-array '(10 10)))) (loop for i from 0 to 9 do - (loop for j from 0 to 9 do - (setf (aref cmp i j) (zerop (logand (random 1024) 512))))) + (loop for j from 0 to 9 do + (setf (aref cmp i j) (zerop (logand (random 1024) 512))))) (setq a (sort a #'(lambda (i j) (aref cmp i j)))) (and (eqlt (length a) 10) - (equalt (sort a #'<) '(0 1 2 3 4 5 6 7 8 9))))) - t) + (equalt (sort a #'<) '(0 1 2 3 4 5 6 7 8 9))))) + t) (deftest sort-vector.1 (let ((a (copy-seq #(1 4 2 5 3)))) @@ -57,7 +57,7 @@ (deftest sort-vector.4 (let ((a (make-array 10 :initial-contents '(10 40 20 50 30 15 45 25 55 35) - :fill-pointer 5))) + :fill-pointer 5))) (sort a #'<)) #(10 20 30 40 50)) @@ -66,13 +66,13 @@ repeat 100 always (let ((a (vector 1 2 3 4 5 6 7 8 9 0)) - (cmp (make-array '(10 10)))) + (cmp (make-array '(10 10)))) (loop for i from 0 to 9 do - (loop for j from 0 to 9 do - (setf (aref cmp i j) (zerop (logand (random 1024) 512))))) + (loop for j from 0 to 9 do + (setf (aref cmp i j) (zerop (logand (random 1024) 512))))) (setq a (sort a #'(lambda (i j) (aref cmp i j)))) (and (eqlt (length a) 10) - (equalpt (sort a #'<) #(0 1 2 3 4 5 6 7 8 9))))) + (equalpt (sort a #'<) #(0 1 2 3 4 5 6 7 8 9))))) t) (deftest sort-vector.6 @@ -98,33 +98,33 @@ (deftest sort-vector.9 (let* ((ivals '(1 4 7 3 2 6 5)) - (sivals '(1 2 3 4 5 6 7)) - (len (length ivals))) + (sivals '(1 2 3 4 5 6 7)) + (len (length ivals))) (loop for etype in '(short-float single-float double-float long-float rational) - for vals = (loop for i in ivals collect (coerce i etype)) - for svals = (loop for i in sivals collect (coerce i etype)) - for vec = (make-array len :element-type etype :initial-contents vals) - for svec = (sort vec #'<) - unless (and (eql (length svec) len) - (every #'eql svals svec)) - collect (list etype vals svec))) + for vals = (loop for i in ivals collect (coerce i etype)) + for svals = (loop for i in sivals collect (coerce i etype)) + for vec = (make-array len :element-type etype :initial-contents vals) + for svec = (sort vec #'<) + unless (and (eql (length svec) len) + (every #'eql svals svec)) + collect (list etype vals svec))) nil) (deftest sort-vector.10 (let* ((ivals '(1 4 7 3 2 6 5)) - (sivals '(1 2 3 4 5 6 7)) - (len (length ivals))) + (sivals '(1 2 3 4 5 6 7)) + (len (length ivals))) (loop for cetype in '(short-float single-float double-float long-float rational) - for etype = `(complex ,cetype) - for vals = (loop for i in ivals collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for svals = (loop for i in sivals collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for vec = (make-array len :element-type etype :initial-contents vals) - for svec = (sort vec #'(lambda (x y) (< (abs x) (abs y)))) - unless (and (eql (length svec) len) - (every #'eql svals svec)) - collect (list etype vals svec))) + for etype = `(complex ,cetype) + for vals = (loop for i in ivals collect (complex (coerce i cetype) + (coerce (- i) cetype))) + for svals = (loop for i in sivals collect (complex (coerce i cetype) + (coerce (- i) cetype))) + for vec = (make-array len :element-type etype :initial-contents vals) + for svec = (sort vec #'(lambda (x y) (< (abs x) (abs y)))) + unless (and (eql (length svec) len) + (every #'eql svals svec)) + collect (list etype vals svec))) nil) ;;; Bit vectors @@ -142,8 +142,8 @@ (deftest sort-bit-vector.3 (let ((a (make-array 10 :initial-contents '(1 0 0 1 1 1 1 0 1 1) - :element-type 'bit - :fill-pointer 5))) + :element-type 'bit + :fill-pointer 5))) (sort a #'<)) #*00111) @@ -161,8 +161,8 @@ (deftest sort-string.3 (let ((a (make-array 10 :initial-contents "1001111011" - :element-type 'character - :fill-pointer 5))) + :element-type 'character + :fill-pointer 5))) (sort a #'char<)) "00111") @@ -180,7 +180,7 @@ (let ((i 0) x y) (values (sort (progn (setf x (incf i)) (list 1 7 3 2)) - (progn (setf y (incf i)) #'<)) + (progn (setf y (incf i)) #'<)) i x y)) (1 2 3 7) 2 1 2) @@ -188,8 +188,8 @@ (let ((i 0) x y z) (values (sort (progn (setf x (incf i)) (list 1 7 3 2)) - (progn (setf y (incf i)) #'<) - :key (progn (setf z (incf i)) #'-)) + (progn (setf y (incf i)) #'<) + :key (progn (setf z (incf i)) #'-)) i x y z)) (7 3 2 1) 3 1 2 3) diff --git a/ansi-tests/special-operator-p.lsp b/ansi-tests/special-operator-p.lsp index 1695d809..09d72275 100644 --- a/ansi-tests/special-operator-p.lsp +++ b/ansi-tests/special-operator-p.lsp @@ -8,16 +8,16 @@ ;;; See section 3.1.2.1.2.1 (defparameter +special-operators+ '(block let* return-from catch load-time-value setq eval-when - locally symbol-macrolet flet macrolet tagbody function - multiple-value-call the go multiple-value-prog1 throw if - progn unwind-protect labels progv let quote)) + locally symbol-macrolet flet macrolet tagbody function + multiple-value-call the go multiple-value-prog1 throw if + progn unwind-protect labels progv let quote)) ;;; All the symbols in +special-operators+ are special operators (deftest special-operator-p.1 (loop for s in +special-operators+ - unless (special-operator-p s) - collect s) + unless (special-operator-p s) + collect s) nil) ;;; None of the standard symbols except those in +special-operators+ @@ -27,17 +27,17 @@ (deftest special-operator-p.2 (let ((p (find-package "CL"))) (loop for name in *cl-symbol-names* - unless (or (member name +special-operators+ :test #'string=) - (let ((sym (find-symbol name p))) - (or (not (special-operator-p sym)) - (macro-function sym)))) - collect name)) + unless (or (member name +special-operators+ :test #'string=) + (let ((sym (find-symbol name p))) + (or (not (special-operator-p sym)) + (macro-function sym)))) + collect name)) nil) (deftest special-operator-p.order.1 (let ((i 0)) (values (notnot (special-operator-p (progn (incf i) 'catch))) - i)) + i)) t 1) (deftest special-operator-p.error.1 diff --git a/ansi-tests/special.lsp b/ansi-tests/special.lsp index 3f03af74..699f5290 100644 --- a/ansi-tests/special.lsp +++ b/ansi-tests/special.lsp @@ -13,8 +13,8 @@ (declare (special f)) (flet ((f () :good)) (flet ((g () (f))) - (flet ((f () :bad)) - (g))))) + (flet ((f () :bad)) + (g))))) :good) (deftest special.2 diff --git a/ansi-tests/sqrt.lsp b/ansi-tests/sqrt.lsp index 58a1259c..2e8a0ff3 100644 --- a/ansi-tests/sqrt.lsp +++ b/ansi-tests/sqrt.lsp @@ -22,183 +22,183 @@ (deftest sqrt.1 (let ((s (sqrt 0))) (and (realp s) - (=t s 0))) + (=t s 0))) t) (deftest sqrt.2 (let ((s (sqrt 1))) (and (realp s) - (=t s 1))) + (=t s 1))) t) (deftest sqrt.3 (loop for x in '(0.0s0 1.0s0 0.0f0 1.0f0 0.0d0 1.0d0 0.0l0 1.0l0) - for s = (sqrt x) - unless (eql s x) - collect (list x s)) + for s = (sqrt x) + unless (eql s x) + collect (list x s)) nil) (deftest sqrt.4 (loop for x in '(0.0s0 1.0s0 0.0f0 1.0f0 0.0d0 1.0d0 0.0l0 1.0l0) - for c = (complex x 0) - for s = (sqrt c) - unless (eql s c) - collect (list x c s)) + for c = (complex x 0) + for s = (sqrt c) + unless (eql s c) + collect (list x c s)) nil) (deftest sqrt.5 (loop for x in '(-1.0s0 -1.0f0 -1.0d0 -1.0l0) - for s = (sqrt x) - unless (eql s (complex 0 (- x))) - collect (list x s)) + for s = (sqrt x) + unless (eql s (complex 0 (- x))) + collect (list x s)) nil) ;;; (deftest sqrt.6 ;;; (let ((result (sqrt (ash 1 10000)))) ;;; (if (integerp result) -;;; (=t result (ash 1 5000)) +;;; (=t result (ash 1 5000)) ;;; (=t result (float (ash 1 5000) result)))) ;;; t) (deftest sqrt.7 (let ((result (sqrt -1))) (or (eqlt result #c(0 1)) - (eqlt result #c(0.0 1.0)))) + (eqlt result #c(0.0 1.0)))) t) (deftest sqrt.8 (loop for x in *floats* - for s = (sqrt x) - unless (cond - ((zerop x) (=t x 0)) - ((plusp x) (and (eqlt (float s x) s) - (eqlt (float x s) x))) - (t (complexp s))) - collect (list x s)) + for s = (sqrt x) + unless (cond + ((zerop x) (=t x 0)) + ((plusp x) (and (eqlt (float s x) s) + (eqlt (float x s) x))) + (t (complexp s))) + collect (list x s)) nil) (deftest sqrt.9 (let ((upper (rational most-positive-double-float)) - (lower (rational most-negative-double-float))) + (lower (rational most-negative-double-float))) (loop for x = (random-fixnum) - repeat 1000 - unless (or (< x lower) - (> x upper) - (let ((s (sqrt x))) - (or (and (rationalp s) - (>= s 0) - (eql (* s s) x)) - (and (floatp s) (>= x 0)) - (and (complexp s) - (zerop (realpart s)) - (> (imagpart s) 0) - (< x 0))))) - collect (list x (sqrt x)))) + repeat 1000 + unless (or (< x lower) + (> x upper) + (let ((s (sqrt x))) + (or (and (rationalp s) + (>= s 0) + (eql (* s s) x)) + (and (floatp s) (>= x 0)) + (and (complexp s) + (zerop (realpart s)) + (> (imagpart s) 0) + (< x 0))))) + collect (list x (sqrt x)))) nil) (deftest sqrt.10 (loop for x from 1 to 1000 - for x2 = (* x x) - for s = (sqrt x2) - unless (if (rationalp s) (eql x s) - (and (typep s 'single-float) - (= x s))) - collect (list x s)) + for x2 = (* x x) + for s = (sqrt x2) + unless (if (rationalp s) (eql x s) + (and (typep s 'single-float) + (= x s))) + collect (list x s)) nil) (deftest sqrt.11 (loop for x from 1 to 1000 - for x2 = (* x x) - for s = (sqrt (- x2)) - unless (and (complexp s) - (zerop (realpart s)) - (let ((i (imagpart s))) - (if (rationalp i) - (eql i x) - (= i x)))) - collect (list x s)) + for x2 = (* x x) + for s = (sqrt (- x2)) + unless (and (complexp s) + (zerop (realpart s)) + (let ((i (imagpart s))) + (if (rationalp i) + (eql i x) + (= i x)))) + collect (list x s)) nil) ;;; Tests of the branch cut (deftest sqrt.12 (loop for xr = (random-fixnum) - for xi = (random-fixnum) - for c = (complex xr xi) - for s = (sqrt c) - repeat 1000 - unless (or (> (realpart s) 0) - (and (= (realpart s) 0) - (>= (imagpart s) 0))) - collect (list c s)) + for xi = (random-fixnum) + for c = (complex xr xi) + for s = (sqrt c) + repeat 1000 + unless (or (> (realpart s) 0) + (and (= (realpart s) 0) + (>= (imagpart s) 0))) + collect (list c s)) nil) (deftest sqrt.13 (loop for xr = (random-from-interval 1.0f6 -1.0f6) - for xi = (random-from-interval 1.0f6 -1.0f6) - for c = (complex xr xi) - for s = (sqrt c) - repeat 1000 - unless (or (> (realpart s) 0) - (and (= (realpart s) 0) - (>= (imagpart s) 0))) - collect (list c s)) - nil) - + for xi = (random-from-interval 1.0f6 -1.0f6) + for c = (complex xr xi) + for s = (sqrt c) + repeat 1000 + unless (or (> (realpart s) 0) + (and (= (realpart s) 0) + (>= (imagpart s) 0))) + collect (list c s)) + nil) + (deftest sqrt.14 (loop for xr = (random-from-interval 1.0s3 -1.0s3) - for xi = (random-from-interval 1.0s3 -1.0s3) - for c = (complex xr xi) - for s = (sqrt c) - repeat 1000 - unless (or (> (realpart s) 0) - (and (= (realpart s) 0) - (>= (imagpart s) 0))) - collect (list c s)) - nil) - + for xi = (random-from-interval 1.0s3 -1.0s3) + for c = (complex xr xi) + for s = (sqrt c) + repeat 1000 + unless (or (> (realpart s) 0) + (and (= (realpart s) 0) + (>= (imagpart s) 0))) + collect (list c s)) + nil) + (deftest sqrt.15 (loop for xr = (random-from-interval 1.0d7 -1.0d7) - for xi = (random-from-interval 1.0d7 -1.0d7) - for c = (complex xr xi) - for s = (sqrt c) - repeat 1000 - unless (or (> (realpart s) 0) - (and (= (realpart s) 0) - (>= (imagpart s) 0))) - collect (list c s)) + for xi = (random-from-interval 1.0d7 -1.0d7) + for c = (complex xr xi) + for s = (sqrt c) + repeat 1000 + unless (or (> (realpart s) 0) + (and (= (realpart s) 0) + (>= (imagpart s) 0))) + collect (list c s)) nil) (deftest sqrt.16 (loop for xr = (random-from-interval 1.0l9 -1.0l9) - for xi = (random-from-interval 1.0l9 -1.0l9) - for c = (complex xr xi) - for s = (sqrt c) - repeat 1000 - unless (or (> (realpart s) 0) - (and (= (realpart s) 0) - (>= (imagpart s) 0))) - collect (list c s)) + for xi = (random-from-interval 1.0l9 -1.0l9) + for c = (complex xr xi) + for s = (sqrt c) + repeat 1000 + unless (or (> (realpart s) 0) + (and (= (realpart s) 0) + (>= (imagpart s) 0))) + collect (list c s)) nil) (deftest sqrt.17 (let ((b1 (find-largest-exactly-floatable-integer most-positive-fixnum))) (loop for i = (random-from-interval (* b1 b1) 0) - repeat 1000 - unless (>= (sqrt i) (isqrt i)) - collect i)) + repeat 1000 + unless (>= (sqrt i) (isqrt i)) + collect i)) nil) (deftest sqrt.18 (loop for x = (random-from-interval 1.0f6 0.0f0) - repeat 1000 - unless (>= (sqrt x) (isqrt (floor x))) - collect x) + repeat 1000 + unless (>= (sqrt x) (isqrt (floor x))) + collect x) nil) (deftest sqrt.19 (loop for x in '(0.0s0 0.0f0 0.0d0 0.0l0) - for s = (sqrt x) - unless (= s x) - collect (list x s)) + for s = (sqrt x) + unless (= s x) + collect (list x s)) nil) diff --git a/ansi-tests/stable-sort.lsp b/ansi-tests/stable-sort.lsp index 3ea8f726..0cbc2019 100644 --- a/ansi-tests/stable-sort.lsp +++ b/ansi-tests/stable-sort.lsp @@ -49,7 +49,7 @@ (deftest stable-sort-vector.4 (let ((a (make-array 10 :initial-contents '(10 40 20 50 30 15 45 25 55 35) - :fill-pointer 5))) + :fill-pointer 5))) (stable-sort a #'<)) #(10 20 30 40 50)) @@ -78,33 +78,33 @@ (deftest stable-sort-vector.9 (let* ((ivals '(1 4 7 3 2 6 5)) - (sivals '(1 2 3 4 5 6 7)) - (len (length ivals))) + (sivals '(1 2 3 4 5 6 7)) + (len (length ivals))) (loop for etype in '(short-float single-float double-float long-float rational) - for vals = (loop for i in ivals collect (coerce i etype)) - for svals = (loop for i in sivals collect (coerce i etype)) - for vec = (make-array len :element-type etype :initial-contents vals) - for svec = (stable-sort vec #'<) - unless (and (eql (length svec) len) - (every #'eql svals svec)) - collect (list etype vals svec))) + for vals = (loop for i in ivals collect (coerce i etype)) + for svals = (loop for i in sivals collect (coerce i etype)) + for vec = (make-array len :element-type etype :initial-contents vals) + for svec = (stable-sort vec #'<) + unless (and (eql (length svec) len) + (every #'eql svals svec)) + collect (list etype vals svec))) nil) (deftest stable-sort-vector.10 (let* ((ivals '(1 4 7 3 2 6 5)) - (sivals '(1 2 3 4 5 6 7)) - (len (length ivals))) + (sivals '(1 2 3 4 5 6 7)) + (len (length ivals))) (loop for cetype in '(short-float single-float double-float long-float rational) - for etype = `(complex ,cetype) - for vals = (loop for i in ivals collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for svals = (loop for i in sivals collect (complex (coerce i cetype) - (coerce (- i) cetype))) - for vec = (make-array len :element-type etype :initial-contents vals) - for svec = (stable-sort vec #'(lambda (x y) (< (abs x) (abs y)))) - unless (and (eql (length svec) len) - (every #'eql svals svec)) - collect (list etype vals svec))) + for etype = `(complex ,cetype) + for vals = (loop for i in ivals collect (complex (coerce i cetype) + (coerce (- i) cetype))) + for svals = (loop for i in sivals collect (complex (coerce i cetype) + (coerce (- i) cetype))) + for vec = (make-array len :element-type etype :initial-contents vals) + for svec = (stable-sort vec #'(lambda (x y) (< (abs x) (abs y)))) + unless (and (eql (length svec) len) + (every #'eql svals svec)) + collect (list etype vals svec))) nil) ;;; Bit vectors @@ -122,8 +122,8 @@ (deftest stable-sort-bit-vector.3 (let ((a (make-array 10 :initial-contents '(1 0 0 1 1 1 1 0 1 1) - :element-type 'bit - :fill-pointer 5))) + :element-type 'bit + :fill-pointer 5))) (stable-sort a #'<)) #*00111) @@ -136,14 +136,14 @@ (deftest stable-sort-string.2 (let ((a (copy-seq "10011101"))) (values (stable-sort a #'char< - :key #'(lambda (c) (if (eql c #\0) #\1 #\0))) a)) + :key #'(lambda (c) (if (eql c #\0) #\1 #\0))) a)) "11111000" "11111000") (deftest stable-sort-string.3 (let ((a (make-array 10 :initial-contents "1001111011" - :element-type 'character - :fill-pointer 5))) + :element-type 'character + :fill-pointer 5))) (stable-sort a #'char<)) "00111") @@ -161,7 +161,7 @@ (let ((i 0) x y) (values (stable-sort (progn (setf x (incf i)) (list 1 7 3 2)) - (progn (setf y (incf i)) #'<)) + (progn (setf y (incf i)) #'<)) i x y)) (1 2 3 7) 2 1 2) @@ -169,8 +169,8 @@ (let ((i 0) x y z) (values (stable-sort (progn (setf x (incf i)) (list 1 7 3 2)) - (progn (setf y (incf i)) #'<) - :key (progn (setf z (incf i)) #'-)) + (progn (setf y (incf i)) #'<) + :key (progn (setf z (incf i)) #'-)) i x y z)) (7 3 2 1) 3 1 2 3) diff --git a/ansi-tests/standard-generic-function.lsp b/ansi-tests/standard-generic-function.lsp index 3eec6331..c13ca750 100644 --- a/ansi-tests/standard-generic-function.lsp +++ b/ansi-tests/standard-generic-function.lsp @@ -13,9 +13,9 @@ (progn (eval '(defgeneric sgf-cpl-gf.1 (x) - (:method ((x generic-function)) 1) - (:method ((x function)) 2) - (:method ((x t)) 3))) + (:method ((x generic-function)) 1) + (:method ((x function)) 2) + (:method ((x t)) 3))) (values (sgf-cpl-gf.1 #'make-instance) (sgf-cpl-gf.1 #'cons) @@ -26,9 +26,9 @@ (progn (eval '(defgeneric sgf-cpl-gf.2 (x) - (:method ((x standard-generic-function)) 1) - (:method ((x function)) 2) - (:method ((x t)) 3))) + (:method ((x standard-generic-function)) 1) + (:method ((x function)) 2) + (:method ((x t)) 3))) (values (sgf-cpl-gf.2 #'make-instance) (sgf-cpl-gf.2 #'cons) @@ -41,5 +41,5 @@ - - + + diff --git a/ansi-tests/store-value.lsp b/ansi-tests/store-value.lsp index 3699ccc7..464f4e49 100644 --- a/ansi-tests/store-value.lsp +++ b/ansi-tests/store-value.lsp @@ -13,7 +13,7 @@ (deftest store-value.2 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 @@ -31,7 +31,7 @@ (deftest store-value.4 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 @@ -43,7 +43,7 @@ (deftest store-value.5 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) diff --git a/ansi-tests/stream-element-type.lsp b/ansi-tests/stream-element-type.lsp index 71bfa864..a1149448 100644 --- a/ansi-tests/stream-element-type.lsp +++ b/ansi-tests/stream-element-type.lsp @@ -7,57 +7,57 @@ (deftest stream-element-type.1 (loop for s in (list *debug-io* *error-output* *query-io* - *standard-input* *standard-output* - *trace-output* *terminal-io*) - for results = (multiple-value-list (stream-element-type s)) - unless (and (eql (length results) 1) - (car results)) - collect s) + *standard-input* *standard-output* + *trace-output* *terminal-io*) + for results = (multiple-value-list (stream-element-type s)) + unless (and (eql (length results) 1) + (car results)) + collect s) nil) (deftest stream-element-type.2 (let ((pn "foo.txt")) (loop for i from 1 to 100 - for etype = `(unsigned-byte ,i) - for s = (progn (delete-all-versions pn) - (open pn :direction :output - :element-type etype)) - unless - (multiple-value-bind (sub good) - (subtypep etype (stream-element-type s)) - (close s) - (or sub (not good))) - collect i)) + for etype = `(unsigned-byte ,i) + for s = (progn (delete-all-versions pn) + (open pn :direction :output + :element-type etype)) + unless + (multiple-value-bind (sub good) + (subtypep etype (stream-element-type s)) + (close s) + (or sub (not good))) + collect i)) nil) (deftest stream-element-type.3 (let ((pn "foo.txt")) (loop for i from 1 to 100 - for etype = `(signed-byte ,i) - for s = (progn (delete-all-versions pn) - (open pn :direction :output - :element-type etype)) - unless - (multiple-value-bind (sub good) - (subtypep etype (stream-element-type s)) - (close s) - (or sub (not good))) - collect i)) + for etype = `(signed-byte ,i) + for s = (progn (delete-all-versions pn) + (open pn :direction :output + :element-type etype)) + unless + (multiple-value-bind (sub good) + (subtypep etype (stream-element-type s)) + (close s) + (or sub (not good))) + collect i)) nil) (deftest stream-element-type.4 (let ((pn "foo.txt")) (loop for i from 1 to 100 - for etype = `(integer 0 ,i) - for s = (progn (delete-all-versions pn) - (open pn :direction :output - :element-type etype)) - unless - (multiple-value-bind (sub good) - (subtypep etype (stream-element-type s)) - (close s) - (or sub (not good))) - collect i)) + for etype = `(integer 0 ,i) + for s = (progn (delete-all-versions pn) + (open pn :direction :output + :element-type etype)) + unless + (multiple-value-bind (sub good) + (subtypep etype (stream-element-type s)) + (close s) + (or sub (not good))) + collect i)) nil) @@ -67,10 +67,10 @@ (delete-all-versions pn) (let ((s (open pn :direction :output))) (let ((etype (stream-element-type s))) - (unwind-protect - (equalt (multiple-value-list (subtypep* 'character etype)) - '(nil t)) - (close s))))) + (unwind-protect + (equalt (multiple-value-list (subtypep* 'character etype)) + '(nil t)) + (close s))))) nil) (deftest stream-element-type.6 @@ -78,15 +78,15 @@ (let ((pn "foo.txt")) (delete-all-versions pn) (let ((s (open pn :direction :output - :element-type :default))) + :element-type :default))) (let ((etype (stream-element-type s))) - (unwind-protect - (multiple-value-bind (sub1 good1) (subtypep* etype 'integer) - (multiple-value-bind (sub2 good2) (subtypep* etype 'character) - (or (not good1) - (not good2) - sub1 sub2))) - (close s))))) + (unwind-protect + (multiple-value-bind (sub1 good1) (subtypep* etype 'integer) + (multiple-value-bind (sub2 good2) (subtypep* etype 'character) + (or (not good1) + (not good2) + sub1 sub2))) + (close s))))) t) (deftest stream-element-type.error.1 diff --git a/ansi-tests/stream-error-stream.lsp b/ansi-tests/stream-error-stream.lsp index 9a7f533e..4d75ab31 100644 --- a/ansi-tests/stream-error-stream.lsp +++ b/ansi-tests/stream-error-stream.lsp @@ -31,4 +31,4 @@ t) - + diff --git a/ansi-tests/streamp.lsp b/ansi-tests/streamp.lsp index 2ffd9658..4d033316 100644 --- a/ansi-tests/streamp.lsp +++ b/ansi-tests/streamp.lsp @@ -7,11 +7,11 @@ (deftest streamp.1 (loop for s in (list *debug-io* *error-output* *query-io* - *standard-input* *standard-output* - *trace-output* *terminal-io*) - unless (equal (multiple-value-list (notnot-mv (streamp s))) - '(t)) - collect s) + *standard-input* *standard-output* + *trace-output* *terminal-io*) + unless (equal (multiple-value-list (notnot-mv (streamp s))) + '(t)) + collect s) nil) (deftest streamp.2 @@ -20,16 +20,16 @@ (deftest streamp.3 (let ((s (open "foo.txt" :direction :output - :if-exists :supersede))) + :if-exists :supersede))) (close s) (notnot-mv (streamp s))) t) (deftest streamp.4 (let ((s (open "foo.txt" :direction :output - :if-exists :supersede))) + :if-exists :supersede))) (unwind-protect - (notnot-mv (streamp s)) + (notnot-mv (streamp s)) (close s))) t) diff --git a/ansi-tests/string-aux.lsp b/ansi-tests/string-aux.lsp index ffafc52b..be4d9080 100644 --- a/ansi-tests/string-aux.lsp +++ b/ansi-tests/string-aux.lsp @@ -9,24 +9,24 @@ (compile-and-load "random-aux.lsp")) (defun my-string-compare (string1 string2 comparison - &key (start1 0) end1 (start2 0) end2 case - &aux - (len1 (progn (assert (stringp string1)) - (length string1))) - (len2 (progn (assert (stringp string2)) - (length string2))) - (compare-fn - (case comparison - (< (if case #'char-lessp #'char<)) - (<= (if case #'char-not-greaterp - #'char<=)) - (= (if case #'char-equal #'char=)) - (/= (if case #'char-not-equal #'char/=)) - (> (if case #'char-greaterp #'char>)) - (>= (if case #'char-not-lessp #'char>=)) - (t (error "Bad comparison arg: ~A~%" - comparison)))) - (equal-fn (if case #'char-equal #'char=))) + &key (start1 0) end1 (start2 0) end2 case + &aux + (len1 (progn (assert (stringp string1)) + (length string1))) + (len2 (progn (assert (stringp string2)) + (length string2))) + (compare-fn + (case comparison + (< (if case #'char-lessp #'char<)) + (<= (if case #'char-not-greaterp + #'char<=)) + (= (if case #'char-equal #'char=)) + (/= (if case #'char-not-equal #'char/=)) + (> (if case #'char-greaterp #'char>)) + (>= (if case #'char-not-lessp #'char>=)) + (t (error "Bad comparison arg: ~A~%" + comparison)))) + (equal-fn (if case #'char-equal #'char=))) (assert (integerp start1)) (assert (integerp start2)) @@ -43,113 +43,113 @@ (return (cond ((= i2 end2) - ;; Both ended -- equality case - (if (member comparison '(= <= >=)) - end1 - nil)) + ;; Both ended -- equality case + (if (member comparison '(= <= >=)) + end1 + nil)) (t ;; string2 still extending - (if (member comparison '(/= < <=)) - end1 - nil))))) + (if (member comparison '(/= < <=)) + end1 + nil))))) ((= i2 end2) ;; string1 still extending (return (if (member comparison '(/= > >=)) - i1 - nil))) + i1 + nil))) (t (let ((c1 (my-aref string1 i1)) - (c2 (my-aref string2 i2))) + (c2 (my-aref string2 i2))) (cond - ((funcall equal-fn c1 c2)) - (t ;; mismatch found -- what kind? - (return - (if (funcall compare-fn c1 c2) - i1 - nil))))))))) + ((funcall equal-fn c1 c2)) + (t ;; mismatch found -- what kind? + (return + (if (funcall compare-fn c1 c2) + i1 + nil))))))))) (defun make-random-string-compare-test (n) (let* ((len (random n)) - ;; Maximum lengths of the two strings - (len1 (if (or (coin) (= len 0)) len (+ len (random len)))) - (len2 (if (or (coin) (= len 0)) len (+ len (random len)))) - (s1 (make-random-string len1)) - (s2 (make-random-string len2)) - ;; Actual lengths of the strings - (len1 (length s1)) - (len2 (length s2)) - ;; Lengths of the parts of the strings to be matched - (sublen1 (if (or (coin) (= len1 0)) (min len1 len2) (random len1))) - (sublen2 (if (or (coin) (= len2 0)) (min len2 sublen1) (random len2))) - ;; Start and end of the substring of the first string - (start1 (if (coin 3) 0 - (max 0 (min (1- len1) (random (- len1 sublen1 -1)))))) - (end1 (+ start1 sublen1)) - ;; Start and end of the substring of the second string - (start2 (if (coin 3) 0 - (max 0 (min (1- len2) (random (- len2 sublen2 -1)))))) - (end2 (+ start2 sublen2)) - ) + ;; Maximum lengths of the two strings + (len1 (if (or (coin) (= len 0)) len (+ len (random len)))) + (len2 (if (or (coin) (= len 0)) len (+ len (random len)))) + (s1 (make-random-string len1)) + (s2 (make-random-string len2)) + ;; Actual lengths of the strings + (len1 (length s1)) + (len2 (length s2)) + ;; Lengths of the parts of the strings to be matched + (sublen1 (if (or (coin) (= len1 0)) (min len1 len2) (random len1))) + (sublen2 (if (or (coin) (= len2 0)) (min len2 sublen1) (random len2))) + ;; Start and end of the substring of the first string + (start1 (if (coin 3) 0 + (max 0 (min (1- len1) (random (- len1 sublen1 -1)))))) + (end1 (+ start1 sublen1)) + ;; Start and end of the substring of the second string + (start2 (if (coin 3) 0 + (max 0 (min (1- len2) (random (- len2 sublen2 -1)))))) + (end2 (+ start2 sublen2)) + ) #| (format t "len = ~A, len1 = ~A, len2 = ~A, sublen1 = ~A, sublen2 = ~A~%" - len len1 len2 sublen1 sublen2) + len len1 len2 sublen1 sublen2) (format t "start1 = ~A, end1 = ~A, start2 = ~A, end2 = ~A~%" - start1 end1 start2 end2) + start1 end1 start2 end2) (format t "s1 = ~S, s2 = ~S~%" s1 s2) |# ;; Sometimes we want them to have a common prefix (when (and (coin) - (equal (array-element-type s1) - (array-element-type s2))) + (equal (array-element-type s1) + (array-element-type s2))) (if (<= sublen1 sublen2) - (setf (subseq s2 start2 (+ start2 sublen1)) - (subseq s1 start1 (+ start1 sublen1))) - (setf (subseq s1 start1 (+ start1 sublen2)) - (subseq s2 start2 (+ start2 sublen2))))) + (setf (subseq s2 start2 (+ start2 sublen1)) + (subseq s1 start1 (+ start1 sublen1))) + (setf (subseq s1 start1 (+ start1 sublen2)) + (subseq s2 start2 (+ start2 sublen2))))) (values s1 s2 (reduce #'nconc - (random-permute - (list - (if (and (= start1 0) (coin)) - nil - (list :start1 start1)) - (if (and (= end1 len1) (coin)) - nil - (list :end1 end1)) - (if (and (= start2 0) (coin)) - nil - (list :start2 start2)) - (if (and (= end2 len2) (coin)) - nil - (list :end2 end2)))))))) + (random-permute + (list + (if (and (= start1 0) (coin)) + nil + (list :start1 start1)) + (if (and (= end1 len1) (coin)) + nil + (list :end1 end1)) + (if (and (= start2 0) (coin)) + nil + (list :start2 start2)) + (if (and (= end2 len2) (coin)) + nil + (list :end2 end2)))))))) (defun random-string-compare-test (n comparison case &optional (iterations 1)) (loop for i from 1 to iterations - count - (multiple-value-bind (s1 s2 args) - (make-random-string-compare-test n) - ;; (format t "Strings: ~s ~s - Args = ~S~%" s1 s2 args) - (let ((x (apply (case comparison - (< (if case #'string-lessp #'string<)) - (<= (if case #'string-not-greaterp - #'string<=)) - (= (if case #'string-equal #'string=)) - (/= (if case #'string-not-equal #'string/=)) - (> (if case #'string-greaterp #'string>)) - (>= (if case #'string-not-lessp #'string>=)) - (t (error "Bad comparison arg: ~A~%" comparison))) - s1 s2 args)) - (y (apply #'my-string-compare s1 s2 comparison :case case args))) - (not - (or (eql x y) - (and x y (eqt comparison '=)))))))) + count + (multiple-value-bind (s1 s2 args) + (make-random-string-compare-test n) + ;; (format t "Strings: ~s ~s - Args = ~S~%" s1 s2 args) + (let ((x (apply (case comparison + (< (if case #'string-lessp #'string<)) + (<= (if case #'string-not-greaterp + #'string<=)) + (= (if case #'string-equal #'string=)) + (/= (if case #'string-not-equal #'string/=)) + (> (if case #'string-greaterp #'string>)) + (>= (if case #'string-not-lessp #'string>=)) + (t (error "Bad comparison arg: ~A~%" comparison))) + s1 s2 args)) + (y (apply #'my-string-compare s1 s2 comparison :case case args))) + (not + (or (eql x y) + (and x y (eqt comparison '=)))))))) (defun string-all-the-same (s) (let ((len (length s))) (or (= len 0) - (let ((c (my-aref s 0))) - (loop for i below len - for d = (my-aref s i) - always (eql c d)))))) + (let ((c (my-aref s 0))) + (loop for i below len + for d = (my-aref s i) + always (eql c d)))))) diff --git a/ansi-tests/string-capitalize.lsp b/ansi-tests/string-capitalize.lsp index 639614c6..38c6de5b 100644 --- a/ansi-tests/string-capitalize.lsp +++ b/ansi-tests/string-capitalize.lsp @@ -46,7 +46,7 @@ (let ((s "ABCDEF")) (values (loop for i from 0 to 5 - collect (string-capitalize s :start i)) + collect (string-capitalize s :start i)) s)) ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") "ABCDEF") @@ -55,7 +55,7 @@ (let ((s "ABCDEF")) (values (loop for i from 0 to 5 - collect (string-capitalize s :start i :end nil)) + collect (string-capitalize s :start i :end nil)) s)) ("Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") "ABCDEF") @@ -64,7 +64,7 @@ (let ((s "ABCDEF")) (values (loop for i from 0 to 6 - collect (string-capitalize s :end i)) + collect (string-capitalize s :end i)) s)) ("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") "ABCDEF") @@ -73,8 +73,8 @@ (let ((s "ABCDEF")) (values (loop for i from 0 to 5 - collect (loop for j from i to 6 - collect (string-capitalize s :start i :end j))) + collect (loop for j from i to 6 + collect (string-capitalize s :start i :end j))) s)) (("ABCDEF" "ABCDEF" "AbCDEF" "AbcDEF" "AbcdEF" "AbcdeF" "Abcdef") ("ABCDEF" "ABCDEF" "ABcDEF" "ABcdEF" "ABcdeF" "ABcdef") @@ -91,29 +91,29 @@ (deftest string-capitalize.12 (loop for type in '(standard-char base-char character) - for s = (make-array '(10) :element-type type - :fill-pointer 5 - :initial-contents "aB0cDefGHi") - collect (list s (string-capitalize s))) + for s = (make-array '(10) :element-type type + :fill-pointer 5 + :initial-contents "aB0cDefGHi") + collect (list s (string-capitalize s))) (("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd"))) (deftest string-capitalize.13 (loop for type in '(standard-char base-char character) - for s0 = (make-array '(10) :element-type type - :initial-contents "zZaB0cDefG") - for s = (make-array '(5) :element-type type - :displaced-to s0 - :displaced-index-offset 2) - collect (list s (string-capitalize s))) + for s0 = (make-array '(10) :element-type type + :initial-contents "zZaB0cDefG") + for s = (make-array '(5) :element-type type + :displaced-to s0 + :displaced-index-offset 2) + collect (list s (string-capitalize s))) (("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd"))) (deftest string-capitalize.14 (loop for type in '(standard-char base-char character) - for s = (make-array '(5) :element-type type - :adjustable t - :initial-contents "aB0cD") - collect (list s (string-capitalize s))) + for s = (make-array '(5) :element-type type + :adjustable t + :initial-contents "aB0cD") + collect (list s (string-capitalize s))) (("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd") ("aB0cD" "Ab0cd"))) ;;; Order of evaluation tests @@ -156,7 +156,7 @@ (deftest string-capitalize.error.4 (signals-error (string-capitalize (copy-seq "abc") :bad t - :allow-other-keys nil) program-error) + :allow-other-keys nil) program-error) t) (deftest string-capitalize.error.5 diff --git a/ansi-tests/string-comparisons.lsp b/ansi-tests/string-comparisons.lsp index 2db6e779..e66c149c 100644 --- a/ansi-tests/string-comparisons.lsp +++ b/ansi-tests/string-comparisons.lsp @@ -30,8 +30,8 @@ ;;; Test that it doesn't stop at null characters (deftest string=.6 (let ((s1 (copy-seq "abc")) - (s2 (copy-seq "abd")) - (c (or (code-char 0) #\a))) + (s2 (copy-seq "abd")) + (c (or (code-char 0) #\a))) (setf (char s1 1) c) (setf (char s2 1) c) (values (length s1) (length s2) (string= s1 s2))) @@ -39,75 +39,75 @@ (deftest string=.7 (loop for i from 0 to 3 - collect (not (string= "abc" "abd" :start1 0 :end1 i :end2 i))) + collect (not (string= "abc" "abd" :start1 0 :end1 i :end2 i))) (nil nil nil t)) (deftest string=.8 (loop for i from 0 to 3 - collect (not (string= "abc" "ab" :end1 i))) + collect (not (string= "abc" "ab" :end1 i))) (t t nil t)) (deftest string=.9 (loop for i from 0 to 3 - collect (not (string= "abc" "abd" :start2 0 :end2 i :end1 i))) + collect (not (string= "abc" "abd" :start2 0 :end2 i :end1 i))) (nil nil nil t)) (deftest string=.10 (loop for i from 0 to 3 - collect (not (string= "ab" "abc" :end2 i))) + collect (not (string= "ab" "abc" :end2 i))) (t t nil t)) (deftest string=.11 (loop for i from 0 to 3 - collect (not (string= "xyab" "ab" :start1 i))) + collect (not (string= "xyab" "ab" :start1 i))) (t t nil t)) (deftest string=.12 (loop for i from 0 to 3 - collect (not (string= "ab" "xyab" :start2 i))) + collect (not (string= "ab" "xyab" :start2 i))) (t t nil t)) (deftest string=.13 (loop for i from 0 to 3 - collect (not (string= "xyab" "ab" :start1 i :end1 nil))) + collect (not (string= "xyab" "ab" :start1 i :end1 nil))) (t t nil t)) (deftest string=.14 (loop for i from 0 to 3 - collect (not (string= "ab" "xyab" :start2 i :end2 nil))) + collect (not (string= "ab" "xyab" :start2 i :end2 nil))) (t t nil t)) ;;; Keyword argument processing (deftest string-comparison.allow-other-keys.1 (loop for fn in '(string= string<= string>= string/= string< string> - string-equal string-not-greaterp string-not-lessp - string-not-equal string-lessp string-greaterp) - for expected in '(nil 0 nil 0 0 nil nil 0 nil 0 0 nil) - for result = (funcall fn "a" "b" :allow-other-keys t :foo nil) - unless (eql result expected) - collect (list fn expected result)) + string-equal string-not-greaterp string-not-lessp + string-not-equal string-lessp string-greaterp) + for expected in '(nil 0 nil 0 0 nil nil 0 nil 0 0 nil) + for result = (funcall fn "a" "b" :allow-other-keys t :foo nil) + unless (eql result expected) + collect (list fn expected result)) nil) (deftest string-comparison.allow-other-keys.2 (loop for fn in '(string= string<= string>= string/= string< string> - string-equal string-not-greaterp string-not-lessp - string-not-equal string-lessp string-greaterp) - for expected in '(nil nil 0 0 nil 0 nil nil 0 0 nil 0) - for result = (funcall fn "c" "b" :allow-other-keys t - :allow-other-keys nil :foo 1) - unless (eql result expected) - collect (list fn expected result)) + string-equal string-not-greaterp string-not-lessp + string-not-equal string-lessp string-greaterp) + for expected in '(nil nil 0 0 nil 0 nil nil 0 0 nil 0) + for result = (funcall fn "c" "b" :allow-other-keys t + :allow-other-keys nil :foo 1) + unless (eql result expected) + collect (list fn expected result)) nil) (deftest string-comparison.allow-other-keys.3 (loop for fn in '(string= string<= string>= string/= string< string> - string-equal string-not-greaterp string-not-lessp - string-not-equal string-lessp string-greaterp) - for expected in '(nil 0 nil 0 0 nil nil 0 nil 0 0 nil) - for result = (funcall fn "a" "b" :allow-other-keys nil) - unless (eql result expected) - collect (list fn expected result)) + string-equal string-not-greaterp string-not-lessp + string-not-equal string-lessp string-greaterp) + for expected in '(nil 0 nil 0 0 nil nil 0 nil 0 0 nil) + for result = (funcall fn "a" "b" :allow-other-keys nil) + unless (eql result expected) + collect (list fn expected result)) nil) @@ -117,7 +117,7 @@ (let ((i 0) x y) (values (string= (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abd")) + (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) @@ -125,12 +125,12 @@ (let ((i 0) a b c d e f) (values (string= (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -138,12 +138,12 @@ (let ((i 0) a b c d e f) (values (string= (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -151,7 +151,7 @@ (let ((i 0) x y) (values (string<= (progn (setf x (incf i)) "abf") - (progn (setf y (incf i)) "abd")) + (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) @@ -159,12 +159,12 @@ (let ((i 0) a b c d e f) (values (string<= (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -172,12 +172,12 @@ (let ((i 0) a b c d e f) (values (string<= (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -185,7 +185,7 @@ (let ((i 0) x y) (values (string< (progn (setf x (incf i)) "abf") - (progn (setf y (incf i)) "abd")) + (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) @@ -193,12 +193,12 @@ (let ((i 0) a b c d e f) (values (string< (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -206,12 +206,12 @@ (let ((i 0) a b c d e f) (values (string< (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -220,7 +220,7 @@ (let ((i 0) x y) (values (string/= (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abc")) + (progn (setf y (incf i)) "abc")) i x y)) nil 2 1 2) @@ -228,12 +228,12 @@ (let ((i 0) a b c d e f) (values (string/= (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abc") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) + (progn (setf b (incf i)) "abc") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -241,12 +241,12 @@ (let ((i 0) a b c d e f) (values (string/= (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abc") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) + (progn (setf b (incf i)) "abc") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -254,7 +254,7 @@ (let ((i 0) x y) (values (string<= (progn (setf x (incf i)) "abf") - (progn (setf y (incf i)) "abd")) + (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) @@ -262,12 +262,12 @@ (let ((i 0) a b c d e f) (values (string>= (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -275,12 +275,12 @@ (let ((i 0) a b c d e f) (values (string>= (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -288,7 +288,7 @@ (let ((i 0) x y) (values (string> (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abd")) + (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) @@ -296,12 +296,12 @@ (let ((i 0) a b c d e f) (values (string> (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -309,12 +309,12 @@ (let ((i 0) a b c d e f) (values (string> (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -323,7 +323,7 @@ (let ((i 0) x y) (values (string-equal (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abd")) + (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) @@ -331,12 +331,12 @@ (let ((i 0) a b c d e f) (values (string-equal (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -344,12 +344,12 @@ (let ((i 0) a b c d e f) (values (string-equal (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -357,7 +357,7 @@ (let ((i 0) x y) (values (string-not-greaterp (progn (setf x (incf i)) "abf") - (progn (setf y (incf i)) "abd")) + (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) @@ -365,12 +365,12 @@ (let ((i 0) a b c d e f) (values (string-not-greaterp (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -378,12 +378,12 @@ (let ((i 0) a b c d e f) (values (string-not-greaterp (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -391,7 +391,7 @@ (let ((i 0) x y) (values (string-lessp (progn (setf x (incf i)) "abf") - (progn (setf y (incf i)) "abd")) + (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) @@ -399,12 +399,12 @@ (let ((i 0) a b c d e f) (values (string-lessp (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -412,12 +412,12 @@ (let ((i 0) a b c d e f) (values (string-lessp (progn (setf a (incf i)) "abf") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -426,7 +426,7 @@ (let ((i 0) x y) (values (string-not-equal (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abc")) + (progn (setf y (incf i)) "abc")) i x y)) nil 2 1 2) @@ -434,12 +434,12 @@ (let ((i 0) a b c d e f) (values (string-not-equal (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abc") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) + (progn (setf b (incf i)) "abc") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -447,12 +447,12 @@ (let ((i 0) a b c d e f) (values (string-not-equal (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abc") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) + (progn (setf b (incf i)) "abc") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -460,7 +460,7 @@ (let ((i 0) x y) (values (string-not-lessp (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abd")) + (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) @@ -468,12 +468,12 @@ (let ((i 0) a b c d e f) (values (string-not-lessp (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -481,12 +481,12 @@ (let ((i 0) a b c d e f) (values (string-not-lessp (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -494,7 +494,7 @@ (let ((i 0) x y) (values (string-greaterp (progn (setf x (incf i)) "abc") - (progn (setf y (incf i)) "abd")) + (progn (setf y (incf i)) "abd")) i x y)) nil 2 1 2) @@ -502,12 +502,12 @@ (let ((i 0) a b c d e f) (values (string-greaterp (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :start1 (progn (setf c (incf i)) 0) - :start2 (progn (setf d (incf i)) 0) - :end1 (progn (setf e (incf i)) nil) - :end2 (progn (setf f (incf i)) nil) - ) + (progn (setf b (incf i)) "abd") + :start1 (progn (setf c (incf i)) 0) + :start2 (progn (setf d (incf i)) 0) + :end1 (progn (setf e (incf i)) nil) + :end2 (progn (setf f (incf i)) nil) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -515,12 +515,12 @@ (let ((i 0) a b c d e f) (values (string-greaterp (progn (setf a (incf i)) "abc") - (progn (setf b (incf i)) "abd") - :end2 (progn (setf c (incf i)) nil) - :end1 (progn (setf d (incf i)) nil) - :start2 (progn (setf e (incf i)) 0) - :start1 (progn (setf f (incf i)) 0) - ) + (progn (setf b (incf i)) "abd") + :end2 (progn (setf c (incf i)) nil) + :end1 (progn (setf d (incf i)) nil) + :start2 (progn (setf e (incf i)) 0) + :start1 (progn (setf f (incf i)) 0) + ) i a b c d e f)) nil 6 1 2 3 4 5 6) @@ -529,11 +529,11 @@ (deftest random-string-comparison-tests (loop for cmp in '(= /= < > <= >=) - append - (loop for case in '(nil t) - collect - (list cmp case - (random-string-compare-test 10 cmp case 1000)))) + append + (loop for case in '(nil t) + collect + (list cmp case + (random-string-compare-test 10 cmp case 1000)))) ((= nil 0) (= t 0) (/= nil 0) (/= t 0) (< nil 0) (< t 0) (> nil 0) (> t 0) (<= nil 0) (<= t 0) (>= nil 0) (>= t 0))) @@ -719,8 +719,8 @@ (deftest string=.error.6 (signals-error (string= "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) + :allow-other-keys t :foo 'bar) + program-error) t) (deftest string/=.error.1 @@ -745,8 +745,8 @@ (deftest string/=.error.6 (signals-error (string/= "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) + :allow-other-keys t :foo 'bar) + program-error) t) @@ -772,8 +772,8 @@ (deftest string<.error.6 (signals-error (string< "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) + :allow-other-keys t :foo 'bar) + program-error) t) @@ -799,8 +799,8 @@ (deftest string<=.error.6 (signals-error (string<= "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) + :allow-other-keys t :foo 'bar) + program-error) t) @@ -826,8 +826,8 @@ (deftest string>.error.6 (signals-error (string> "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) + :allow-other-keys t :foo 'bar) + program-error) t) @@ -853,8 +853,8 @@ (deftest string>=.error.6 (signals-error (string>= "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) + :allow-other-keys t :foo 'bar) + program-error) t) @@ -880,8 +880,8 @@ (deftest string-equal.error.6 (signals-error (string-equal "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) + :allow-other-keys t :foo 'bar) + program-error) t) (deftest string-not-equal.error.1 @@ -906,8 +906,8 @@ (deftest string-not-equal.error.6 (signals-error (string-not-equal "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) + :allow-other-keys t :foo 'bar) + program-error) t) (deftest string-lessp.error.1 @@ -932,8 +932,8 @@ (deftest string-lessp.error.6 (signals-error (string-lessp "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) + :allow-other-keys t :foo 'bar) + program-error) t) (deftest string-greaterp.error.1 @@ -958,8 +958,8 @@ (deftest string-greaterp.error.6 (signals-error (string-greaterp "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) + :allow-other-keys t :foo 'bar) + program-error) t) (deftest string-not-lessp.error.1 @@ -984,8 +984,8 @@ (deftest string-not-lessp.error.6 (signals-error (string-not-lessp "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) + :allow-other-keys t :foo 'bar) + program-error) t) (deftest string-not-greaterp.error.1 @@ -1010,6 +1010,6 @@ (deftest string-not-greaterp.error.6 (signals-error (string-not-greaterp "a" "b" :allow-other-keys nil - :allow-other-keys t :foo 'bar) - program-error) + :allow-other-keys t :foo 'bar) + program-error) t) diff --git a/ansi-tests/string-downcase.lsp b/ansi-tests/string-downcase.lsp index 193471ca..141879df 100644 --- a/ansi-tests/string-downcase.lsp +++ b/ansi-tests/string-downcase.lsp @@ -33,14 +33,14 @@ (deftest string-downcase.6 (let ((s (make-array 6 :element-type 'character - :initial-contents '(#\A #\B #\C #\D #\E #\F)))) + :initial-contents '(#\A #\B #\C #\D #\E #\F)))) (values (string-downcase s) s)) "abcdef" "ABCDEF") (deftest string-downcase.7 (let ((s (make-array 6 :element-type 'standard-char - :initial-contents '(#\A #\B #\7 #\D #\E #\F)))) + :initial-contents '(#\A #\B #\7 #\D #\E #\F)))) (values (string-downcase s) s)) "ab7def" "AB7DEF") @@ -51,7 +51,7 @@ (let ((s "ABCDEF")) (values (loop for i from 0 to 6 - collect (string-downcase s :start i)) + collect (string-downcase s :start i)) s)) ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") "ABCDEF") @@ -60,7 +60,7 @@ (let ((s "ABCDEF")) (values (loop for i from 0 to 6 - collect (string-downcase s :start i :end nil)) + collect (string-downcase s :start i :end nil)) s)) ("abcdef" "Abcdef" "ABcdef" "ABCdef" "ABCDef" "ABCDEf" "ABCDEF") "ABCDEF") @@ -69,9 +69,9 @@ (let ((s "ABCDE")) (values (loop for i from 0 to 4 - collect (loop for j from i to 5 - collect (string-invertcase - (string-downcase s :start i :end j)))) + collect (loop for j from i to 5 + collect (string-invertcase + (string-downcase s :start i :end j)))) s)) (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") @@ -87,29 +87,29 @@ (deftest string-downcase.12 (loop for type in '(standard-char base-char character) - for s = (make-array '(10) :element-type type - :fill-pointer 5 - :initial-contents "aB0cDefGHi") - collect (list s (string-downcase s))) + for s = (make-array '(10) :element-type type + :fill-pointer 5 + :initial-contents "aB0cDefGHi") + collect (list s (string-downcase s))) (("aB0cD" "ab0cd") ("aB0cD" "ab0cd") ("aB0cD" "ab0cd"))) (deftest string-downcase.13 (loop for type in '(standard-char base-char character) - for s0 = (make-array '(10) :element-type type - :initial-contents "zZaB0cDefG") - for s = (make-array '(5) :element-type type - :displaced-to s0 - :displaced-index-offset 2) - collect (list s (string-downcase s))) + for s0 = (make-array '(10) :element-type type + :initial-contents "zZaB0cDefG") + for s = (make-array '(5) :element-type type + :displaced-to s0 + :displaced-index-offset 2) + collect (list s (string-downcase s))) (("aB0cD" "ab0cd") ("aB0cD" "ab0cd") ("aB0cD" "ab0cd"))) (deftest string-downcase.14 (loop for type in '(standard-char base-char character) - for s = (make-array '(5) :element-type type - :adjustable t - :initial-contents "aB0cD") - collect (list s (string-downcase s))) + for s = (make-array '(5) :element-type type + :adjustable t + :initial-contents "aB0cD") + collect (list s (string-downcase s))) (("aB0cD" "ab0cd") ("aB0cD" "ab0cd") ("aB0cD" "ab0cd"))) ;;; Order of evaluation tests @@ -152,7 +152,7 @@ (deftest string-downcase.error.4 (signals-error (string-downcase (copy-seq "abc") :bad t - :allow-other-keys nil) program-error) + :allow-other-keys nil) program-error) t) (deftest string-downcase.error.5 diff --git a/ansi-tests/string-left-trim.lsp b/ansi-tests/string-left-trim.lsp index a0368793..f80bb0cf 100644 --- a/ansi-tests/string-left-trim.lsp +++ b/ansi-tests/string-left-trim.lsp @@ -7,121 +7,121 @@ (deftest string-left-trim.1 (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim "ab" s))) + (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.2 (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim '(#\a #\b) s))) + (s2 (string-left-trim '(#\a #\b) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.3 (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim #(#\a #\b) s))) + (s2 (string-left-trim #(#\a #\b) s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.4 (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b)) - s))) + (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b)) + s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.5 (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'character) - s))) + (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'character) + s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.6 (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'standard-char) - s))) + (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'standard-char) + s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.7 (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'base-char) - s))) + (s2 (string-left-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'base-char) + s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.8 (let* ((s (copy-seq "abcdaba")) - (s2 (string-left-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) - :element-type 'character - :fill-pointer 2) - s))) + (s2 (string-left-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) + :element-type 'character + :fill-pointer 2) + s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.9 (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'character - )) - (s2 (string-left-trim "ab" s))) + :element-type 'character + )) + (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.10 (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'character - :fill-pointer 7)) - (s2 (string-left-trim "ab" s))) + :element-type 'character + :fill-pointer 7)) + (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.10a (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'base-char - :fill-pointer 7)) - (s2 (string-left-trim "ab" s))) + :element-type 'base-char + :fill-pointer 7)) + (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.10b (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'base-char - :adjustable t - :fill-pointer 7)) - (s2 (string-left-trim "ab" s))) + :element-type 'base-char + :adjustable t + :fill-pointer 7)) + (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.11 (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'standard-char - )) - (s2 (string-left-trim "ab" s))) + :element-type 'standard-char + )) + (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") (deftest string-left-trim.12 (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'base-char - )) - (s2 (string-left-trim "ab" s))) + :element-type 'base-char + )) + (s2 (string-left-trim "ab" s))) (values s s2)) "abcdaba" "cdaba") @@ -129,13 +129,13 @@ ;;; Test that trimming is case sensitive (deftest string-left-trim.13 (let* ((s (copy-seq "aA")) - (s2 (string-left-trim "a" s))) + (s2 (string-left-trim "a" s))) (values s s2)) "aA" "A") (deftest string-left-trim.14 (let* ((s '|abcdaba|) - (s2 (string-left-trim "ab" s))) + (s2 (string-left-trim "ab" s))) (values (symbol-name s) s2)) "abcdaba" "cdaba") @@ -172,35 +172,35 @@ (deftest string-left-trim.22 (let ((s (make-array '(6) :initial-contents "abcaeb" - :element-type 'base-char - :adjustable t))) + :element-type 'base-char + :adjustable t))) (values (string-left-trim "ab" s) s)) "caeb" "abcaeb") (deftest string-left-trim.23 (let ((s (make-array '(6) :initial-contents "abcaeb" - :element-type 'character - :adjustable t))) + :element-type 'character + :adjustable t))) (values (string-left-trim "ab" s) s)) "caeb" "abcaeb") (deftest string-left-trim.24 (let* ((etype 'base-char) - (s0 (make-array '(6) :initial-contents "abcaeb" - :element-type etype)) - (s (make-array '(3) :element-type etype - :displaced-to s0 - :displaced-index-offset 1))) + (s0 (make-array '(6) :initial-contents "abcaeb" + :element-type etype)) + (s (make-array '(3) :element-type etype + :displaced-to s0 + :displaced-index-offset 1))) (values (string-left-trim "ab" s) s s0)) "ca" "bca" "abcaeb") (deftest string-left-trim.25 (let* ((etype 'character) - (s0 (make-array '(6) :initial-contents "abcaeb" - :element-type etype)) - (s (make-array '(3) :element-type etype - :displaced-to s0 - :displaced-index-offset 1))) + (s0 (make-array '(6) :initial-contents "abcaeb" + :element-type etype)) + (s (make-array '(3) :element-type etype + :displaced-to s0 + :displaced-index-offset 1))) (values (string-left-trim "ab" s) s s0)) "ca" "bca" "abcaeb") @@ -209,8 +209,8 @@ (let ((i 0) x y) (values (string-left-trim (progn (setf x (incf i)) " ") - (progn (setf y (incf i)) - (copy-seq " abc d e f "))) + (progn (setf y (incf i)) + (copy-seq " abc d e f "))) i x y)) "abc d e f " 2 1 2) diff --git a/ansi-tests/string-right-trim.lsp b/ansi-tests/string-right-trim.lsp index 1706b78e..e3b11a23 100644 --- a/ansi-tests/string-right-trim.lsp +++ b/ansi-tests/string-right-trim.lsp @@ -7,121 +7,121 @@ (deftest string-right-trim.1 (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim "ab" s))) + (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.2 (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim '(#\a #\b) s))) + (s2 (string-right-trim '(#\a #\b) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.3 (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim #(#\a #\b) s))) + (s2 (string-right-trim #(#\a #\b) s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.4 (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b)) - s))) + (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b)) + s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.5 (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'character) - s))) + (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'character) + s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.6 (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'standard-char) - s))) + (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'standard-char) + s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.7 (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'base-char) - s))) + (s2 (string-right-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'base-char) + s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.8 (let* ((s (copy-seq "abcdaba")) - (s2 (string-right-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) - :element-type 'character - :fill-pointer 2) - s))) + (s2 (string-right-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) + :element-type 'character + :fill-pointer 2) + s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.9 (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'character - )) - (s2 (string-right-trim "ab" s))) + :element-type 'character + )) + (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.10 (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'character - :fill-pointer 7)) - (s2 (string-right-trim "ab" s))) + :element-type 'character + :fill-pointer 7)) + (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.10a (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'base-char - :fill-pointer 7)) - (s2 (string-right-trim "ab" s))) + :element-type 'base-char + :fill-pointer 7)) + (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.10b (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'base-char - :adjustable t - :fill-pointer 7)) - (s2 (string-right-trim "ab" s))) + :element-type 'base-char + :adjustable t + :fill-pointer 7)) + (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.11 (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'standard-char - )) - (s2 (string-right-trim "ab" s))) + :element-type 'standard-char + )) + (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") (deftest string-right-trim.12 (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'base-char - )) - (s2 (string-right-trim "ab" s))) + :element-type 'base-char + )) + (s2 (string-right-trim "ab" s))) (values s s2)) "abcdaba" "abcd") @@ -129,13 +129,13 @@ ;;; Test that trimming is case sensitive (deftest string-right-trim.13 (let* ((s (copy-seq "Aa")) - (s2 (string-right-trim "a" s))) + (s2 (string-right-trim "a" s))) (values s s2)) "Aa" "A") (deftest string-right-trim.14 (let* ((s '|abcdaba|) - (s2 (string-right-trim "ab" s))) + (s2 (string-right-trim "ab" s))) (values (symbol-name s) s2)) "abcdaba" "abcd") @@ -172,35 +172,35 @@ (deftest string-right-trim.22 (let ((s (make-array '(6) :initial-contents "abcaeb" - :element-type 'base-char - :adjustable t))) + :element-type 'base-char + :adjustable t))) (values (string-right-trim "ab" s) s)) "abcae" "abcaeb") (deftest string-right-trim.23 (let ((s (make-array '(6) :initial-contents "abcaeb" - :element-type 'character - :adjustable t))) + :element-type 'character + :adjustable t))) (values (string-right-trim "ab" s) s)) "abcae" "abcaeb") (deftest string-right-trim.24 (let* ((etype 'base-char) - (s0 (make-array '(6) :initial-contents "abcaeb" - :element-type etype)) - (s (make-array '(3) :element-type etype - :displaced-to s0 - :displaced-index-offset 1))) + (s0 (make-array '(6) :initial-contents "abcaeb" + :element-type etype)) + (s (make-array '(3) :element-type etype + :displaced-to s0 + :displaced-index-offset 1))) (values (string-right-trim "ab" s) s s0)) "bc" "bca" "abcaeb") (deftest string-right-trim.25 (let* ((etype 'character) - (s0 (make-array '(6) :initial-contents "abcaeb" - :element-type etype)) - (s (make-array '(3) :element-type etype - :displaced-to s0 - :displaced-index-offset 1))) + (s0 (make-array '(6) :initial-contents "abcaeb" + :element-type etype)) + (s (make-array '(3) :element-type etype + :displaced-to s0 + :displaced-index-offset 1))) (values (string-right-trim "ab" s) s s0)) "bc" "bca" "abcaeb") @@ -208,8 +208,8 @@ (let ((i 0) x y) (values (string-right-trim (progn (setf x (incf i)) " ") - (progn (setf y (incf i)) - (copy-seq " abc d e f "))) + (progn (setf y (incf i)) + (copy-seq " abc d e f "))) i x y)) " abc d e f" 2 1 2) diff --git a/ansi-tests/string-trim.lsp b/ansi-tests/string-trim.lsp index 3283f5f5..715935dc 100644 --- a/ansi-tests/string-trim.lsp +++ b/ansi-tests/string-trim.lsp @@ -7,122 +7,122 @@ (deftest string-trim.1 (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim "ab" s))) + (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.2 (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim '(#\a #\b) s))) + (s2 (string-trim '(#\a #\b) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.3 (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim #(#\a #\b) s))) + (s2 (string-trim #(#\a #\b) s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.4 (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b)) - s))) + (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b)) + s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.5 (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'character) - s))) + (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'character) + s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.6 (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'standard-char) - s))) + (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'standard-char) + s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.7 (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) - :element-type 'base-char) - s))) + (s2 (string-trim (make-array 2 :initial-contents '(#\a #\b) + :element-type 'base-char) + s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.8 (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) - :element-type 'character - :fill-pointer 2) - s))) + (s2 (string-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) + :element-type 'character + :fill-pointer 2) + s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.8a (let* ((s (copy-seq "abcdaba")) - (s2 (string-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) - :element-type 'base-char - :fill-pointer 2) - s))) + (s2 (string-trim (make-array 4 :initial-contents '(#\a #\b #\c #\d) + :element-type 'base-char + :fill-pointer 2) + s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.9 (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'character - )) - (s2 (string-trim "ab" s))) + :element-type 'character + )) + (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.10 (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'character - :fill-pointer 7)) - (s2 (string-trim "ab" s))) + :element-type 'character + :fill-pointer 7)) + (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.10a (let* ((s (make-array 9 :initial-contents "abcdabadd" - :element-type 'base-char - :adjustable t - :fill-pointer 7)) - (s2 (string-trim "ab" s))) + :element-type 'base-char + :adjustable t + :fill-pointer 7)) + (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.11 (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'standard-char - )) - (s2 (string-trim "ab" s))) + :element-type 'standard-char + )) + (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") (deftest string-trim.12 (let* ((s (make-array 7 :initial-contents "abcdaba" - :element-type 'base-char - )) - (s2 (string-trim "ab" s))) + :element-type 'base-char + )) + (s2 (string-trim "ab" s))) (values s s2)) "abcdaba" "cd") @@ -130,13 +130,13 @@ ;;; Test that trimming is case sensitive (deftest string-trim.13 (let* ((s (copy-seq "Aa")) - (s2 (string-trim "a" s))) + (s2 (string-trim "a" s))) (values s s2)) "Aa" "A") (deftest string-trim.14 (let* ((s '|abcdaba|) - (s2 (string-trim "ab" s))) + (s2 (string-trim "ab" s))) (values (symbol-name s) s2)) "abcdaba" "cd") @@ -173,35 +173,35 @@ (deftest string-trim.22 (let ((s (make-array '(6) :initial-contents "abcaeb" - :element-type 'base-char - :adjustable t))) + :element-type 'base-char + :adjustable t))) (values (string-trim "ab" s) s)) "cae" "abcaeb") (deftest string-trim.23 (let ((s (make-array '(6) :initial-contents "abcaeb" - :element-type 'character - :adjustable t))) + :element-type 'character + :adjustable t))) (values (string-trim "ab" s) s)) "cae" "abcaeb") (deftest string-trim.24 (let* ((etype 'base-char) - (s0 (make-array '(6) :initial-contents "abcaeb" - :element-type etype)) - (s (make-array '(3) :element-type etype - :displaced-to s0 - :displaced-index-offset 1))) + (s0 (make-array '(6) :initial-contents "abcaeb" + :element-type etype)) + (s (make-array '(3) :element-type etype + :displaced-to s0 + :displaced-index-offset 1))) (values (string-trim "ab" s) s s0)) "c" "bca" "abcaeb") (deftest string-trim.25 (let* ((etype 'character) - (s0 (make-array '(6) :initial-contents "abcaeb" - :element-type etype)) - (s (make-array '(3) :element-type etype - :displaced-to s0 - :displaced-index-offset 1))) + (s0 (make-array '(6) :initial-contents "abcaeb" + :element-type etype)) + (s (make-array '(3) :element-type etype + :displaced-to s0 + :displaced-index-offset 1))) (values (string-trim "ab" s) s s0)) "c" "bca" "abcaeb") @@ -209,8 +209,8 @@ (let ((i 0) x y) (values (string-trim (progn (setf x (incf i)) " ") - (progn (setf y (incf i)) - (copy-seq " abc d e f "))) + (progn (setf y (incf i)) + (copy-seq " abc d e f "))) i x y)) "abc d e f" 2 1 2) diff --git a/ansi-tests/string-upcase.lsp b/ansi-tests/string-upcase.lsp index 1ecbd2e5..ca109669 100644 --- a/ansi-tests/string-upcase.lsp +++ b/ansi-tests/string-upcase.lsp @@ -33,14 +33,14 @@ (deftest string-upcase.6 (let ((s (make-array 6 :element-type 'character - :initial-contents '(#\a #\b #\c #\d #\e #\f)))) + :initial-contents '(#\a #\b #\c #\d #\e #\f)))) (values (string-upcase s) s)) "ABCDEF" "abcdef") (deftest string-upcase.7 (let ((s (make-array 6 :element-type 'standard-char - :initial-contents '(#\a #\b #\7 #\d #\e #\f)))) + :initial-contents '(#\a #\b #\7 #\d #\e #\f)))) (values (string-upcase s) s)) "AB7DEF" "ab7def") @@ -51,7 +51,7 @@ (let ((s "abcdef")) (values (loop for i from 0 to 6 - collect (string-upcase s :start i)) + collect (string-upcase s :start i)) s)) ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef") "abcdef") @@ -60,8 +60,8 @@ (let ((s "abcdef")) (values (loop for i from 0 to 6 - collect - (string-upcase s :start i :end nil)) + collect + (string-upcase s :start i :end nil)) s)) ("ABCDEF" "aBCDEF" "abCDEF" "abcDEF" "abcdEF" "abcdeF" "abcdef") "abcdef") @@ -70,8 +70,8 @@ (let ((s "abcde")) (values (loop for i from 0 to 4 - collect (loop for j from i to 5 - collect (string-upcase s :start i :end j))) + collect (loop for j from i to 5 + collect (string-upcase s :start i :end j))) s)) (("abcde" "Abcde" "ABcde" "ABCde" "ABCDe" "ABCDE") ("abcde" "aBcde" "aBCde" "aBCDe" "aBCDE") @@ -87,29 +87,29 @@ (deftest string-upcase.12 (loop for type in '(standard-char base-char character) - for s = (make-array '(10) :element-type type - :fill-pointer 5 - :initial-contents "aB0cDefGHi") - collect (list s (string-upcase s))) + for s = (make-array '(10) :element-type type + :fill-pointer 5 + :initial-contents "aB0cDefGHi") + collect (list s (string-upcase s))) (("aB0cD" "AB0CD") ("aB0cD" "AB0CD") ("aB0cD" "AB0CD"))) (deftest string-upcase.13 (loop for type in '(standard-char base-char character) - for s0 = (make-array '(10) :element-type type - :initial-contents "zZaB0cDefG") - for s = (make-array '(5) :element-type type - :displaced-to s0 - :displaced-index-offset 2) - collect (list s (string-upcase s))) + for s0 = (make-array '(10) :element-type type + :initial-contents "zZaB0cDefG") + for s = (make-array '(5) :element-type type + :displaced-to s0 + :displaced-index-offset 2) + collect (list s (string-upcase s))) (("aB0cD" "AB0CD") ("aB0cD" "AB0CD") ("aB0cD" "AB0CD"))) (deftest string-upcase.14 (loop for type in '(standard-char base-char character) - for s = (make-array '(5) :element-type type - :adjustable t - :initial-contents "aB0cD") - collect (list s (string-upcase s))) + for s = (make-array '(5) :element-type type + :adjustable t + :initial-contents "aB0cD") + collect (list s (string-upcase s))) (("aB0cD" "AB0CD") ("aB0cD" "AB0CD") ("aB0cD" "AB0CD"))) ;;; Order of evaluation tests @@ -137,7 +137,7 @@ ;;; Const fold tests (def-fold-test string-upcase.fold.1 (string-upcase "abcde")) - + ;;; Error tests (deftest string-upcase.error.1 @@ -154,7 +154,7 @@ (deftest string-upcase.error.4 (signals-error (string-upcase (copy-seq "abc") :bad t - :allow-other-keys nil) program-error) + :allow-other-keys nil) program-error) t) (deftest string-upcase.error.5 diff --git a/ansi-tests/string.lsp b/ansi-tests/string.lsp index e8a33a2c..233eec76 100644 --- a/ansi-tests/string.lsp +++ b/ansi-tests/string.lsp @@ -36,10 +36,10 @@ (check-predicate #'(lambda (x) (handler-case (stringp (string x)) - (type-error () :caught)))) + (type-error () :caught)))) nil) -(deftest string.8 +(deftest string.8 :notes (:allow-nil-arrays :nil-vectors-are-strings) (subtypep* '(array nil (*)) 'string) t t) @@ -71,27 +71,27 @@ (deftest string.14 (let ((count 0)) (loop for i below (min char-code-limit 65536) - for c = (code-char i) - for s = (and c (string c)) - when (and c - (or (not (stringp s)) - (not (= (length s) 1)) - (not (eql c (char s 0))))) - collect (progn (incf count) (list i c s)) - until (>= count 100))) + for c = (code-char i) + for s = (and c (string c)) + when (and c + (or (not (stringp s)) + (not (= (length s) 1)) + (not (eql c (char s 0))))) + collect (progn (incf count) (list i c s)) + until (>= count 100))) nil) (deftest string.15 (when (> char-code-limit 65536) (loop for i = (random char-code-limit) - for c = (code-char i) - for s = (and c (string c)) - repeat 2000 - when (and c - (or (not (stringp s)) - (not (= (length s) 1)) - (not (eql c (char s 0))))) - collect (list i c s))) + for c = (code-char i) + for s = (and c (string c)) + repeat 2000 + when (and c + (or (not (stringp s)) + (not (= (length s) 1)) + (not (eql c (char s 0))))) + collect (list i c s))) nil) (deftest string.16 @@ -121,19 +121,19 @@ (deftest string.22 (do-special-strings (s "X") (assert (typep s 'string))) nil) - + (deftest string.23 (do-special-strings (s "X") (assert (typep s '(string)))) nil) - + (deftest string.24 (do-special-strings (s "X") (assert (typep s '(string *)))) nil) - + (deftest string.25 (do-special-strings (s "X") - (or (array-has-fill-pointer-p s) - (assert (typep s '(string 1))))) + (or (array-has-fill-pointer-p s) + (assert (typep s '(string 1))))) nil) (deftest string.26 diff --git a/ansi-tests/stringp.lsp b/ansi-tests/stringp.lsp index f892ea21..0bc60791 100644 --- a/ansi-tests/stringp.lsp +++ b/ansi-tests/stringp.lsp @@ -15,17 +15,17 @@ (deftest stringp.3 (notnot (stringp (make-array 4 :element-type 'character - :initial-contents '(#\a #\b #\c #\d)))) + :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.4 (notnot (stringp (make-array 4 :element-type 'base-char - :initial-contents '(#\a #\b #\c #\d)))) + :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.5 (notnot (stringp (make-array 4 :element-type 'standard-char - :initial-contents '(#\a #\b #\c #\d)))) + :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.6 @@ -38,10 +38,10 @@ (deftest stringp.8 (let* ((s (make-array 10 :element-type 'character - :initial-element #\a)) - (s2 (make-array 4 :element-type 'character - :displaced-to s - :displaced-index-offset 2))) + :initial-element #\a)) + (s2 (make-array 4 :element-type 'character + :displaced-to s + :displaced-index-offset 2))) (notnot (stringp s2))) t) @@ -57,26 +57,26 @@ (deftest stringp.11 (notnot (stringp (make-array 4 :element-type 'base-char - :fill-pointer 2 - :initial-contents '(#\a #\b #\c #\d)))) + :fill-pointer 2 + :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.12 (notnot (stringp (make-array 4 :element-type 'base-char - :adjustable t - :initial-contents '(#\a #\b #\c #\d)))) + :adjustable t + :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.13 (notnot (stringp (make-array 4 :element-type 'character - :fill-pointer 2 - :initial-contents '(#\a #\b #\c #\d)))) + :fill-pointer 2 + :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.14 (notnot (stringp (make-array 4 :element-type 'character - :adjustable t - :initial-contents '(#\a #\b #\c #\d)))) + :adjustable t + :initial-contents '(#\a #\b #\c #\d)))) t) (deftest stringp.15 diff --git a/ansi-tests/structure-00.lsp b/ansi-tests/structure-00.lsp index f85f0fb9..b0b26ac0 100644 --- a/ansi-tests/structure-00.lsp +++ b/ansi-tests/structure-00.lsp @@ -13,23 +13,23 @@ ;; (assert (typep n 'fixnum)) (setf structure-name (string structure-name)) (intern (concatenate 'string - structure-name - "/" - (princ-to-string n)))) + structure-name + "/" + (princ-to-string n)))) (defun make-struct-p-fn (structure-name) (assert (typep structure-name '(or string symbol character))) (setf structure-name (string structure-name)) (intern (concatenate 'string - structure-name - (string '#:-p)))) + structure-name + (string '#:-p)))) (defun make-struct-copy-fn (structure-name) (assert (typep structure-name '(or string symbol character))) (setf structure-name (string structure-name)) (intern (concatenate 'string - (string '#:copy-) - structure-name))) + (string '#:copy-) + structure-name))) (defun make-struct-field-fn (conc-name field-name) "Make field accessor for a field in a structure" @@ -47,7 +47,7 @@ (assert (typep structure-name '(or string symbol character))) (setf structure-name (string structure-name)) (intern (concatenate 'string - (string '#:make-) structure-name))) + (string '#:make-) structure-name))) (defun create-instance-of-type (type) "Return an instance of a type. Signal an error if @@ -67,44 +67,44 @@ ((eqt type 'bignum) (let ((x 1)) (loop until (typep x 'bignum) - do (setq x (* 2 x))) + do (setq x (* 2 x))) x)) ((and (symbolp type) - (typep type 'structure-class)) + (typep type 'structure-class)) (let ((make-fn - (intern (concatenate 'string (string '#:make-) (symbol-name type)) - (symbol-package type)))) + (intern (concatenate 'string (string '#:make-) (symbol-name type)) + (symbol-package type)))) (eval (list make-fn)))) ((eqt type 'character) #\w) ((eqt type 'base-char) #\z) ((member type '(integer unsigned-byte signed-byte)) 35) ((eqt type 'bit) 1) ((and (consp type) - (consp (cdr type)) - (consp (cddr type)) - (null (cdddr type)) - (eqt (car type) 'integer) - (integerp (second type))) + (consp (cdr type)) + (consp (cddr type)) + (null (cdddr type)) + (eqt (car type) 'integer) + (integerp (second type))) (second type)) ((member type '(float single-float long-float double-float short-float)) 0.0) ((and (consp type) - (eqt (car type) 'member) - (consp (cdr type))) + (eqt (car type) 'member) + (consp (cdr type))) (second type)) ((and (consp type) - (eqt (car type) 'or) - (consp (second type))) + (eqt (car type) 'or) + (consp (second type))) (create-instance-of-type (second type))) (t (error "Cannot generate element for type ~S~%" type)))) (defun find-option (option-list option &optional default) (loop for opt in option-list - when (or (eq opt option) - (and (consp opt) - (eq (car opt) option))) - return opt - finally (return default))) + when (or (eq opt option) + (and (consp opt) + (eq (car opt) option))) + return opt + finally (return default))) (defvar *defstruct-with-tests-names* nil "Names of structure types defined with DEFSRUCT-WITH-TESTS.") @@ -148,411 +148,411 @@ do the defstruct." slot-descriptions-and-documentation)) (defun defstruct-with-tests-fun (name-and-options - slot-descriptions-and-documentation) + slot-descriptions-and-documentation) ;; Function called from macro defstruct-with-tests (let* ( - ;; Either NIL or the documentation string for the structure - (doc-string - (when (and (consp slot-descriptions-and-documentation) - (stringp (car slot-descriptions-and-documentation))) - (car slot-descriptions-and-documentation))) - - ;; The list of slot descriptions that follows either the - ;; name and options or the doc string - (slot-descriptions - (if doc-string (cdr slot-descriptions-and-documentation) - slot-descriptions-and-documentation)) - - ;; The name of the structure (should be a symbol) - (name (if (consp name-and-options) - (car name-and-options) - name-and-options)) - - ;; The options list, or NIL if there were no options - (options (if (consp name-and-options) - (cdr name-and-options) - nil)) - - ;; List of symbols that are the names of the slots - (slot-names - (loop - for x in slot-descriptions collect - (if (consp x) (car x) x))) - - ;; List of slot types, if any - (slot-types - (loop - for x in slot-descriptions collect - (if (consp x) - (getf (cddr x) :type :none) - :none))) - - ;; read-only flags for slots - (slot-read-only - (loop - for x in slot-descriptions collect - (and (consp x) - (getf (cddr x) :read-only)))) - - ;; Symbol obtained by prepending MAKE- to the name symbol - (make-fn (make-struct-make-fn name)) - - ;; The type option, if specified - (type-option (find-option options :type)) - (struct-type (second type-option)) - - (named-option (find-option options :named)) - (include-option (find-option options :include)) - - ;; The :predicate option entry from OPTIONS, or NIL if none - (predicate-option (find-option options :predicate)) - - ;; The name of the -P function, either the default or the - ;; one specified in the :predicate option - (p-fn-default (make-struct-p-fn name)) - (p-fn (cond - ((and type-option (not named-option)) nil) - ((or (eq predicate-option :predicate) - (null (cdr predicate-option))) - p-fn-default) - ((cadr predicate-option) (cadr predicate-option)) - (t nil))) - - ;; The :copier option, or NIL if no such option specified - (copier-option (find-option options :copier)) - ;; The name of the copier function, either the default or - ;; one speciefied in the :copier option - (copy-fn-default (make-struct-copy-fn name)) - (copy-fn (cond - ((or (eq copier-option :copier) - (null (cdr copier-option))) - copy-fn-default) - ((cadr copier-option) (cadr copier-option)) - (t nil))) - - ;; The :conc-name option, or NIL if none specified - (conc-option (find-option options :conc-name)) - ;; String to be prepended to slot names to get the - ;; slot accessor function - (conc-prefix-default (concatenate 'string (string name) "-")) - (conc-prefix (cond - ((null conc-option) - conc-prefix-default) - ((or (eq conc-option :conc-name) - (null (cadr conc-option))) - nil) - (t (string (cadr conc-option))))) - - (initial-offset-option (find-option options :initial-offset)) - (initial-offset (second initial-offset-option)) - - ;; Accessor names - (field-fns - (loop for slot-name in slot-names - collect (make-struct-field-fn conc-prefix slot-name))) - - ;; a list of initial values - (initial-value-alist - (loop - for slot-desc in slot-descriptions - for slot-name in slot-names - for type in slot-types - for i from 1 - collect (if (not (eq type :none)) - (cons slot-name (create-instance-of-type type)) - (cons slot-name (defstruct-maketemp name "SLOTTEMP" i))))) - ) + ;; Either NIL or the documentation string for the structure + (doc-string + (when (and (consp slot-descriptions-and-documentation) + (stringp (car slot-descriptions-and-documentation))) + (car slot-descriptions-and-documentation))) + + ;; The list of slot descriptions that follows either the + ;; name and options or the doc string + (slot-descriptions + (if doc-string (cdr slot-descriptions-and-documentation) + slot-descriptions-and-documentation)) + + ;; The name of the structure (should be a symbol) + (name (if (consp name-and-options) + (car name-and-options) + name-and-options)) + + ;; The options list, or NIL if there were no options + (options (if (consp name-and-options) + (cdr name-and-options) + nil)) + + ;; List of symbols that are the names of the slots + (slot-names + (loop + for x in slot-descriptions collect + (if (consp x) (car x) x))) + + ;; List of slot types, if any + (slot-types + (loop + for x in slot-descriptions collect + (if (consp x) + (getf (cddr x) :type :none) + :none))) + + ;; read-only flags for slots + (slot-read-only + (loop + for x in slot-descriptions collect + (and (consp x) + (getf (cddr x) :read-only)))) + + ;; Symbol obtained by prepending MAKE- to the name symbol + (make-fn (make-struct-make-fn name)) + + ;; The type option, if specified + (type-option (find-option options :type)) + (struct-type (second type-option)) + + (named-option (find-option options :named)) + (include-option (find-option options :include)) + + ;; The :predicate option entry from OPTIONS, or NIL if none + (predicate-option (find-option options :predicate)) + + ;; The name of the -P function, either the default or the + ;; one specified in the :predicate option + (p-fn-default (make-struct-p-fn name)) + (p-fn (cond + ((and type-option (not named-option)) nil) + ((or (eq predicate-option :predicate) + (null (cdr predicate-option))) + p-fn-default) + ((cadr predicate-option) (cadr predicate-option)) + (t nil))) + + ;; The :copier option, or NIL if no such option specified + (copier-option (find-option options :copier)) + ;; The name of the copier function, either the default or + ;; one speciefied in the :copier option + (copy-fn-default (make-struct-copy-fn name)) + (copy-fn (cond + ((or (eq copier-option :copier) + (null (cdr copier-option))) + copy-fn-default) + ((cadr copier-option) (cadr copier-option)) + (t nil))) + + ;; The :conc-name option, or NIL if none specified + (conc-option (find-option options :conc-name)) + ;; String to be prepended to slot names to get the + ;; slot accessor function + (conc-prefix-default (concatenate 'string (string name) "-")) + (conc-prefix (cond + ((null conc-option) + conc-prefix-default) + ((or (eq conc-option :conc-name) + (null (cadr conc-option))) + nil) + (t (string (cadr conc-option))))) + + (initial-offset-option (find-option options :initial-offset)) + (initial-offset (second initial-offset-option)) + + ;; Accessor names + (field-fns + (loop for slot-name in slot-names + collect (make-struct-field-fn conc-prefix slot-name))) + + ;; a list of initial values + (initial-value-alist + (loop + for slot-desc in slot-descriptions + for slot-name in slot-names + for type in slot-types + for i from 1 + collect (if (not (eq type :none)) + (cons slot-name (create-instance-of-type type)) + (cons slot-name (defstruct-maketemp name "SLOTTEMP" i))))) + ) (declare (ignorable initial-offset)) ;; Build the tests in an eval-when form `(eval-when (:load-toplevel :compile-toplevel :execute) (report-and-ignore-errors - (eval '(defstruct ,name-and-options - ,@slot-descriptions-and-documentation)) - ,(unless (or type-option include-option) - `(pushnew ',name *defstruct-with-tests-names*)) - nil) + (eval '(defstruct ,name-and-options + ,@slot-descriptions-and-documentation)) + ,(unless (or type-option include-option) + `(pushnew ',name *defstruct-with-tests-names*)) + nil) ;; Test that structure is of the correct type (deftest ,(make-struct-test-name name 1) - (and (fboundp (quote ,make-fn)) - (functionp (function ,make-fn)) - (symbol-function (quote ,make-fn)) - (typep (,make-fn) (quote ,(if type-option struct-type - name))) - t) - t) + (and (fboundp (quote ,make-fn)) + (functionp (function ,make-fn)) + (symbol-function (quote ,make-fn)) + (typep (,make-fn) (quote ,(if type-option struct-type + name))) + t) + t) ;; Test that the predicate exists ,@(when p-fn - `((deftest ,(make-struct-test-name name 2) - (let ((s (,make-fn))) - (and (fboundp (quote ,p-fn)) - (functionp (function ,p-fn)) - (symbol-function (quote ,p-fn)) - (notnot (funcall #',p-fn s)) - (notnot-mv (,p-fn s)) - )) - t) - (deftest ,(make-struct-test-name name "ERROR.1") - (signals-error (,p-fn) program-error) - t) - (deftest ,(make-struct-test-name name "ERROR.2") - (signals-error (,p-fn (,make-fn) nil) program-error) - t) - )) + `((deftest ,(make-struct-test-name name 2) + (let ((s (,make-fn))) + (and (fboundp (quote ,p-fn)) + (functionp (function ,p-fn)) + (symbol-function (quote ,p-fn)) + (notnot (funcall #',p-fn s)) + (notnot-mv (,p-fn s)) + )) + t) + (deftest ,(make-struct-test-name name "ERROR.1") + (signals-error (,p-fn) program-error) + t) + (deftest ,(make-struct-test-name name "ERROR.2") + (signals-error (,p-fn (,make-fn) nil) program-error) + t) + )) ;; Test that the elements of *universe* are not ;; of this type ,@(when p-fn - `((deftest ,(make-struct-test-name name 3) - (count-if (function ,p-fn) *universe*) - 0))) + `((deftest ,(make-struct-test-name name 3) + (count-if (function ,p-fn) *universe*) + 0))) ,@(unless type-option - `((deftest ,(make-struct-test-name name 4) - (count-if (function (lambda (x) (typep x (quote ,name)))) - *universe*) - 0))) + `((deftest ,(make-struct-test-name name 4) + (count-if (function (lambda (x) (typep x (quote ,name)))) + *universe*) + 0))) ;; Check that the fields can be read after being initialized (deftest ,(make-struct-test-name name 5) - ,(let ((inits nil) - (tests nil) - (var (defstruct-maketemp name "TEMP-5"))) - (loop - for (slot-name . initval) in initial-value-alist - for field-fn in field-fns - do - (setf inits - (list* (intern (string slot-name) "KEYWORD") - (list 'quote initval) - inits)) - (push `(and - (eqlt (quote ,initval) - (,field-fn ,var)) - (eqlt (quote ,initval) - (funcall #',field-fn ,var))) - tests)) - `(let ((,var (,make-fn . ,inits))) - (and ,@tests t))) - t) + ,(let ((inits nil) + (tests nil) + (var (defstruct-maketemp name "TEMP-5"))) + (loop + for (slot-name . initval) in initial-value-alist + for field-fn in field-fns + do + (setf inits + (list* (intern (string slot-name) "KEYWORD") + (list 'quote initval) + inits)) + (push `(and + (eqlt (quote ,initval) + (,field-fn ,var)) + (eqlt (quote ,initval) + (funcall #',field-fn ,var))) + tests)) + `(let ((,var (,make-fn . ,inits))) + (and ,@tests t))) + t) (deftest ,(make-struct-test-name name "ERROR.3") - (remove nil - (list - ,@(loop - for (slot-name . initval) in initial-value-alist - for field-fn in field-fns - collect - `(multiple-value-bind - (x val) - (signals-error (,field-fn) program-error) - (unless x - (list ',slot-name ',field-fn val)))))) - nil) + (remove nil + (list + ,@(loop + for (slot-name . initval) in initial-value-alist + for field-fn in field-fns + collect + `(multiple-value-bind + (x val) + (signals-error (,field-fn) program-error) + (unless x + (list ',slot-name ',field-fn val)))))) + nil) (deftest ,(make-struct-test-name name "ERROR.4") - (remove nil - (list - ,@(loop - for (slot-name . initval) in initial-value-alist - for field-fn in field-fns - collect - `(multiple-value-bind - (x val) - (signals-error (,field-fn (,make-fn) nil) - program-error) - (unless x - (list ',slot-name ',field-fn val)))))) - nil) + (remove nil + (list + ,@(loop + for (slot-name . initval) in initial-value-alist + for field-fn in field-fns + collect + `(multiple-value-bind + (x val) + (signals-error (,field-fn (,make-fn) nil) + program-error) + (unless x + (list ',slot-name ',field-fn val)))))) + nil) ;; Check that two invocations return different structures (deftest ,(make-struct-test-name name 6) - (eqt (,make-fn) (,make-fn)) - nil) + (eqt (,make-fn) (,make-fn)) + nil) ;; Check that we can setf the fields (deftest ,(make-struct-test-name name 7) - ,(let* ((var (defstruct-maketemp name "TEMP-7-1")) - (var2 (defstruct-maketemp name "TEMP-7-2")) - (tests - (loop - for (slot-name . initval) in initial-value-alist - for read-only-p in slot-read-only - for slot-desc in slot-descriptions - for field-fn in field-fns - unless read-only-p - collect - `(let ((,var2 (quote ,initval))) - (setf (,field-fn ,var) ,var2) - (eqlt (,field-fn ,var) ,var2))))) - `(let ((,var (,make-fn))) - (and ,@tests t))) - t) + ,(let* ((var (defstruct-maketemp name "TEMP-7-1")) + (var2 (defstruct-maketemp name "TEMP-7-2")) + (tests + (loop + for (slot-name . initval) in initial-value-alist + for read-only-p in slot-read-only + for slot-desc in slot-descriptions + for field-fn in field-fns + unless read-only-p + collect + `(let ((,var2 (quote ,initval))) + (setf (,field-fn ,var) ,var2) + (eqlt (,field-fn ,var) ,var2))))) + `(let ((,var (,make-fn))) + (and ,@tests t))) + t) ;; Check that the copy function exists ,@(when copy-fn - `((deftest ,(make-struct-test-name name 8) - (and (fboundp (quote ,copy-fn)) - (functionp (function ,copy-fn)) - (symbol-function (quote ,copy-fn)) - t) - t) - (deftest ,(make-struct-test-name name "ERROR.5") - (signals-error (,copy-fn) program-error) - t) - (deftest ,(make-struct-test-name name "ERROR.6") - (signals-error (,copy-fn (,make-fn) nil) program-error) - t) - )) + `((deftest ,(make-struct-test-name name 8) + (and (fboundp (quote ,copy-fn)) + (functionp (function ,copy-fn)) + (symbol-function (quote ,copy-fn)) + t) + t) + (deftest ,(make-struct-test-name name "ERROR.5") + (signals-error (,copy-fn) program-error) + t) + (deftest ,(make-struct-test-name name "ERROR.6") + (signals-error (,copy-fn (,make-fn) nil) program-error) + t) + )) ;; Check that the copy function properly copies fields ,@(when copy-fn - `((deftest ,(make-struct-test-name name 9) - ,(let* ((var 'XTEMP-9) - (var2 'YTEMP-9) - (var3 'ZTEMP-9)) - `(let ((,var (,make-fn - ,@(loop - for (slot-name . initval) - in initial-value-alist - nconc (list (intern (string slot-name) - "KEYWORD") - `(quote ,initval)))))) - (let ((,var2 (,copy-fn ,var)) - (,var3 (funcall #',copy-fn ,var))) - (and - (not (eqlt ,var ,var2)) - (not (eqlt ,var ,var3)) - (not (eqlt ,var2 ,var3)) - ,@(loop - for (slot-name . nil) in initial-value-alist - for fn in field-fns - collect - `(and (eqlt (,fn ,var) (,fn ,var2)) - (eqlt (,fn ,var) (,fn ,var3)))) - t)))) - t))) + `((deftest ,(make-struct-test-name name 9) + ,(let* ((var 'XTEMP-9) + (var2 'YTEMP-9) + (var3 'ZTEMP-9)) + `(let ((,var (,make-fn + ,@(loop + for (slot-name . initval) + in initial-value-alist + nconc (list (intern (string slot-name) + "KEYWORD") + `(quote ,initval)))))) + (let ((,var2 (,copy-fn ,var)) + (,var3 (funcall #',copy-fn ,var))) + (and + (not (eqlt ,var ,var2)) + (not (eqlt ,var ,var3)) + (not (eqlt ,var2 ,var3)) + ,@(loop + for (slot-name . nil) in initial-value-alist + for fn in field-fns + collect + `(and (eqlt (,fn ,var) (,fn ,var2)) + (eqlt (,fn ,var) (,fn ,var3)))) + t)))) + t))) ;; When the predicate is not the default, check ;; that the default is not defined. Tests should ;; be designed so that this function name doesn't ;; collide with anything else. ,@(unless (eq p-fn p-fn-default) - `((deftest ,(make-struct-test-name name 10) - (fboundp (quote ,p-fn-default)) - nil))) + `((deftest ,(make-struct-test-name name 10) + (fboundp (quote ,p-fn-default)) + nil))) ;; When the copy function name is not the default, check ;; that the default function is not defined. Tests should ;; be designed so that this name is not accidently defined ;; for something else. ,@(unless (eq copy-fn copy-fn-default) - `((deftest ,(make-struct-test-name name 11) - (fboundp (quote ,copy-fn-default)) - nil))) + `((deftest ,(make-struct-test-name name 11) + (fboundp (quote ,copy-fn-default)) + nil))) ;; When there are read-only slots, test that the SETF ;; form for them is not FBOUNDP ,@(when (loop for x in slot-read-only thereis x) - `((deftest ,(make-struct-test-name name 12) - (and - ,@(loop for slot-name in slot-names - for read-only in slot-read-only - for field-fn in field-fns - when read-only - collect `(not-mv (fboundp '(setf ,field-fn)))) - t) - t))) + `((deftest ,(make-struct-test-name name 12) + (and + ,@(loop for slot-name in slot-names + for read-only in slot-read-only + for field-fn in field-fns + when read-only + collect `(not-mv (fboundp '(setf ,field-fn)))) + t) + t))) ;; When the structure is a true structure type, check that ;; the various class relationships hold ,@(unless type-option - `( - (deftest ,(make-struct-test-name name 13) - (notnot-mv (typep (,make-fn) (find-class (quote ,name)))) - t) - (deftest ,(make-struct-test-name name 14) - (let ((class (find-class (quote ,name)))) - (notnot-mv (typep class 'structure-class))) - t) - (deftest ,(make-struct-test-name name 15) - (notnot-mv (typep (,make-fn) 'structure-object)) - t) - (deftest ,(make-struct-test-name name 16) - (loop for type in *disjoint-types-list* - unless (and - (equalt (multiple-value-list - (subtypep* type (quote ,name))) - '(nil t)) - (equalt (multiple-value-list - (subtypep* (quote ,name) type)) - '(nil t))) - collect type) - nil) - (deftest ,(make-struct-test-name name 17) - (let ((class (find-class (quote ,name)))) - (loop for type in *disjoint-types-list* - unless (and - (equalt (multiple-value-list - (subtypep* type class)) - '(nil t)) - (equalt (multiple-value-list - (subtypep* class type)) - '(nil t))) - collect type)) - nil) - (deftest ,(make-struct-test-name name "15A") - (let ((class (find-class (quote ,name)))) - (notnot-mv (subtypep class 'structure-object))) - t t) - (deftest ,(make-struct-test-name name "15B") - (notnot-mv (subtypep (quote ,name) 'structure-object)) - t t) - - )) + `( + (deftest ,(make-struct-test-name name 13) + (notnot-mv (typep (,make-fn) (find-class (quote ,name)))) + t) + (deftest ,(make-struct-test-name name 14) + (let ((class (find-class (quote ,name)))) + (notnot-mv (typep class 'structure-class))) + t) + (deftest ,(make-struct-test-name name 15) + (notnot-mv (typep (,make-fn) 'structure-object)) + t) + (deftest ,(make-struct-test-name name 16) + (loop for type in *disjoint-types-list* + unless (and + (equalt (multiple-value-list + (subtypep* type (quote ,name))) + '(nil t)) + (equalt (multiple-value-list + (subtypep* (quote ,name) type)) + '(nil t))) + collect type) + nil) + (deftest ,(make-struct-test-name name 17) + (let ((class (find-class (quote ,name)))) + (loop for type in *disjoint-types-list* + unless (and + (equalt (multiple-value-list + (subtypep* type class)) + '(nil t)) + (equalt (multiple-value-list + (subtypep* class type)) + '(nil t))) + collect type)) + nil) + (deftest ,(make-struct-test-name name "15A") + (let ((class (find-class (quote ,name)))) + (notnot-mv (subtypep class 'structure-object))) + t t) + (deftest ,(make-struct-test-name name "15B") + (notnot-mv (subtypep (quote ,name) 'structure-object)) + t t) + + )) ;;; Documentation tests ,(when doc-string - `(deftest ,(make-struct-test-name name 18) - (let ((doc (documentation ',name 'structure))) - (or (null doc) (equalt doc ',doc-string))) - t)) + `(deftest ,(make-struct-test-name name 18) + (let ((doc (documentation ',name 'structure))) + (or (null doc) (equalt doc ',doc-string))) + t)) ,(when (and doc-string (not type-option)) - `(deftest ,(make-struct-test-name name 19) - (let ((doc (documentation ',name 'type))) - (or (null doc) (equalt doc ',doc-string))) - t)) + `(deftest ,(make-struct-test-name name 19) + (let ((doc (documentation ',name 'type))) + (or (null doc) (equalt doc ',doc-string))) + t)) ;; Test that COPY-STRUCTURE works, if this is a structure ;; type ,@(unless type-option - `((deftest ,(make-struct-test-name name 20) - ,(let* ((var 'XTEMP-20) - (var2 'YTEMP-20)) - `(let ((,var (,make-fn - ,@(loop - for (slot-name . initval) - in initial-value-alist - nconc (list (intern (string slot-name) - "KEYWORD") - `(quote ,initval)))))) - (let ((,var2 (copy-structure ,var))) - (and - (not (eqlt ,var ,var2)) - ,@(loop - for (slot-name . nil) in initial-value-alist - for fn in field-fns - collect - `(eqlt (,fn ,var) (,fn ,var2))) - t)))) - t))) + `((deftest ,(make-struct-test-name name 20) + ,(let* ((var 'XTEMP-20) + (var2 'YTEMP-20)) + `(let ((,var (,make-fn + ,@(loop + for (slot-name . initval) + in initial-value-alist + nconc (list (intern (string slot-name) + "KEYWORD") + `(quote ,initval)))))) + (let ((,var2 (copy-structure ,var))) + (and + (not (eqlt ,var ,var2)) + ,@(loop + for (slot-name . nil) in initial-value-alist + for fn in field-fns + collect + `(eqlt (,fn ,var) (,fn ,var2))) + t)))) + t))) nil ))) (defun defstruct-maketemp (stem suffix1 &optional suffix2) "Make a temporary variable for DEFSTRUCT-WITH-TESTS." (intern (if suffix2 (format nil "~A-~A-~A" stem suffix1 suffix2) - (format nil "~A-~A" stem suffix1)))) + (format nil "~A-~A" stem suffix1)))) diff --git a/ansi-tests/structures-01.lsp b/ansi-tests/structures-01.lsp index 022adffe..e5c67c72 100644 --- a/ansi-tests/structures-01.lsp +++ b/ansi-tests/structures-01.lsp @@ -75,7 +75,7 @@ (setf (s-1-foo s) nil) (setf (s-1-bar s) nil) (list (s-1-foo s2) - (s-1-bar s2)))) + (s-1-bar s2)))) (a b)) ;; Make produces unique items diff --git a/ansi-tests/structures-02.lsp b/ansi-tests/structures-02.lsp index 15317850..64858e46 100644 --- a/ansi-tests/structures-02.lsp +++ b/ansi-tests/structures-02.lsp @@ -39,13 +39,13 @@ (deftest structure-2-2 (let ((*s-2-f6-counter* 0)) (eqt (s-2-f5 (make-s-2)) - (s-2-f5 (make-s-2)))) + (s-2-f5 (make-s-2)))) nil) ;; Creation with various fields does the right thing (deftest structure-2-3 (let* ((*s-2-f6-counter* 0) - (s (make-s-2 :f1 17))) + (s (make-s-2 :f1 17))) (and (eqlt (s-2-f1 s) 17) (eqt (s-2-f2 s) 'a) @@ -58,7 +58,7 @@ (deftest structure-2-4 (let* ((*s-2-f6-counter* 0) - (s (make-s-2 :f2 'z))) + (s (make-s-2 :f2 'z))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'z) @@ -71,7 +71,7 @@ (deftest structure-2-5 (let* ((*s-2-f6-counter* 0) - (s (make-s-2 :f3 1.0))) + (s (make-s-2 :f3 1.0))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) @@ -84,7 +84,7 @@ (deftest structure-2-6 (let* ((*s-2-f6-counter* 0) - (s (make-s-2 :f4 #\z))) + (s (make-s-2 :f4 #\z))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) @@ -97,7 +97,7 @@ (deftest structure-2-7 (let* ((*s-2-f6-counter* 0) - (s (make-s-2 :f5 '(c d e)))) + (s (make-s-2 :f5 '(c d e)))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) @@ -110,7 +110,7 @@ (deftest structure-2-8 (let* ((*s-2-f6-counter* 0) - (s (make-s-2 :f6 10))) + (s (make-s-2 :f6 10))) (and (eqlt (s-2-f1 s) 0) (eqt (s-2-f2 s) 'a) @@ -142,7 +142,7 @@ (defstruct-with-tests (struct-test-15 (:predicate nil)) a15 b15) (defstruct-with-tests (struct-test-16 :predicate) a16 b16) (defstruct-with-tests (struct-test-17 - (:predicate struct-test-17-alternate-pred)) + (:predicate struct-test-17-alternate-pred)) a17 b17) (defstruct-with-tests (struct-test-18 :copier) a18 b18) @@ -214,7 +214,7 @@ (struct-test-38 11 12 4)) (defstruct-with-tests (struct-test-39 (:predicate nil) - (:type list) :named) + (:type list) :named) a39 b39 c39) (deftest structure-39-1 @@ -233,11 +233,11 @@ ;;; Confirm that the defined structure types are all disjoint (deftest structs-are-disjoint (loop for s1 in *defstruct-with-tests-names* - sum (loop for s2 in *defstruct-with-tests-names* - unless (eq s1 s2) - count (not (equalt (multiple-value-list - (subtypep* s1 s2)) - '(nil t))))) + sum (loop for s2 in *defstruct-with-tests-names* + unless (eq s1 s2) + count (not (equalt (multiple-value-list + (subtypep* s1 s2)) + '(nil t))))) 0) (defstruct-with-tests (struct-test-45 (:type list) (:initial-offset 2)) @@ -248,7 +248,7 @@ (1 2)) (defstruct-with-tests (struct-test-46 (:type list) - (:include struct-test-45)) + (:include struct-test-45)) c46 d46) (deftest structure-46-1 @@ -256,8 +256,8 @@ (1 2 3 4)) (defstruct-with-tests (struct-test-47 (:type list) - (:initial-offset 3) - (:include struct-test-45)) + (:initial-offset 3) + (:include struct-test-45)) c47 d47) (deftest structure-47-1 @@ -266,8 +266,8 @@ 1 2 3 4) (defstruct-with-tests (struct-test-48 (:type list) - (:initial-offset 0) - (:include struct-test-45)) + (:initial-offset 0) + (:include struct-test-45)) c48 d48) (deftest structure-48-1 @@ -287,11 +287,11 @@ (b51 25 :type (integer 0 255))) (defstruct-with-tests (struct-test-52 (:type vector) - (:initial-offset 0)) + (:initial-offset 0)) a52 b52) (defstruct-with-tests (struct-test-53 (:type vector) - (:initial-offset 5)) + (:initial-offset 5)) "This is struct-test-53" a53 b53) @@ -301,8 +301,8 @@ 10 a) (defstruct-with-tests (struct-test-54 (:type vector) - (:initial-offset 2) - (:include struct-test-53)) + (:initial-offset 2) + (:include struct-test-53)) "This is struct-test-54" a54 b54) @@ -312,8 +312,8 @@ 8 g 10 a) (defstruct-with-tests (struct-test-55 (:type list) - (:initial-offset 2) - :named) + (:initial-offset 2) + :named) a55 b55 c55) (deftest structure-55-1 @@ -322,9 +322,9 @@ struct-test-55 p q) (defstruct-with-tests (struct-test-56 (:type list) - (:initial-offset 3) - (:include struct-test-55) - :named) + (:initial-offset 3) + (:include struct-test-55) + :named) d56 e56) (deftest structure-56-1 @@ -355,8 +355,8 @@ (let ((*st-60* 10)) (let ((s (make-struct-test-60 :*st-60* 200))) (values (struct-test-60-a60 s) - (struct-test-60-*st-60* s) - (struct-test-60-b60 s)))) + (struct-test-60-*st-60* s) + (struct-test-60-b60 s)))) 10 200 10) @@ -370,7 +370,7 @@ (deftest structure-61-1 (let ((s (make-struct-test-61 :a 10 :b 'c))) (values (struct-test-61-a s) - (struct-test-61-b s))) + (struct-test-61-b s))) 10 c) ;;; Initializer forms are evaluated only when needed, and are @@ -379,15 +379,15 @@ (eval-when (:load-toplevel :execute) (let ((x nil)) (flet ((%f () x) - (%g (y) (setf x y))) + (%g (y) (setf x y))) (defstruct struct-test-62 - (a (progn (setf x 'a) nil)) - (f #'%f) - (g #'%g))))) + (a (progn (setf x 'a) nil)) + (f #'%f) + (g #'%g))))) (deftest structure-62-1 (let* ((s (make-struct-test-62 :a 1)) - (f (struct-test-62-f s))) + (f (struct-test-62-f s))) (assert (typep f 'function)) (values (struct-test-62-a s) @@ -396,8 +396,8 @@ (deftest structure-62-2 (let* ((s (make-struct-test-62)) - (f (struct-test-62-f s)) - (g (struct-test-62-g s))) + (f (struct-test-62-f s)) + (g (struct-test-62-g s))) (assert (typep f 'function)) (assert (typep g 'function)) (locally @@ -483,7 +483,7 @@ (b nil)) (defstruct-with-tests (struct-test-68 (:include struct-test-67)) - c d) + c d) ;;; Error tests diff --git a/ansi-tests/structures-03.lsp b/ansi-tests/structures-03.lsp index 1e865ff1..e4329977 100644 --- a/ansi-tests/structures-03.lsp +++ b/ansi-tests/structures-03.lsp @@ -7,10 +7,10 @@ (defun sbt-slots (sname s &rest slots) (loop for slotname in slots collect - (let ((fun (intern (concatenate 'string (string sname) - "-" (string slotname)) - :cl-test))) - (funcall (symbol-function fun) s)))) + (let ((fun (intern (concatenate 'string (string sname) + "-" (string slotname)) + :cl-test))) + (funcall (symbol-function fun) s)))) ;;; See the DEFSTRUCT page, and section 3.4.6 (Boa Lambda Lists) @@ -20,34 +20,34 @@ (deftest structure-boa-test-01/1 (let ((s (sbt-01-con 1 2 3))) (values (sbt-01-a s) - (sbt-01-b s) - (sbt-01-c s))) + (sbt-01-b s) + (sbt-01-c s))) 2 1 3) (defstruct* (sbt-02 (:constructor sbt-02-con (a b c)) - (:constructor sbt-02-con-2 (a b)) - (:constructor sbt-02-con-3 ())) + (:constructor sbt-02-con-2 (a b)) + (:constructor sbt-02-con-3 ())) (a 'x) (b 'y) (c 'z)) (deftest structure-boa-test-02/1 (let ((s (sbt-02-con 1 2 3))) (values (sbt-02-a s) - (sbt-02-b s) - (sbt-02-c s))) + (sbt-02-b s) + (sbt-02-c s))) 1 2 3) (deftest structure-boa-test-02/2 (let ((s (sbt-02-con-2 'p 'q))) (values (sbt-02-a s) - (sbt-02-b s) - (sbt-02-c s))) + (sbt-02-b s) + (sbt-02-c s))) p q z) (deftest structure-boa-test-02/3 (let ((s (sbt-02-con-3))) (values (sbt-02-a s) - (sbt-02-b s) - (sbt-02-c s))) + (sbt-02-b s) + (sbt-02-c s))) x y z) ;;; &optional in BOA LL @@ -131,10 +131,10 @@ ;;; Test presence flag in optional parameters (defstruct* (sbt-07 (:constructor sbt-07-con - (&optional (a 'p a-p) (b 'q b-p) (c 'r c-p) - &aux (d (list (notnot a-p) - (notnot b-p) - (notnot c-p)))))) + (&optional (a 'p a-p) (b 'q b-p) (c 'r c-p) + &aux (d (list (notnot a-p) + (notnot b-p) + (notnot c-p)))))) a b c d) (deftest structure-boa-test-07/1 @@ -157,7 +157,7 @@ ;;; Keyword arguments (defstruct* (sbt-08 (:constructor sbt-08-con - (&key ((:foo a))))) + (&key ((:foo a))))) a) (deftest structure-boa-test-08/1 @@ -165,14 +165,14 @@ (10)) (defstruct* (sbt-09 (:constructor sbt-09-con - (&key (a 'p a-p) - ((:x b) 'q) - (c 'r) - d - ((:y e)) - ((:z f) 's z-p) - &aux (g (list (notnot a-p) - (notnot z-p)))))) + (&key (a 'p a-p) + ((:x b) 'q) + (c 'r) + d + ((:y e)) + ((:z f) 's z-p) + &aux (g (list (notnot a-p) + (notnot z-p)))))) a b c d e f g) (deftest structure-boa-test-09/1 @@ -206,7 +206,7 @@ ;;; Aux variable overriding a default value (defstruct* (sbt-10 (:constructor sbt-10-con (&aux (a 10) - (b (1+ a))))) + (b (1+ a))))) (a 1) (b 2)) (deftest structure-boa-test-10/1 @@ -228,8 +228,8 @@ ;;; Arguments that correspond to no slots (defstruct* (sbt-12 (:constructor sbt-12-con (a &optional (b 1) - &rest c - &aux (d (list a b c))))) + &rest c + &aux (d (list a b c))))) d) (deftest structure-boa-12/1 @@ -246,7 +246,7 @@ (defstruct* (sbt-13 (:constructor sbt-13-con - (&key (a 1) (b 2) c &aux (d (list a b c))))) + (&key (a 1) (b 2) c &aux (d (list a b c))))) d) (deftest structure-boa-test-13/1 @@ -311,9 +311,9 @@ ;;; keyword parameters if not specified. (defstruct* (sbt-15 (:constructor sbt-15-con - (&key ((:x a) nil) - ((y b) nil) - (c nil)))) + (&key ((:x a) nil) + ((y b) nil) + (c nil)))) a b c) (deftest structure-boa-test-15/1 @@ -352,7 +352,7 @@ ;;; Default constructor w. BOA constructor, and error cases (defstruct* (sbt-16 (:constructor) - (:constructor sbt-16-con (a b c))) + (:constructor sbt-16-con (a b c))) a b c) (deftest structure-boa-test-16/1 @@ -381,12 +381,12 @@ (deftest structure-boa-test-16/7 (sbt-slots 'sbt-16 (make-sbt-16 :a 1 :b 2 :c 3 :d 5 :allow-other-keys t) - :a :b :c) + :a :b :c) (1 2 3)) (deftest structure-boa-test-16/8 (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :a 1 :b 2 :c 3 :d 5) - :a :b :c) + :a :b :c) (1 2 3)) ;;; :allow-other-keys turns off keyword error checking, including @@ -394,7 +394,7 @@ ;;;(deftest structure-boa-test-16/9 ;;; (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t ;;; :a 3 :b 6 :c 9 1000 1000) -;;; :a :b :c) +;;; :a :b :c) ;;; (3 6 9)) ;;; Repeated keyword arguments are allowed; the leftmost one is used @@ -403,16 +403,16 @@ (1 3 5)) (deftest structure-boa-test-16/11 - (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t - :allow-other-keys nil - :a 1 :b 2 :c 3 :d 5) - :a :b :c) + (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t + :allow-other-keys nil + :a 1 :b 2 :c 3 :d 5) + :a :b :c) (1 2 3)) ;; Checking of # of keywords is suppressed when :allow-other-keys is true ;;;(deftest structure-boa-test-16/12 ;;; (sbt-slots 'sbt-16 (make-sbt-16 :allow-other-keys t :a 3 :b 6 :c 9 :a) -;;; :a :b :c) +;;; :a :b :c) ;;; (3 6 9)) diff --git a/ansi-tests/structures-04.lsp b/ansi-tests/structures-04.lsp index 146f75f6..6c5fde8b 100644 --- a/ansi-tests/structures-04.lsp +++ b/ansi-tests/structures-04.lsp @@ -12,7 +12,7 @@ a (b 0)) (defstruct (struct-include-01b (:include struct-include-01a - (a 100) (b 'x))) + (a 100) (b 'x))) (c 200) d) (deftest struct-include.1 @@ -46,7 +46,7 @@ (a 0 :type number)) (defstruct (struct-include-02b (:include struct-include-02a - (a 10 :type integer)))) + (a 10 :type integer)))) (deftest struct-include.3 (let ((obj (make-struct-include-02b))) @@ -91,7 +91,7 @@ (defstruct struct-include-04a a b) (defstruct (struct-include-04b (:include struct-include-04a - (a 0 :read-only t)))) + (a 0 :read-only t)))) (deftest struct-include.6 (let ((obj (make-struct-include-04b))) diff --git a/ansi-tests/sublis.lsp b/ansi-tests/sublis.lsp index 46d76d49..84a66623 100644 --- a/ansi-tests/sublis.lsp +++ b/ansi-tests/sublis.lsp @@ -9,57 +9,57 @@ (deftest sublis.1 (check-sublis '((a b) g (d e 10 g h) 15 . g) - '((e . e2) (g . 17))) + '((e . e2) (g . 17))) ((a b) 17 (d e2 10 17 h) 15 . 17)) (deftest sublis.2 (check-sublis '(f6 10 (f4 (f3 (f1 a b) (f1 a p)) (f2 a b))) - '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) - :test #'equal) + '(((f1 a b) . (f2 a b)) ((f2 a b) . (f1 a b))) + :test #'equal) (f6 10 (f4 (f3 (f2 a b) (f1 a p)) (f1 a b)))) (deftest sublis.3 (check-sublis '(10 ((10 20 (a b c) 30)) (((10 20 30 40)))) - '((30 . "foo"))) + '((30 . "foo"))) (10 ((10 20 (a b c) "foo")) (((10 20 "foo" 40))))) (deftest sublis.4 (check-sublis (sublis - (copy-tree '((a . 2) (b . 4) (c . 1))) - (copy-tree '(a b c d e (a b c a d b) f))) - '((t . "yes")) - :key #'(lambda (x) (and (typep x 'integer) - (evenp x)))) + (copy-tree '((a . 2) (b . 4) (c . 1))) + (copy-tree '(a b c d e (a b c a d b) f))) + '((t . "yes")) + :key #'(lambda (x) (and (typep x 'integer) + (evenp x)))) ("yes" "yes" 1 d e ("yes" "yes" 1 "yes" d "yes") f)) (deftest sublis.5 (check-sublis '("fee" (("fee" "Fie" "foo")) - fie ("fee" "fie")) - `((,(copy-seq "fie") . #\f))) + fie ("fee" "fie")) + `((,(copy-seq "fie") . #\f))) ("fee" (("fee" "Fie" "foo")) fie ("fee" "fie"))) (deftest sublis.6 (check-sublis '("fee" fie (("fee" "Fie" "foo") 1) - ("fee" "fie")) - `((,(copy-seq "fie") . #\f)) - :test 'equal) + ("fee" "fie")) + `((,(copy-seq "fie") . #\f)) + :test 'equal) ("fee" fie (("fee" "Fie" "foo") 1) ("fee" #\f))) (deftest sublis.7 (check-sublis '(("aa" a b) - (z "bb" d) - ((x . "aa"))) - `((,(copy-seq "aa") . 1) - (,(copy-seq "bb") . 2)) - :test 'equal - :key #'(lambda (x) (if (consp x) (car x) - '*not-present*))) + (z "bb" d) + ((x . "aa"))) + `((,(copy-seq "aa") . 1) + (,(copy-seq "bb") . 2)) + :test 'equal + :key #'(lambda (x) (if (consp x) (car x) + '*not-present*))) (1 (z . 2) ((x . "aa")))) ;; Check that a null key arg is ignored. (deftest sublis.8 - (check-sublis + (check-sublis '(1 2 a b) '((1 . 2) (a . b)) :key nil) @@ -67,24 +67,24 @@ (deftest sublis.9 (check-sublis (list 0 3 8 20) - '((1 . x) (5 . y) (10 . z)) - :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) + '((1 . x) (5 . y) (10 . z)) + :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) (x y z 20)) (deftest sublis.10 (check-sublis (list 0 3 8 20) - '((1 . x) (5 . y) (10 . z)) - :test-not - #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) + '((1 . x) (5 . y) (10 . z)) + :test-not + #'(lambda (x y) (not (and (realp x) (realp y) (< x y))))) (x y z 20)) (defharmless sublis.test-and-test-not.1 (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) - :test #'eql :test-not #'eql)) + :test #'eql :test-not #'eql)) (defharmless sublis.test-and-test-not.2 (sublis '((a . 1) (b . 2)) (list 'a 'b 'c 'd) - :test-not #'eql :test #'eql)) + :test-not #'eql :test #'eql)) ;;; Order of argument evaluation (deftest sublis.order.1 @@ -92,9 +92,9 @@ (values (sublis (progn (setf w (incf i)) - '((a . z))) + '((a . z))) (progn (setf x (incf i)) - (copy-tree '(a b c d))) + (copy-tree '(a b c d))) :test (progn (setf y (incf i)) #'eql) :key (progn (setf z (incf i)) #'identity)) i w x y z)) @@ -106,9 +106,9 @@ (values (sublis (progn (setf w (incf i)) - '((a . z))) + '((a . z))) (progn (setf x (incf i)) - (copy-tree '(a b c d))) + (copy-tree '(a b c d))) :key (progn (setf y (incf i)) #'identity) :test-not (progn (setf z (incf i)) (complement #'eql)) ) @@ -145,7 +145,7 @@ (deftest sublis.keywords.6 (sublis '((1 . a)) (list 0 1 2) :key #'(lambda (x) (if (numberp x) (1+ x) x)) - :key #'identity) + :key #'identity) (a 1 2)) @@ -169,33 +169,33 @@ (deftest sublis.error.5 (signals-error (sublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :test #'identity) - program-error) + (list 'a 'b 'c 'd) + :test #'identity) + program-error) t) (deftest sublis.error.6 (signals-error (sublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :key #'cons) - program-error) + (list 'a 'b 'c 'd) + :key #'cons) + program-error) t) (deftest sublis.error.7 (signals-error (sublis '((a . 1) (b . 2)) - (list 'a 'b 'c 'd) - :test-not #'identity) - program-error) + (list 'a 'b 'c 'd) + :test-not #'identity) + program-error) t) (deftest sublis.error.8 (signals-error (sublis '((a . 1) . bad) - (list 'a 'b 'c 'd)) - type-error) + (list 'a 'b 'c 'd)) + type-error) t) (deftest sublis.shared (let* ((shared-piece (list 'a 'b)) - (a (list shared-piece shared-piece))) + (a (list shared-piece shared-piece))) (check-sublis a '((a . b) (b . a)))) ((b a) (b a))) diff --git a/ansi-tests/subseq-aux.lsp b/ansi-tests/subseq-aux.lsp index 02a0066e..fba5149a 100644 --- a/ansi-tests/subseq-aux.lsp +++ b/ansi-tests/subseq-aux.lsp @@ -11,11 +11,11 @@ (loop for i from 0 to 20 do (loop - for j from i to 20 do - (let ((y (subseq x i j))) - (loop - for e in y and k from i to (1- j) do - (unless (eqlt e k) (return-from done nil))))))) + for j from i to 20 do + (let ((y (subseq x i j))) + (loop + for e in y and k from i to (1- j) do + (unless (eqlt e k) (return-from done nil))))))) t)) (defun subseq-list.5-body () @@ -24,29 +24,29 @@ (loop for i from 0 to 30 do (unless (equalt (subseq x i) - (loop for j from i to 29 collect j)) - (return-from done nil)))) + (loop for j from i to 29 collect j)) + (return-from done nil)))) t)) (defun subseq-list.6-body () (let* ((x (make-list 100)) - (z (loop for e on x collect e)) - (y (subseq x 0))) + (z (loop for e on x collect e)) + (y (subseq x 0))) (loop for e on x and f on y and g in z do (when (or (not (eqt g e)) - (not (eqlt (car e) (car f))) - (car e) - (eqt e f)) + (not (eqlt (car e) (car f))) + (car e) + (eqt e f)) (return nil)) finally (return t)))) (defun subseq-vector.1-body () (block nil (let* ((x (make-sequence 'vector 10 :initial-element 'a)) - (y (subseq x 4 8))) + (y (subseq x 4 8))) (unless (every #'(lambda (e) (eqt e 'a)) x) (return 1)) (unless (every #'(lambda (e) (eqt e 'a)) y) @@ -64,7 +64,7 @@ (defun subseq-vector.2-body () (block nil (let* ((x (make-sequence '(vector fixnum) 10 :initial-element 1)) - (y (subseq x 4 8))) + (y (subseq x 4 8))) (unless (every #'(lambda (e) (eqlt e 1)) x) (return 1)) (unless (every #'(lambda (e) (eqlt e 1)) y) @@ -82,7 +82,7 @@ (defun subseq-vector.3-body () (block nil (let* ((x (make-sequence '(vector single-float) 10 :initial-element 1.0)) - (y (subseq x 4 8))) + (y (subseq x 4 8))) (unless (every #'(lambda (e) (= e 1.0)) x) (return 1)) (unless (every #'(lambda (e) (= e 1.0)) y) @@ -100,7 +100,7 @@ (defun subseq-vector.4-body () (block nil (let* ((x (make-sequence '(vector double-float) 10 :initial-element 1.0d0)) - (y (subseq x 4 8))) + (y (subseq x 4 8))) (unless (every #'(lambda (e) (= e 1.0)) x) (return 1)) (unless (every #'(lambda (e) (= e 1.0)) y) @@ -118,7 +118,7 @@ (defun subseq-vector.5-body () (block nil (let* ((x (make-sequence '(vector short-float) 10 :initial-element 1.0s0)) - (y (subseq x 4 8))) + (y (subseq x 4 8))) (unless (every #'(lambda (e) (= e 1.0)) x) (return 1)) (unless (every #'(lambda (e) (= e 1.0)) y) @@ -136,7 +136,7 @@ (defun subseq-vector.6-body () (block nil (let* ((x (make-sequence '(vector long-float) 10 :initial-element 1.0l0)) - (y (subseq x 4 8))) + (y (subseq x 4 8))) (unless (every #'(lambda (e) (= e 1.0)) x) (return 1)) (unless (every #'(lambda (e) (= e 1.0)) y) @@ -153,87 +153,87 @@ (defun subseq-string.1-body () (let* ((s1 "abcdefgh") - (len (length s1))) + (len (length s1))) (loop for start from 0 below len - always - (string= (subseq s1 start) - (coerce (loop for i from start to (1- len) - collect (elt s1 i)) - 'string))))) + always + (string= (subseq s1 start) + (coerce (loop for i from start to (1- len) + collect (elt s1 i)) + 'string))))) (defun subseq-string.2-body () (let* ((s1 "abcdefgh") - (len (length s1))) + (len (length s1))) (loop for start from 0 below len - always - (loop for end from (1+ start) to len - always - (string= (subseq s1 start end) - (coerce (loop for i from start below end - collect (elt s1 i)) - 'string)))))) + always + (loop for end from (1+ start) to len + always + (string= (subseq s1 start end) + (coerce (loop for i from start below end + collect (elt s1 i)) + 'string)))))) (defun subseq-string.3-body () (let* ((s1 (make-array '(10) :initial-contents "abcdefghij" - :fill-pointer 8 - :element-type 'character)) - (len (length s1))) + :fill-pointer 8 + :element-type 'character)) + (len (length s1))) (and (eqlt len 8) (loop for start from 0 below len - always - (string= (subseq s1 start) - (coerce (loop for i from start to (1- len) - collect (elt s1 i)) - 'string))) + always + (string= (subseq s1 start) + (coerce (loop for i from start to (1- len) + collect (elt s1 i)) + 'string))) (loop for start from 0 below len - always - (loop for end from (1+ start) to len - always - (string= (subseq s1 start end) - (coerce (loop for i from start below end - collect (elt s1 i)) - 'string))))))) + always + (loop for end from (1+ start) to len + always + (string= (subseq s1 start end) + (coerce (loop for i from start below end + collect (elt s1 i)) + 'string))))))) (defun subseq-bit-vector.1-body () (let* ((s1 #*11001000) - (len (length s1))) + (len (length s1))) (loop for start from 0 below len - always - (equalp (subseq s1 start) - (coerce (loop for i from start to (1- len) - collect (elt s1 i)) - 'bit-vector))))) + always + (equalp (subseq s1 start) + (coerce (loop for i from start to (1- len) + collect (elt s1 i)) + 'bit-vector))))) (defun subseq-bit-vector.2-body () (let* ((s1 #*01101011) - (len (length s1))) + (len (length s1))) (loop for start from 0 below len - always - (loop for end from (1+ start) to len - always - (equalp (subseq s1 start end) - (coerce (loop for i from start below end - collect (elt s1 i)) - 'bit-vector)))))) + always + (loop for end from (1+ start) to len + always + (equalp (subseq s1 start end) + (coerce (loop for i from start below end + collect (elt s1 i)) + 'bit-vector)))))) (defun subseq-bit-vector.3-body () (let* ((s1 (make-array '(10) :initial-contents #*1101100110 - :fill-pointer 8 - :element-type 'bit)) - (len (length s1))) + :fill-pointer 8 + :element-type 'bit)) + (len (length s1))) (and (eqlt len 8) (loop for start from 0 below len - always - (equalp (subseq s1 start) - (coerce (loop for i from start to (1- len) - collect (elt s1 i)) - 'bit-vector))) + always + (equalp (subseq s1 start) + (coerce (loop for i from start to (1- len) + collect (elt s1 i)) + 'bit-vector))) (loop for start from 0 below len - always - (loop for end from (1+ start) to len - always - (equalp (subseq s1 start end) - (coerce (loop for i from start below end - collect (elt s1 i)) - 'bit-vector))))))) + always + (loop for end from (1+ start) to len + always + (equalp (subseq s1 start end) + (coerce (loop for i from start below end + collect (elt s1 i)) + 'bit-vector))))))) diff --git a/ansi-tests/subseq.lsp b/ansi-tests/subseq.lsp index 780aba85..525d06d1 100644 --- a/ansi-tests/subseq.lsp +++ b/ansi-tests/subseq.lsp @@ -43,35 +43,35 @@ (deftest subseq-list.8 (let* ((x '(a b c d e)) - (y (copy-seq x))) + (y (copy-seq x))) (setf (subseq y 0) '(f g h)) (list x y)) ((a b c d e) (f g h d e))) (deftest subseq-list.9 (let* ((x '(a b c d e)) - (y (copy-seq x))) + (y (copy-seq x))) (setf (subseq y 1 3) '(1 2 3 4 5)) (list x y)) ((a b c d e) (a 1 2 d e))) (deftest subseq-list.10 (let* ((x '(a b c d e)) - (y (copy-seq x))) + (y (copy-seq x))) (setf (subseq y 5) '(1 2 3 4 5)) (list x y)) ((a b c d e) (a b c d e))) (deftest subseq-list.11 (let* ((x '(a b c d e)) - (y (copy-seq x))) + (y (copy-seq x))) (setf (subseq y 2 5) '(1)) (list x y)) ((a b c d e) (a b 1 d e))) (deftest subseq-list.12 (let* ((x '(a b c d e)) - (y (copy-seq x))) + (y (copy-seq x))) (setf (subseq y 0 0) '(1 2)) (list x y)) ((a b c d e) (a b c d e))) @@ -86,20 +86,20 @@ (deftest subseq-vector.2 (subseq-vector.2-body) - t) + t) (deftest subseq-vector.3 (subseq-vector.3-body) - t) + t) (deftest subseq-vector.4 (subseq-vector.4-body) - t) + t) (deftest subseq-vector.5 (subseq-vector.5-body) - t) + t) (deftest subseq-vector.6 (subseq-vector.6-body) @@ -107,45 +107,45 @@ (deftest subseq-vector.7 (let* ((x (make-array '(10) :initial-contents '(a b c d e f g h i j))) - (y (subseq x 2 8))) + (y (subseq x 2 8))) (equal-array y (make-array '(6) :initial-contents '(c d e f g h)))) t) (deftest subseq-vector.8 (let* ((x (make-array '(200) :initial-element 107 - :element-type 'fixnum)) - (y (subseq x 17 95))) + :element-type 'fixnum)) + (y (subseq x 17 95))) (and (eqlt (length y) (- 95 17)) - (equal-array y - (make-array (list (- 95 17)) - :initial-element 107 - :element-type 'fixnum)))) + (equal-array y + (make-array (list (- 95 17)) + :initial-element 107 + :element-type 'fixnum)))) t) (deftest subseq-vector.9 (let* ((x (make-array '(1000) :initial-element 17.6e-1 - :element-type 'single-float)) - (lo 164) - (hi 873) - (y (subseq x lo hi))) + :element-type 'single-float)) + (lo 164) + (hi 873) + (y (subseq x lo hi))) (and (eqlt (length y) (- hi lo)) - (equal-array y - (make-array (list (- hi lo)) - :initial-element 17.6e-1 - :element-type 'single-float)))) + (equal-array y + (make-array (list (- hi lo)) + :initial-element 17.6e-1 + :element-type 'single-float)))) t) (deftest subseq-vector.10 (let* ((x (make-array '(2000) :initial-element 3.1415927d4 - :element-type 'double-float)) - (lo 731) - (hi 1942) - (y (subseq x lo hi))) + :element-type 'double-float)) + (lo 731) + (hi 1942) + (y (subseq x lo hi))) (and (eqlt (length y) (- hi lo)) - (equal-array y - (make-array (list (- hi lo)) - :initial-element 3.1415927d4 - :element-type 'double-float)))) + (equal-array y + (make-array (list (- hi lo)) + :initial-element 3.1415927d4 + :element-type 'double-float)))) t) ;;; subseq on strings @@ -166,61 +166,61 @@ (deftest subseq.specialized-string.1 (let* ((s0 "abcde") - (len (length s0))) + (len (length s0))) (do-special-strings (s "abcde" nil) (loop for i from 0 below len - for s1 = (subseq s i) - do (assert (typep s1 'simple-array)) - do (assert (string= (subseq s i) (subseq s0 i))) - do (loop for j from i to len - for s2 = (subseq s i j) - do (assert (typep s2 'simple-array)) - (assert (string= s2 (subseq s0 i j))))))) + for s1 = (subseq s i) + do (assert (typep s1 'simple-array)) + do (assert (string= (subseq s i) (subseq s0 i))) + do (loop for j from i to len + for s2 = (subseq s i j) + do (assert (typep s2 'simple-array)) + (assert (string= s2 (subseq s0 i j))))))) nil) ;;; Other specialized vectors (deftest subseq.specialized-vector.1 (let* ((v0 #(1 0 1 1 0 1 1 0)) - (len (length v0))) + (len (length v0))) (do-special-integer-vectors (v (copy-seq v0) nil) (loop for i from 0 below len - for v1 = (subseq v i) - do (assert (typep v1 'simple-array)) - do (assert (equalp (subseq v i) (subseq v0 i))) - do (loop for j from i to len - for v2 = (subseq v i j) - do (assert (typep v2 'simple-array)) - (assert (equalp v2 (subseq v0 i j))))))) + for v1 = (subseq v i) + do (assert (typep v1 'simple-array)) + do (assert (equalp (subseq v i) (subseq v0 i))) + do (loop for j from i to len + for v2 = (subseq v i j) + do (assert (typep v2 'simple-array)) + (assert (equalp v2 (subseq v0 i j))))))) nil) (deftest subseq.specialized-vector.2 (loop for type in '(short-float single-float long-float double-float) - for len = 10 - for vals = (loop for i from 1 to len collect (coerce i type)) - for vec = (make-array len :element-type type :initial-contents vals) - for result = (subseq vec 1 9) - unless (and (= (length result) 8) - (equal (array-element-type vec) (array-element-type result)) - (equalp result (apply #'vector (subseq vals 1 9)))) - collect (list type vals result)) + for len = 10 + for vals = (loop for i from 1 to len collect (coerce i type)) + for vec = (make-array len :element-type type :initial-contents vals) + for result = (subseq vec 1 9) + unless (and (= (length result) 8) + (equal (array-element-type vec) (array-element-type result)) + (equalp result (apply #'vector (subseq vals 1 9)))) + collect (list type vals result)) nil) (deftest subseq.specialized-vector.3 (loop for etype in '(short-float single-float long-float double-float - integer rational) - for type = `(complex ,etype) - for len = 10 - for vals = (loop for i from 1 to len collect (complex (coerce i etype) - (coerce (- i) etype))) - for vec = (make-array len :element-type type :initial-contents vals) - for result = (subseq vec 1 9) - unless (and (= (length result) 8) - (equal (array-element-type vec) (array-element-type result)) - (equalp result (apply #'vector (subseq vals 1 9)))) - collect (list type vals result)) + integer rational) + for type = `(complex ,etype) + for len = 10 + for vals = (loop for i from 1 to len collect (complex (coerce i etype) + (coerce (- i) etype))) + for vec = (make-array len :element-type type :initial-contents vals) + for result = (subseq vec 1 9) + unless (and (= (length result) 8) + (equal (array-element-type vec) (array-element-type result)) + (equalp result (apply #'vector (subseq vals 1 9)))) + collect (list type vals result)) nil) ;;; Tests on bit vectors @@ -260,24 +260,24 @@ (deftest subseq.order.3 (let ((i 0) a b c d - (s (copy-seq "abcdefgh"))) + (s (copy-seq "abcdefgh"))) (values (setf (subseq - (progn (setf a (incf i)) s) - (progn (setf b (incf i)) 1) - (progn (setf c (incf i)) 4)) - (progn (setf d (incf i)) "xyz")) + (progn (setf a (incf i)) s) + (progn (setf b (incf i)) 1) + (progn (setf c (incf i)) 4)) + (progn (setf d (incf i)) "xyz")) s i a b c d)) "xyz" "axyzefgh" 4 1 2 3 4) (deftest subseq.order.4 (let ((i 0) a b c - (s (copy-seq "abcd"))) + (s (copy-seq "abcd"))) (values (setf (subseq - (progn (setf a (incf i)) s) - (progn (setf b (incf i)) 1)) - (progn (setf c (incf i)) "xyz")) + (progn (setf a (incf i)) s) + (progn (setf b (incf i)) 1)) + (progn (setf c (incf i)) "xyz")) s i a b c)) "xyz" "axyz" 3 1 2 3) diff --git a/ansi-tests/subsetp.lsp b/ansi-tests/subsetp.lsp index 1f199bf0..196f124f 100644 --- a/ansi-tests/subsetp.lsp +++ b/ansi-tests/subsetp.lsp @@ -19,64 +19,64 @@ (deftest subsetp.3 (subsetp-with-check (copy-tree '((8 9))) - cons-test-24-var :test 'equal) + cons-test-24-var :test 'equal) t) (deftest subsetp.4 (subsetp-with-check (list 78 (copy-seq "Z")) cons-test-24-var - :test #'equalp) + :test #'equalp) t) (deftest subsetp.5 (subsetp-with-check (list 1) (list 0 2 3 4) - :key #'(lambda (i) (floor (/ i 2)))) + :key #'(lambda (i) (floor (/ i 2)))) t) (deftest subsetp.6 (subsetp-with-check (list 1 6) (list 0 2 3 4) - :key #'(lambda (i) (floor (/ i 2)))) + :key #'(lambda (i) (floor (/ i 2)))) nil) (deftest subsetp.7 (subsetp-with-check (list '(a . 10) '(b . 20) '(c . 30)) - (list '(z . c) '(a . y) '(b . 100) '(e . f) - '(c . foo)) - :key #'car) + (list '(z . c) '(a . y) '(b . 100) '(e . f) + '(c . foo)) + :key #'car) t) (deftest subsetp.8 (subsetp-with-check (copy-tree '((a . 10) (b . 20) (c . 30))) - (copy-tree '((z . c) (a . y) (b . 100) (e . f) - (c . foo))) - :key 'car) + (copy-tree '((z . c) (a . y) (b . 100) (e . f) + (c . foo))) + :key 'car) t) (deftest subsetp.9 (subsetp-with-check (list 'a 'b 'c) - (copy-tree - (list '(z . c) '(a . y) '(b . 100) '(e . f) - '(c . foo))) - :test #'(lambda (e1 e2) - (eqt e1 (car e2)))) + (copy-tree + (list '(z . c) '(a . y) '(b . 100) '(e . f) + '(c . foo))) + :test #'(lambda (e1 e2) + (eqt e1 (car e2)))) t) (deftest subsetp.10 (subsetp-with-check (list 'a 'b 'c) - (copy-tree - (list '(z . c) '(a . y) '(b . 100) '(e . f) - '(c . foo))) - :test #'(lambda (e1 e2) - (eqt e1 (car e2))) - :key nil) + (copy-tree + (list '(z . c) '(a . y) '(b . 100) '(e . f) + '(c . foo))) + :test #'(lambda (e1 e2) + (eqt e1 (car e2))) + :key nil) t) (deftest subsetp.11 (subsetp-with-check (list 'a 'b 'c) - (copy-tree - (list '(z . c) '(a . y) '(b . 100) '(e . f) - '(c . foo))) - :test-not #'(lambda (e1 e2) - (not (eqt e1 (car e2))))) + (copy-tree + (list '(z . c) '(a . y) '(b . 100) '(e . f) + '(c . foo))) + :test-not #'(lambda (e1 e2) + (not (eqt e1 (car e2))))) t) ;; Check that it maintains order of arguments @@ -87,8 +87,8 @@ (list 1 2 3) (list 4 5 6) :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - t))) + (when (< y x) (return-from fail 'fail)) + t))) t) (deftest subsetp.13 @@ -98,8 +98,8 @@ (list 4 5 6) :key #'identity :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - t))) + (when (< y x) (return-from fail 'fail)) + t))) t) (deftest subsetp.14 @@ -108,8 +108,8 @@ (list 1 2 3) (list 4 5 6) :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - nil))) + (when (< y x) (return-from fail 'fail)) + nil))) t) (deftest subsetp.15 @@ -119,8 +119,8 @@ (list 4 5 6) :key #'identity :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - nil))) + (when (< y x) (return-from fail 'fail)) + nil))) t) (defharmless subsetp.test-and-test-not.1 @@ -135,9 +135,9 @@ (let ((i 0) x y) (values (notnot (subsetp (progn (setf x (incf i)) - '(a b c)) - (progn (setf y (incf i)) - '(a b c d)))) + '(a b c)) + (progn (setf y (incf i)) + '(a b c d)))) i x y)) t 2 1 2) @@ -145,11 +145,11 @@ (let ((i 0) x y z w) (values (notnot (subsetp (progn (setf x (incf i)) - '(a b c)) - (progn (setf y (incf i)) - '(a b c d)) - :test (progn (setf z (incf i)) #'eql) - :key (progn (setf w (incf i)) nil))) + '(a b c)) + (progn (setf y (incf i)) + '(a b c d)) + :test (progn (setf z (incf i)) #'eql) + :key (progn (setf w (incf i)) nil))) i x y z w)) t 4 1 2 3 4) @@ -157,11 +157,11 @@ (let ((i 0) x y z w) (values (notnot (subsetp (progn (setf x (incf i)) - '(a b c)) - (progn (setf y (incf i)) - '(a b c d)) - :key (progn (setf z (incf i)) nil) - :test (progn (setf w (incf i)) #'eql))) + '(a b c)) + (progn (setf y (incf i)) + '(a b c d)) + :key (progn (setf z (incf i)) nil) + :test (progn (setf w (incf i)) #'eql))) i x y z w)) t 4 1 2 3 4) @@ -173,14 +173,14 @@ (deftest subsetp.allow-other-keys.2 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) - :allow-other-keys #'cons :bad t)) + :allow-other-keys #'cons :bad t)) t) (deftest subsetp.allow-other-keys.3 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4) - :allow-other-keys (make-hash-table) - :bad t - :test #'(lambda (x y) (= (1+ x) y)))) + :allow-other-keys (make-hash-table) + :bad t + :test #'(lambda (x y) (= (1+ x) y)))) nil) (deftest subsetp.allow-other-keys.4 @@ -193,20 +193,20 @@ (deftest subsetp.allow-other-keys.6 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4 5) - :allow-other-keys t :bad1 t - :allow-other-keys nil :bad2 t)) + :allow-other-keys t :bad1 t + :allow-other-keys nil :bad2 t)) t) (deftest subsetp.keywords.7 (notnot-mv (subsetp '(1 2 3 4) '(0 1 2 3 4) - :test #'(lambda (x y) (= (1+ x) y)) - :test #'eql)) + :test #'(lambda (x y) (= (1+ x) y)) + :test #'eql)) nil) (deftest subsetp.keywords.8 (notnot-mv (subsetp '(1 2 3 4 10) '(0 1 2 3 4) - :key nil - :key #'(lambda (x) (mod x 2)))) + :key nil + :key #'(lambda (x) (mod x 2)))) nil) diff --git a/ansi-tests/subst-if-not.lsp b/ansi-tests/subst-if-not.lsp index 664a0afb..e95b0b9a 100644 --- a/ansi-tests/subst-if-not.lsp +++ b/ansi-tests/subst-if-not.lsp @@ -17,13 +17,13 @@ (deftest subst-if-not.2 (check-subst-if-not 'a (complement #'listp) - '((100 1) (2 3) (4 3 2 1) (a b c))) + '((100 1) (2 3) (4 3 2 1) (a b c))) a) (deftest subst-if-not.3 (check-subst-if-not 'c #'identity - '((100 1) (2 3) (4 3 2 1) (a b c)) - :key (complement #'listp)) + '((100 1) (2 3) (4 3 2 1) (a b c)) + :key (complement #'listp)) c) (deftest subst-if-not.4 @@ -32,14 +32,14 @@ #'(lambda (x) (not (eql x 17))) '((17) (17 22) (17 22 31) (17 21 34 54)) :key #'(lambda (x) - (and (consp x) - (car x)))) + (and (consp x) + (car x)))) (40 40 40 40)) (deftest subst-if-not.5 (check-subst-if-not 'a #'(lambda (x) (not (eql x 'b))) - '((a) (b) (c) (d)) - :key nil) + '((a) (b) (c) (d)) + :key nil) ((a) (a) (c) (d))) (deftest subst-if-not.7 @@ -55,7 +55,7 @@ 4 1 2 3 4) (def-fold-test subst-if-not.fold.1 (subst-if-not 'a #'consp '((1 . 2) 3 . 4))) - + ;;; Keywords tests for subst-if-not (deftest subst-if-not.allow-other-keys.1 @@ -76,7 +76,7 @@ (deftest subst-if-not.allow-other-keys.5 (subst-if-not 'a #'identity nil :allow-other-keys t - :allow-other-keys nil :bad t) + :allow-other-keys nil :bad t) a) (deftest subst-if-not.keywords.6 @@ -111,7 +111,7 @@ (deftest subst-if-not.error.7 (signals-error (subst-if-not 'a #'null nil - :bad t :allow-other-keys nil) program-error) + :bad t :allow-other-keys nil) program-error) t) (deftest subst-if-not.error.8 diff --git a/ansi-tests/subst-if.lsp b/ansi-tests/subst-if.lsp index 0546248d..7a3493de 100644 --- a/ansi-tests/subst-if.lsp +++ b/ansi-tests/subst-if.lsp @@ -17,8 +17,8 @@ (deftest subst-if.3 (check-subst-if '(z) - (complement #'consp) - '(a (a b) (c d e) (f g h i))) + (complement #'consp) + '(a (a b) (c d e) (f g h i))) ((z) ((z) (z) z) ((z) (z) (z) z) @@ -27,21 +27,21 @@ (deftest subst-if.4 (check-subst-if 'b #'identity '((100 1) (2 3) (4 3 2 1) (a b c)) - :key #'listp) + :key #'listp) b) (deftest subst-if.5 (check-subst-if 4 #'(lambda (x) (eql x 1)) - '((1 3) (1) (1 10 20 30) (1 3 x y)) - :key #'(lambda (x) - (and (consp x) - (car x)))) + '((1 3) (1) (1 10 20 30) (1 3 x y)) + :key #'(lambda (x) + (and (consp x) + (car x)))) (4 4 4 4)) (deftest subst-if.6 (check-subst-if 'a #'(lambda (x) (eql x 'b)) - '((a) (b) (c) (d)) - :key nil) + '((a) (b) (c) (d)) + :key nil) ((a) (a) (c) (d))) (deftest subst-if.7 diff --git a/ansi-tests/subst.lsp b/ansi-tests/subst.lsp index 0de24a19..5ca4e080 100644 --- a/ansi-tests/subst.lsp +++ b/ansi-tests/subst.lsp @@ -23,7 +23,7 @@ (deftest subst.4 (check-subst 'grape 'dick - '(melville wrote (moby dick))) + '(melville wrote (moby dick))) (melville wrote (moby grape))) (deftest subst.5 @@ -42,8 +42,8 @@ 'foo "aaa" '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) :key #'(lambda (x) (if (and (numberp x) (evenp x)) - "aaa" - nil)) + "aaa" + nil)) :test #'string=) ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) @@ -52,26 +52,26 @@ 'foo nil '((1 . 2) (4 . 5) (6 7 8 9 10 (11 12))) :key #'(lambda (x) (if (and (numberp x) (evenp x)) - (copy-seq "aaa") - nil)) + (copy-seq "aaa") + nil)) :test-not #'equal) ((1 . foo) (foo . 5) (foo 7 foo 9 foo (11 foo)))) (deftest subst.9 (check-subst 'a 'b - (copy-tree '(a b c d a b)) - :key nil) + (copy-tree '(a b c d a b)) + :key nil) (a a c d a a)) (deftest subst.10 (check-subst 'x 10 (copy-tree '(1 2 10 20 30 4)) - :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) + :test #'(lambda (x y) (and (realp x) (realp y) (< x y)))) (1 2 10 x x 4)) (deftest subst.11 (check-subst 'x 10 (copy-tree '(1 2 10 20 30 4)) - :test-not #'(lambda (x y) - (not (and (realp x) (realp y) (< x y))))) + :test-not #'(lambda (x y) + (not (and (realp x) (realp y) (< x y))))) (1 2 10 x x 4)) (defharmless subset.test-and-test-not.1 @@ -86,10 +86,10 @@ (let ((i 0) v w x y z) (values (subst (progn (setf v (incf i)) 'b) - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) - :key (progn (setf y (incf i)) #'identity) - :test (progn (setf z (incf i)) #'eql)) + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) + :key (progn (setf y (incf i)) #'identity) + :test (progn (setf z (incf i)) #'eql)) i v w x y z)) ((10 b . b) b b c ((b)) z) 5 1 2 3 4 5) @@ -98,11 +98,11 @@ (let ((i 0) v w x y z) (values (subst (progn (setf v (incf i)) 'b) - (progn (setf w (incf i)) 'a) - (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) - :test-not (progn (setf y (incf i)) (complement #'eql)) - :key (progn (setf z (incf i)) #'identity) - ) + (progn (setf w (incf i)) 'a) + (progn (setf x (incf i)) (copy-tree '((10 a . a) a b c ((a)) z))) + :test-not (progn (setf y (incf i)) (complement #'eql)) + :key (progn (setf z (incf i)) #'identity) + ) i v w x y z)) ((10 b . b) b b c ((b)) z) 5 1 2 3 4 5) @@ -131,7 +131,7 @@ (deftest subst.allow-other-keys.5 (subst 'a 'b (list 'a 'b 'c) :allow-other-keys t :allow-other-keys nil - :bad t) + :bad t) (a a c)) (deftest subst.keywords.6 diff --git a/ansi-tests/substitute-if-not.lsp b/ansi-tests/substitute-if-not.lsp index 484869cc..5b7341a3 100644 --- a/ansi-tests/substitute-if-not.lsp +++ b/ansi-tests/substitute-if-not.lsp @@ -75,52 +75,52 @@ (deftest substitute-if-not-list.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-not-list.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :from-end t))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-not-list.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) :initial-element 'a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-if-not-list.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c :from-end t))) - (and (equal orig x) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))))) t) ;;; Tests on vectors @@ -195,91 +195,91 @@ (deftest substitute-if-not-vector.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-not-vector.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-not-vector.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 (+ i c)) :initial-element 'a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-if-not-vector.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array (- j c) :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if-not 'x (is-not-eql-p 'a) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))))) t) (deftest substitute-if-not-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if-not 'z (is-not-eql-p 'a) x))) + :fill-pointer 5)) + (result (substitute-if-not 'z (is-not-eql-p 'a) x))) result) #(z b z c b)) (deftest substitute-if-not-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if-not 'z (is-not-eql-p 'a) x :from-end t))) + :fill-pointer 5)) + (result (substitute-if-not 'z (is-not-eql-p 'a) x :from-end t))) result) #(z b z c b)) (deftest substitute-if-not-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if-not 'z (is-not-eql-p 'a) x :count 1))) + :fill-pointer 5)) + (result (substitute-if-not 'z (is-not-eql-p 'a) x :count 1))) result) #(z b a c b)) (deftest substitute-if-not-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if-not 'z (is-not-eql-p 'a) x - :from-end t :count 1))) + :fill-pointer 5)) + (result (substitute-if-not 'z (is-not-eql-p 'a) x + :from-end t :count 1))) result) #(a b z c b)) (deftest substitute-if-not-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (substitute-if-not 'x (is-not-eql-p 'c) v2 :count 1) v1)) @@ -288,8 +288,8 @@ (deftest substitute-if-not-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (substitute-if-not 'x (is-not-eql-p 'c) v2 :count 1 :from-end t) v1)) @@ -370,84 +370,84 @@ (deftest substitute-if-not-string.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if-not #\x (is-not-eql-p #\a) x :start i :end j))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if-not #\x (is-not-eql-p #\a) x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-if-not-string.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-if-not-string.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 (+ i c)) :initial-element #\a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a)))))))) t) (deftest substitute-if-not-string.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array (- j c) :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if-not #\x (is-not-eql-p #\a) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))))) t) (deftest substitute-if-not-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if-not #\z (is-not-eql-p #\a) x))) + :fill-pointer 5 :element-type 'character)) + (result (substitute-if-not #\z (is-not-eql-p #\a) x))) result) "zbzcb") (deftest substitute-if-not-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if-not #\z (is-not-eql-p #\a) x :from-end t))) + :fill-pointer 5 :element-type 'character)) + (result (substitute-if-not #\z (is-not-eql-p #\a) x :from-end t))) result) "zbzcb") (deftest substitute-if-not-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if-not #\z (is-not-eql-p #\a) x :count 1))) + :fill-pointer 5 :element-type 'character)) + (result (substitute-if-not #\z (is-not-eql-p #\a) x :count 1))) result) "zbacb") (deftest substitute-if-not-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if-not #\z (is-not-eql-p #\a) x - :from-end t :count 1))) + :fill-pointer 5 :element-type 'character)) + (result (substitute-if-not #\z (is-not-eql-p #\a) x + :from-end t :count 1))) result) "abzcb") @@ -457,235 +457,235 @@ (deftest substitute-if-not-bitstring.1 (let* ((orig #*) - (x (copy-seq orig)) - (result (substitute-if-not 0 (is-not-eql-p 1) x))) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eql-p 1) x))) (and (equalp orig x) - result)) + result)) #*) (deftest substitute-if-not-bitstring.2 (let* ((orig #*) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x))) (and (equalp orig x) - result)) + result)) #*) (deftest substitute-if-not-bitstring.3 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 0 (is-not-eql-p 1) x))) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eql-p 1) x))) (and (equalp orig x) - result)) + result)) #*000000) (deftest substitute-if-not-bitstring.4 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x))) (and (equalp orig x) - result)) + result)) #*111111) (deftest substitute-if-not-bitstring.5 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :start 1))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :start 1))) (and (equalp orig x) - result)) + result)) #*011111) - + (deftest substitute-if-not-bitstring.6 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 0 (is-not-eql-p 1) x :start 2 :end nil))) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eql-p 1) x :start 2 :end nil))) (and (equalp orig x) - result)) + result)) #*010000) (deftest substitute-if-not-bitstring.7 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :end 4))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :end 4))) (and (equalp orig x) - result)) + result)) #*111101) - + (deftest substitute-if-not-bitstring.8 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 0 (is-not-eql-p 1) x :end nil))) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eql-p 1) x :end nil))) (and (equalp orig x) - result)) + result)) #*000000) (deftest substitute-if-not-bitstring.9 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 0 (is-not-eql-p 1) x :end 3))) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eql-p 1) x :end 3))) (and (equalp orig x) - result)) + result)) #*000101) (deftest substitute-if-not-bitstring.10 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 0 (is-not-eql-p 1) x :start 2 :end 4))) + (x (copy-seq orig)) + (result (substitute-if-not 0 (is-not-eql-p 1) x :start 2 :end 4))) (and (equalp orig x) - result)) + result)) #*010001) (deftest substitute-if-not-bitstring.11 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :start 2 :end 4))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :start 2 :end 4))) (and (equalp orig x) - result)) + result)) #*011101) (deftest substitute-if-not-bitstring.12 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count 1))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count 1))) (and (equalp orig x) - result)) + result)) #*110101) (deftest substitute-if-not-bitstring.13 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count 0))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count 0))) (and (equalp orig x) - result)) + result)) #*010101) (deftest substitute-if-not-bitstring.14 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count -1))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count -1))) (and (equalp orig x) - result)) + result)) #*010101) (deftest substitute-if-not-bitstring.15 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count 1 :from-end t))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count 1 :from-end t))) (and (equalp orig x) - result)) + result)) #*010111) (deftest substitute-if-not-bitstring.16 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count 0 :from-end t))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count 0 :from-end t))) (and (equalp orig x) - result)) + result)) #*010101) (deftest substitute-if-not-bitstring.17 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count -1 :from-end t))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count -1 :from-end t))) (and (equalp orig x) - result)) + result)) #*010101) (deftest substitute-if-not-bitstring.18 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count nil))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count nil))) (and (equalp orig x) - result)) + result)) #*111111) (deftest substitute-if-not-bitstring.19 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if-not 1 (complement #'zerop) x :count nil :from-end t))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (complement #'zerop) x :count nil :from-end t))) (and (equalp orig x) - result)) + result)) #*111111) (deftest substitute-if-not-bitstring.20 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*0000000000) - (x (copy-seq orig)) - (y (substitute-if-not 1 (complement #'zerop) x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-bit-vector - (make-list i :initial-element 0) - (make-list c :initial-element 1) - (make-list (- 10 (+ i c)) :initial-element 0)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (substitute-if-not 1 (complement #'zerop) x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0)))))))) t) (deftest substitute-if-not-bitstring.21 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*1111111111) - (x (copy-seq orig)) - (y (substitute-if-not 0 (is-not-eql-p 1) x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-bit-vector - (make-list (- j c) :initial-element 1) - (make-list c :initial-element 0) - (make-list (- 10 j) :initial-element 1)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (substitute-if-not 0 (is-not-eql-p 1) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1)))))))) t) ;;; More tests (deftest substitute-if-not-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car))) + (x (copy-seq orig)) + (result (substitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car))) (and (equal orig x) - result)) + result)) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-if-not-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if-not '(a 10) (is-not-eql-p 'a) x - :key #'car :start 1 :end 5))) + (x (copy-seq orig)) + (result (substitute-if-not '(a 10) (is-not-eql-p 'a) x + :key #'car :start 1 :end 5))) (and (equal orig x) - result)) + result)) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-if-not-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car))) + (x (copy-seq orig)) + (result (substitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car))) (and (equalp orig x) - result)) + result)) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - + (deftest substitute-if-not-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car :start 1 :end 5))) + (x (copy-seq orig)) + (result (substitute-if-not '(a 10) (is-not-eql-p 'a) x :key #'car :start 1 :end 5))) (and (equalp orig x) - result)) + result)) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-if-not-string.24 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute-if-not #\a (is-not-eql-p #\1) x :key #'nextdigit))) + (x (copy-seq orig)) + (result (substitute-if-not #\a (is-not-eql-p #\1) x :key #'nextdigit))) (and (equalp orig x) - result)) + result)) "a1a2342a15") - + (deftest substitute-if-not-string.25 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute-if-not #\a (is-not-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) + (x (copy-seq orig)) + (result (substitute-if-not #\a (is-not-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) - result)) + result)) "01a2342015") (deftest substitute-if-not-string.26 @@ -699,45 +699,45 @@ (deftest substitute-if-not-bitstring.26 (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute-if-not 1 (is-not-eql-p 1) x :key #'1+))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (is-not-eql-p 1) x :key #'1+))) (and (equalp orig x) - result)) + result)) #*11111111111111111) - + (deftest substitute-if-not-bitstring.27 (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute-if-not 1 (is-not-eql-p 1) x :key #'1+ :start 1 :end 10))) + (x (copy-seq orig)) + (result (substitute-if-not 1 (is-not-eql-p 1) x :key #'1+ :start 1 :end 10))) (and (equalp orig x) - result)) + result)) #*01111111111010110) (deftest substitute-if-not-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if-not 1 #'onep x))) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if-not 1 #'onep x))) result) #*11111) (deftest substitute-if-not-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if-not 1 #'onep x :from-end t))) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if-not 1 #'onep x :from-end t))) result) #*11111) (deftest substitute-if-not-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if-not 1 #'onep x :count 1))) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if-not 1 #'onep x :count 1))) result) #*11011) (deftest substitute-if-not-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if-not 1 #'onep x :from-end t :count 1))) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if-not 1 #'onep x :from-end t :count 1))) result) #*01111) @@ -779,37 +779,37 @@ (deftest substitute-if-not.allow-other-keys.1 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :allow-other-keys t :bad t) + :allow-other-keys t :bad t) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.2 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :bad t :allow-other-keys t) + :bad t :allow-other-keys t) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.3 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :allow-other-keys nil :bad t) + :allow-other-keys nil :bad t) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.4 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :bad t - :allow-other-keys t :allow-other-keys nil) + :allow-other-keys t :allow-other-keys nil) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.5 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :allow-other-keys t :key #'1-) + :allow-other-keys t :key #'1-) (1 a a a 1 a a)) (deftest substitute-if-not.keywords.6 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) - :key #'1- :key #'identity) + :key #'1- :key #'identity) (1 a a a 1 a a)) (deftest substitute-if-not.allow-other-keys.7 (substitute-if-not 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :bad t :allow-other-keys nil) + :bad t :allow-other-keys nil) (a a 0 a a 0 a)) (deftest substitute-if-not.allow-other-keys.8 @@ -847,7 +847,7 @@ (deftest substitute-if-not.error.5 (signals-error (substitute-if-not 'a #'null nil - 'bad t :allow-other-keys nil) program-error) + 'bad t :allow-other-keys nil) program-error) t) (deftest substitute-if-not.error.6 @@ -868,14 +868,14 @@ (deftest substitute-if-not.error.10 (signals-error (substitute-if-not 'a #'identity (list 'a 'b 'c) - :key #'car) - type-error) + :key #'car) + type-error) t) (deftest substitute-if-not.error.11 (signals-error (substitute-if-not 'a #'identity (list 'a 'b 'c) - :key #'cons) - program-error) + :key #'cons) + program-error) t) (deftest substitute-if-not.error.12 diff --git a/ansi-tests/substitute-if.lsp b/ansi-tests/substitute-if.lsp index 8dd45171..d70f9d33 100644 --- a/ansi-tests/substitute-if.lsp +++ b/ansi-tests/substitute-if.lsp @@ -75,52 +75,52 @@ (deftest substitute-if-list.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x :start i :end j))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eql-p 'a) x :start i :end j))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-list.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-list.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :count c))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) :initial-element 'a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :count c))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-if-list.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :count c :from-end t))) - (and (equal orig x) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :count c :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))))) t) @@ -199,103 +199,103 @@ (deftest substitute-if-vector.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x :start i :end j))) - (and (equalp orig x) - (equalp y - (concatenate - 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eql-p 'a) x :start i :end j))) + (and (equalp orig x) + (equalp y + (concatenate + 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-vector.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t))) - (and (equalp orig x) - (equalp y - (concatenate - 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eql-p 'a) x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y + (concatenate + 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-if-vector.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x - :start i :end j :count c))) - (and (equalp orig x) - (equalp - y (concatenate - 'simple-vector - (make-array i :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 (+ i c)) - :initial-element 'a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eql-p 'a) x + :start i :end j :count c))) + (and (equalp orig x) + (equalp + y (concatenate + 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) + :initial-element 'a)))))))) t) (deftest substitute-if-vector.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute-if 'x (is-eql-p 'a) x - :start i :end j :count c - :from-end t))) - (and (equalp orig x) - (equalp - y - (concatenate - 'simple-vector - (make-array (- j c) :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute-if 'x (is-eql-p 'a) x + :start i :end j :count c + :from-end t))) + (and (equalp orig x) + (equalp + y + (concatenate + 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))))) t) (deftest substitute-if-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if 'z (is-eql-p 'a) x))) + :fill-pointer 5)) + (result (substitute-if 'z (is-eql-p 'a) x))) result) #(z b z c b)) (deftest substitute-if-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if 'z (is-eql-p 'a) x :from-end t))) + :fill-pointer 5)) + (result (substitute-if 'z (is-eql-p 'a) x :from-end t))) result) #(z b z c b)) (deftest substitute-if-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if 'z (is-eql-p 'a) x :count 1))) + :fill-pointer 5)) + (result (substitute-if 'z (is-eql-p 'a) x :count 1))) result) #(z b a c b)) (deftest substitute-if-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute-if 'z (is-eql-p 'a) x :from-end t :count 1))) + :fill-pointer 5)) + (result (substitute-if 'z (is-eql-p 'a) x :from-end t :count 1))) result) #(a b z c b)) (deftest substitute-if-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (substitute-if 'x (is-eql-p 'c) v2 :count 1) v1)) @@ -304,8 +304,8 @@ (deftest substitute-if-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (substitute-if 'x (is-eql-p 'c) v2 :count 1 :from-end t) v1)) @@ -384,95 +384,95 @@ (deftest substitute-if-string.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if #\x (is-eql-p #\a) x :start i :end j))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if #\x (is-eql-p #\a) x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-if-string.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if #\x (is-eql-p #\a) x - :start i :end j :from-end t))) - (and (equalp orig x) - (equalp y - (concatenate - 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if #\x (is-eql-p #\a) x + :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y + (concatenate + 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-if-string.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if #\x (is-eql-p #\a) x - :start i :end j :count c))) - (and (equalp orig x) - (equalp y - (concatenate - 'simple-string - (make-array i :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 (+ i c)) - :initial-element #\a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if #\x (is-eql-p #\a) x + :start i :end j :count c))) + (and (equalp orig x) + (equalp y + (concatenate + 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) + :initial-element #\a)))))))) t) (deftest substitute-if-string.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute-if #\x (is-eql-p #\a) x - :start i :end j :count c - :from-end t))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-string - (make-array (- j c) :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 j) - :initial-element #\a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute-if #\x (is-eql-p #\a) x + :start i :end j :count c + :from-end t))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) + :initial-element #\a)))))))) t) (deftest substitute-if-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if #\z (is-eql-p #\a) x))) + :fill-pointer 5 :element-type 'character)) + (result (substitute-if #\z (is-eql-p #\a) x))) result) "zbzcb") (deftest substitute-if-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if #\z (is-eql-p #\a) x :from-end t))) + :fill-pointer 5 :element-type 'character)) + (result (substitute-if #\z (is-eql-p #\a) x :from-end t))) result) "zbzcb") (deftest substitute-if-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if #\z (is-eql-p #\a) x :count 1))) + :fill-pointer 5 :element-type 'character)) + (result (substitute-if #\z (is-eql-p #\a) x :count 1))) result) "zbacb") (deftest substitute-if-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute-if #\z (is-eql-p #\a) x :from-end t :count 1))) + :fill-pointer 5 :element-type 'character)) + (result (substitute-if #\z (is-eql-p #\a) x :from-end t :count 1))) result) "abzcb") @@ -480,235 +480,235 @@ (deftest substitute-if-bit-vector.1 (let* ((orig #*) - (x (copy-seq orig)) - (result (substitute-if 0 (is-eql-p 1) x))) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eql-p 1) x))) (and (equalp orig x) - result)) + result)) #*) (deftest substitute-if-bit-vector.2 (let* ((orig #*) - (x (copy-seq orig)) - (result (substitute-if 1 'zerop x))) + (x (copy-seq orig)) + (result (substitute-if 1 'zerop x))) (and (equalp orig x) - result)) + result)) #*) (deftest substitute-if-bit-vector.3 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 0 (is-eql-p 1) x))) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eql-p 1) x))) (and (equalp orig x) - result)) + result)) #*000000) (deftest substitute-if-bit-vector.4 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x))) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x))) (and (equalp orig x) - result)) + result)) #*111111) (deftest substitute-if-bit-vector.5 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :start 1))) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :start 1))) (and (equalp orig x) - result)) + result)) #*011111) - + (deftest substitute-if-bit-vector.6 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 0 (is-eql-p 1) x :start 2 :end nil))) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eql-p 1) x :start 2 :end nil))) (and (equalp orig x) - result)) + result)) #*010000) (deftest substitute-if-bit-vector.7 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :end 4))) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :end 4))) (and (equalp orig x) - result)) + result)) #*111101) - + (deftest substitute-if-bit-vector.8 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 0 (is-eql-p 1) x :end nil))) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eql-p 1) x :end nil))) (and (equalp orig x) - result)) + result)) #*000000) (deftest substitute-if-bit-vector.9 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 0 (is-eql-p 1) x :end 3))) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eql-p 1) x :end 3))) (and (equalp orig x) - result)) + result)) #*000101) (deftest substitute-if-bit-vector.10 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 0 (is-eql-p 1) x :start 2 :end 4))) + (x (copy-seq orig)) + (result (substitute-if 0 (is-eql-p 1) x :start 2 :end 4))) (and (equalp orig x) - result)) + result)) #*010001) (deftest substitute-if-bit-vector.11 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :start 2 :end 4))) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :start 2 :end 4))) (and (equalp orig x) - result)) + result)) #*011101) (deftest substitute-if-bit-vector.12 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count 1))) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count 1))) (and (equalp orig x) - result)) + result)) #*110101) (deftest substitute-if-bit-vector.13 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count 0))) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count 0))) (and (equalp orig x) - result)) + result)) #*010101) (deftest substitute-if-bit-vector.14 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count -1))) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count -1))) (and (equalp orig x) - result)) + result)) #*010101) (deftest substitute-if-bit-vector.15 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count 1 :from-end t))) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count 1 :from-end t))) (and (equalp orig x) - result)) + result)) #*010111) (deftest substitute-if-bit-vector.16 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count 0 :from-end t))) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count 0 :from-end t))) (and (equalp orig x) - result)) + result)) #*010101) (deftest substitute-if-bit-vector.17 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count -1 :from-end t))) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count -1 :from-end t))) (and (equalp orig x) - result)) + result)) #*010101) (deftest substitute-if-bit-vector.18 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count nil))) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count nil))) (and (equalp orig x) - result)) + result)) #*111111) (deftest substitute-if-bit-vector.19 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute-if 1 #'zerop x :count nil :from-end t))) + (x (copy-seq orig)) + (result (substitute-if 1 #'zerop x :count nil :from-end t))) (and (equalp orig x) - result)) + result)) #*111111) (deftest substitute-if-bit-vector.20 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*0000000000) - (x (copy-seq orig)) - (y (substitute-if 1 #'zerop x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-bit-vector - (make-list i :initial-element 0) - (make-list c :initial-element 1) - (make-list (- 10 (+ i c)) :initial-element 0)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (substitute-if 1 #'zerop x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0)))))))) t) (deftest substitute-if-bit-vector.21 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*1111111111) - (x (copy-seq orig)) - (y (substitute-if 0 (is-eql-p 1) x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-bit-vector - (make-list (- j c) :initial-element 1) - (make-list c :initial-element 0) - (make-list (- 10 j) :initial-element 1)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (substitute-if 0 (is-eql-p 1) x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1)))))))) t) ;;; More tests (deftest substitute-if-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if '(a 10) (is-eql-p 'a) x :key #'car))) + (x (copy-seq orig)) + (result (substitute-if '(a 10) (is-eql-p 'a) x :key #'car))) (and (equal orig x) - result)) + result)) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-if-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if '(a 10) (is-eql-p 'a) x - :key #'car :start 1 :end 5))) + (x (copy-seq orig)) + (result (substitute-if '(a 10) (is-eql-p 'a) x + :key #'car :start 1 :end 5))) (and (equal orig x) - result)) + result)) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-if-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if '(a 10) (is-eql-p 'a) x :key #'car))) + (x (copy-seq orig)) + (result (substitute-if '(a 10) (is-eql-p 'a) x :key #'car))) (and (equalp orig x) - result)) + result)) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - + (deftest substitute-if-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute-if '(a 10) (is-eql-p 'a) x :key #'car :start 1 :end 5))) + (x (copy-seq orig)) + (result (substitute-if '(a 10) (is-eql-p 'a) x :key #'car :start 1 :end 5))) (and (equalp orig x) - result)) + result)) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-if-string.24 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute-if #\a (is-eql-p #\1) x :key #'nextdigit))) + (x (copy-seq orig)) + (result (substitute-if #\a (is-eql-p #\1) x :key #'nextdigit))) (and (equalp orig x) - result)) + result)) "a1a2342a15") - + (deftest substitute-if-string.25 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute-if #\a (is-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) + (x (copy-seq orig)) + (result (substitute-if #\a (is-eql-p #\1) x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) - result)) + result)) "01a2342015") (deftest substitute-if-string.26 @@ -724,45 +724,45 @@ (deftest substitute-if-bit-vector.22 (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute-if 1 (is-eql-p 1) x :key #'1+))) + (x (copy-seq orig)) + (result (substitute-if 1 (is-eql-p 1) x :key #'1+))) (and (equalp orig x) - result)) + result)) #*11111111111111111) - + (deftest substitute-if-bit-vector.23 (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute-if 1 (is-eql-p 1) x :key #'1+ :start 1 :end 10))) + (x (copy-seq orig)) + (result (substitute-if 1 (is-eql-p 1) x :key #'1+ :start 1 :end 10))) (and (equalp orig x) - result)) + result)) #*01111111111010110) (deftest substitute-if-bit-vector.24 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if 1 #'zerop x))) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if 1 #'zerop x))) result) #*11111) (deftest substitute-if-bit-vector.25 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if 1 #'zerop x :from-end t))) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if 1 #'zerop x :from-end t))) result) #*11111) (deftest substitute-if-bit-vector.26 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if 1 #'zerop x :count 1))) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if 1 #'zerop x :count 1))) result) #*11011) (deftest substitute-if-bit-vector.27 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute-if 1 #'zerop x :from-end t :count 1))) + :fill-pointer 5 :element-type 'bit)) + (result (substitute-if 1 #'zerop x :from-end t :count 1))) result) #*01111) @@ -814,17 +814,17 @@ (deftest substitute-if.allow-other-keys.3 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :allow-other-keys nil :bad t) + :allow-other-keys nil :bad t) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.4 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :bad t - :allow-other-keys t :allow-other-keys nil) + :allow-other-keys t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.5 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) - :allow-other-keys t :key #'1-) + :allow-other-keys t :key #'1-) (a 2 0 3 a 0 3)) (deftest substitute-if.keywords.6 @@ -833,7 +833,7 @@ (deftest substitute-if.allow-other-keys.7 (substitute-if 'a #'zerop (list 1 2 0 3 1 0 3) :allow-other-keys t - :bad t :allow-other-keys nil) + :bad t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest substitute-if.allow-other-keys.8 @@ -846,7 +846,7 @@ (def-fold-test substitute-if.fold.2 (substitute-if 'z 'null #(a nil b))) (def-fold-test substitute-if.fold.3 (substitute-if 0 'plusp #*100110)) (def-fold-test substitute-if.fold.4 (substitute-if #\x 'digit-char-p - "asdf8234n123f")) + "asdf8234n123f")) ;;; Error cases @@ -868,7 +868,7 @@ (deftest substitute-if.error.5 (signals-error (substitute-if 'a #'null nil 'bad t :allow-other-keys nil) - program-error) + program-error) t) (deftest substitute-if.error.6 @@ -889,14 +889,14 @@ (deftest substitute-if.error.10 (signals-error (substitute-if 'a #'identity (list 'a 'b 'c) - :key #'car) - type-error) + :key #'car) + type-error) t) (deftest substitute-if.error.11 (signals-error (substitute-if 'a #'identity (list 'a 'b 'c) - :key #'cons) - program-error) + :key #'cons) + program-error) t) (deftest substitute-if.error.12 diff --git a/ansi-tests/substitute.lsp b/ansi-tests/substitute.lsp index d7fef60b..483dc91e 100644 --- a/ansi-tests/substitute.lsp +++ b/ansi-tests/substitute.lsp @@ -75,133 +75,133 @@ (deftest substitute-list.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-list.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j :from-end t))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list (- j i) :initial-element 'x) - (make-list (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list (- j i) :initial-element 'x) + (make-list (- 10 j) :initial-element 'a))))))) t) (deftest substitute-list.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j :count c))) - (and (equal orig x) - (equal y (nconc (make-list i :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 (+ i c)) :initial-element 'a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :count c))) + (and (equal orig x) + (equal y (nconc (make-list i :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-list.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig '(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j :count c :from-end t))) - (and (equal orig x) - (equal y (nconc (make-list (- j c) :initial-element 'a) - (make-list c :initial-element 'x) - (make-list (- 10 j) :initial-element 'a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig '(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :count c :from-end t))) + (and (equal orig x) + (equal y (nconc (make-list (- j c) :initial-element 'a) + (make-list c :initial-element 'x) + (make-list (- 10 j) :initial-element 'a)))))))) t) (deftest substitute-list.19 (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) + (x (copy-seq orig)) + (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) (and (equal orig x) - result)) + result)) (1 2 x x x x x 8 9)) (deftest substitute-list.20 (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) + (x (copy-seq orig)) + (c -4) + (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) (and (equal orig x) - result)) + result)) (1 2 x 4 5 6 7 8 9)) (deftest substitute-list.21 (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) - :from-end t))) + (x (copy-seq orig)) + (c 5) + (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) + :from-end t))) (and (equal orig x) - result)) + result)) (1 2 3 4 5 6 7 x 9)) (deftest substitute-list.22 (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) + (x (copy-seq orig)) + (c -4) + (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) (and (equal orig x) - result)) + result)) (1 2 x 4 5 6 7 8 9)) (deftest substitute-list.23 (let* ((orig '(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) - :from-end t))) + (x (copy-seq orig)) + (c 5) + (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) + :from-end t))) (and (equal orig x) - result)) + result)) (1 2 3 4 5 6 7 x 9)) (deftest substitute-list.24 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car))) (and (equal orig x) - result)) + result)) ((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) (deftest substitute-list.25 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) (and (equal orig x) - result)) + result)) ((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-list.26 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car :test (complement #'eql)))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :test (complement #'eql)))) (and (equal orig x) - result)) + result)) ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest substitute-list.27 (let* ((orig '((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car :test-not #'eql))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :test-not #'eql))) (and (equal orig x) - result)) - ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) + result)) + ((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) ;;; Tests on vectors @@ -275,170 +275,170 @@ (deftest substitute-vector.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-vector.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array (- j i) :initial-element 'x) - (make-array (- 10 j) :initial-element 'a))))))) + (loop for j from i to 10 always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array (- j i) :initial-element 'x) + (make-array (- 10 j) :initial-element 'a))))))) t) (deftest substitute-vector.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array i :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 (+ i c)) :initial-element 'a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array i :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 (+ i c)) :initial-element 'a)))))))) t) (deftest substitute-vector.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #(a a a a a a a a a a)) - (x (copy-seq orig)) - (y (substitute 'x 'a x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-vector - (make-array (- j c) :initial-element 'a) - (make-array c :initial-element 'x) - (make-array (- 10 j) :initial-element 'a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #(a a a a a a a a a a)) + (x (copy-seq orig)) + (y (substitute 'x 'a x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-vector + (make-array (- j c) :initial-element 'a) + (make-array c :initial-element 'x) + (make-array (- 10 j) :initial-element 'a)))))))) t) (deftest substitute-vector.19 (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) + (x (copy-seq orig)) + (result (substitute 'x 5 x :test #'(lambda (a b) (<= (abs (- a b)) 2))))) (and (equalp orig x) - result)) + result)) #(1 2 x x x x x 8 9)) (deftest substitute-vector.20 (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) + (x (copy-seq orig)) + (c -4) + (result (substitute 'x 5 x :test #'(lambda (a b) (incf c 2) (= (+ b c) a))))) (and (equalp orig x) - result)) + result)) #(1 2 x 4 5 6 7 8 9)) (deftest substitute-vector.21 (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) - :from-end t))) + (x (copy-seq orig)) + (c 5) + (result (substitute 'x 9 x :test #'(lambda (a b) (incf c -2) (= (+ b c) a)) + :from-end t))) (and (equalp orig x) - result)) + result)) #(1 2 3 4 5 6 7 x 9)) (deftest substitute-vector.22 (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c -4) - (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) + (x (copy-seq orig)) + (c -4) + (result (substitute 'x 5 x :test-not #'(lambda (a b) (incf c 2) (/= (+ b c) a))))) (and (equalp orig x) - result)) + result)) #(1 2 x 4 5 6 7 8 9)) (deftest substitute-vector.23 (let* ((orig #(1 2 3 4 5 6 7 8 9)) - (x (copy-seq orig)) - (c 5) - (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) - :from-end t))) + (x (copy-seq orig)) + (c 5) + (result (substitute 'x 9 x :test-not #'(lambda (a b) (incf c -2) (/= (+ b c) a)) + :from-end t))) (and (equalp orig x) - result)) + result)) #(1 2 3 4 5 6 7 x 9)) (deftest substitute-vector.24 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car))) (and (equalp orig x) - result)) + result)) #((a 10) (b 2) (a 10) (c 4) (d 5) (a 10) (e 7))) - + (deftest substitute-vector.25 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :start 1 :end 5))) (and (equalp orig x) - result)) + result)) #((a 1) (b 2) (a 10) (c 4) (d 5) (a 6) (e 7))) (deftest substitute-vector.26 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car :test (complement #'eql)))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :test (complement #'eql)))) (and (equalp orig x) - result)) + result)) #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest substitute-vector.27 (let* ((orig #((a 1) (b 2) (a 3) (c 4) (d 5) (a 6) (e 7))) - (x (copy-seq orig)) - (result (substitute '(a 10) 'a x :key #'car :test-not #'eql))) + (x (copy-seq orig)) + (result (substitute '(a 10) 'a x :key #'car :test-not #'eql))) (and (equalp orig x) - result)) + result)) #((a 1) (a 10) (a 3) (a 10) (a 10) (a 6) (a 10))) (deftest substitute-vector.28 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute 'z 'a x))) + :fill-pointer 5)) + (result (substitute 'z 'a x))) result) #(z b z c b)) (deftest substitute-vector.29 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute 'z 'a x :from-end t))) + :fill-pointer 5)) + (result (substitute 'z 'a x :from-end t))) result) #(z b z c b)) (deftest substitute-vector.30 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute 'z 'a x :count 1))) + :fill-pointer 5)) + (result (substitute 'z 'a x :count 1))) result) #(z b a c b)) (deftest substitute-vector.31 (let* ((x (make-array '(10) :initial-contents '(a b a c b a d e a f) - :fill-pointer 5)) - (result (substitute 'z 'a x :from-end t :count 1))) + :fill-pointer 5)) + (result (substitute 'z 'a x :from-end t :count 1))) result) #(a b z c b)) (deftest substitute-vector.32 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (substitute 'x 'c v2 :count 1) v1)) @@ -447,8 +447,8 @@ (deftest substitute-vector.33 (let* ((v1 (copy-seq #(a b c d a b c d a b c d a b c d))) - (v2 (make-array '(8) :displaced-to v1 - :displaced-index-offset 3))) + (v2 (make-array '(8) :displaced-to v1 + :displaced-index-offset 3))) (values (substitute 'x 'c v2 :count 1 :from-end t) v1)) @@ -527,178 +527,178 @@ (deftest substitute-string.15 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute #\x #\a x :start i :end j))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute #\x #\a x :start i :end j))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-string.16 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute #\x #\a x :start i :end j :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array (- j i) :initial-element #\x) - (make-array (- 10 j) :initial-element #\a))))))) + (loop for j from i to 10 always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute #\x #\a x :start i :end j :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array (- j i) :initial-element #\x) + (make-array (- 10 j) :initial-element #\a))))))) t) (deftest substitute-string.17 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute #\x #\a x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array i :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 (+ i c)) :initial-element #\a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute #\x #\a x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array i :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 (+ i c)) :initial-element #\a)))))))) t) (deftest substitute-string.18 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig "aaaaaaaaaa") - (x (copy-seq orig)) - (y (substitute #\x #\a x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate 'simple-string - (make-array (- j c) :initial-element #\a) - (make-array c :initial-element #\x) - (make-array (- 10 j) :initial-element #\a)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig "aaaaaaaaaa") + (x (copy-seq orig)) + (y (substitute #\x #\a x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate 'simple-string + (make-array (- j c) :initial-element #\a) + (make-array c :initial-element #\x) + (make-array (- 10 j) :initial-element #\a)))))))) t) (deftest substitute-string.19 (let* ((orig "123456789") - (x (copy-seq orig)) - (result (substitute #\x #\5 x :test #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (<= (abs (- a b)) 2))))) + (x (copy-seq orig)) + (result (substitute #\x #\5 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (<= (abs (- a b)) 2))))) (and (equalp orig x) - result)) + result)) "12xxxxx89") (deftest substitute-string.20 (let* ((orig "123456789") - (x (copy-seq orig)) - (c -4) - (result (substitute #\x #\5 x :test #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c 2) (= (+ b c) a))))) + (x (copy-seq orig)) + (c -4) + (result (substitute #\x #\5 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c 2) (= (+ b c) a))))) (and (equalp orig x) - result)) + result)) "12x456789") (deftest substitute-string.21 (let* ((orig "123456789") - (x (copy-seq orig)) - (c 5) - (result (substitute #\x #\9 x :test #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c -2) (= (+ b c) a)) - :from-end t))) + (x (copy-seq orig)) + (c 5) + (result (substitute #\x #\9 x :test #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c -2) (= (+ b c) a)) + :from-end t))) (and (equalp orig x) - result)) + result)) "1234567x9") (deftest substitute-string.22 (let* ((orig "123456789") - (x (copy-seq orig)) - (c -4) - (result (substitute #\x #\5 x :test-not #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c 2) (/= (+ b c) a))))) + (x (copy-seq orig)) + (c -4) + (result (substitute #\x #\5 x :test-not #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c 2) (/= (+ b c) a))))) (and (equalp orig x) - result)) + result)) "12x456789") (deftest substitute-string.23 (let* ((orig "123456789") - (x (copy-seq orig)) - (c 5) - (result (substitute #\x #\9 x :test-not #'(lambda (a b) - (setq a (read-from-string (string a))) - (setq b (read-from-string (string b))) - (incf c -2) (/= (+ b c) a)) - :from-end t))) + (x (copy-seq orig)) + (c 5) + (result (substitute #\x #\9 x :test-not #'(lambda (a b) + (setq a (read-from-string (string a))) + (setq b (read-from-string (string b))) + (incf c -2) (/= (+ b c) a)) + :from-end t))) (and (equalp orig x) - result)) + result)) "1234567x9") (deftest substitute-string.24 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute #\a #\1 x :key #'nextdigit))) + (x (copy-seq orig)) + (result (substitute #\a #\1 x :key #'nextdigit))) (and (equalp orig x) - result)) + result)) "a1a2342a15") - + (deftest substitute-string.25 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) + (x (copy-seq orig)) + (result (substitute #\a #\1 x :key #'nextdigit :start 1 :end 6))) (and (equalp orig x) - result)) + result)) "01a2342015") (deftest substitute-string.26 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute #\a #\1 x :key #'nextdigit :test (complement #'eql)))) + (x (copy-seq orig)) + (result (substitute #\a #\1 x :key #'nextdigit :test (complement #'eql)))) (and (equalp orig x) - result)) + result)) "0a0aaaa0aa") (deftest substitute-string.27 (let* ((orig "0102342015") - (x (copy-seq orig)) - (result (substitute #\a #\1 x :key #'nextdigit :test-not #'eql))) + (x (copy-seq orig)) + (result (substitute #\a #\1 x :key #'nextdigit :test-not #'eql))) (and (equalp orig x) - result)) + result)) "0a0aaaa0aa") (deftest substitute-string.28 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute #\z #\a x))) + :fill-pointer 5 :element-type 'character)) + (result (substitute #\z #\a x))) result) "zbzcb") (deftest substitute-string.29 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute #\z #\a x :from-end t))) + :fill-pointer 5 :element-type 'character)) + (result (substitute #\z #\a x :from-end t))) result) "zbzcb") (deftest substitute-string.30 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute #\z #\a x :count 1))) + :fill-pointer 5 :element-type 'character)) + (result (substitute #\z #\a x :count 1))) result) "zbacb") (deftest substitute-string.31 (let* ((x (make-array '(10) :initial-contents "abacbadeaf" - :fill-pointer 5 :element-type 'character)) - (result (substitute #\z #\a x :from-end t :count 1))) + :fill-pointer 5 :element-type 'character)) + (result (substitute #\z #\a x :from-end t :count 1))) result) "abzcb") @@ -715,283 +715,283 @@ (deftest substitute-bit-vector.1 (let* ((orig #*) - (x (copy-seq orig)) - (result (substitute 0 1 x))) + (x (copy-seq orig)) + (result (substitute 0 1 x))) (and (equalp orig x) - result)) + result)) #*) (deftest substitute-bit-vector.2 (let* ((orig #*) - (x (copy-seq orig)) - (result (substitute 1 0 x))) + (x (copy-seq orig)) + (result (substitute 1 0 x))) (and (equalp orig x) - result)) + result)) #*) (deftest substitute-bit-vector.3 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 0 1 x))) + (x (copy-seq orig)) + (result (substitute 0 1 x))) (and (equalp orig x) - result)) + result)) #*000000) (deftest substitute-bit-vector.4 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x))) + (x (copy-seq orig)) + (result (substitute 1 0 x))) (and (equalp orig x) - result)) + result)) #*111111) (deftest substitute-bit-vector.5 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :start 1))) + (x (copy-seq orig)) + (result (substitute 1 0 x :start 1))) (and (equalp orig x) - result)) + result)) #*011111) - + (deftest substitute-bit-vector.6 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 0 1 x :start 2 :end nil))) + (x (copy-seq orig)) + (result (substitute 0 1 x :start 2 :end nil))) (and (equalp orig x) - result)) + result)) #*010000) (deftest substitute-bit-vector.7 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :end 4))) + (x (copy-seq orig)) + (result (substitute 1 0 x :end 4))) (and (equalp orig x) - result)) + result)) #*111101) - + (deftest substitute-bit-vector.8 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 0 1 x :end nil))) + (x (copy-seq orig)) + (result (substitute 0 1 x :end nil))) (and (equalp orig x) - result)) + result)) #*000000) (deftest substitute-bit-vector.9 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 0 1 x :end 3))) + (x (copy-seq orig)) + (result (substitute 0 1 x :end 3))) (and (equalp orig x) - result)) + result)) #*000101) (deftest substitute-bit-vector.10 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 0 1 x :start 2 :end 4))) + (x (copy-seq orig)) + (result (substitute 0 1 x :start 2 :end 4))) (and (equalp orig x) - result)) + result)) #*010001) (deftest substitute-bit-vector.11 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :start 2 :end 4))) + (x (copy-seq orig)) + (result (substitute 1 0 x :start 2 :end 4))) (and (equalp orig x) - result)) + result)) #*011101) (deftest substitute-bit-vector.12 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count 1))) + (x (copy-seq orig)) + (result (substitute 1 0 x :count 1))) (and (equalp orig x) - result)) + result)) #*110101) (deftest substitute-bit-vector.13 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count 0))) + (x (copy-seq orig)) + (result (substitute 1 0 x :count 0))) (and (equalp orig x) - result)) + result)) #*010101) (deftest substitute-bit-vector.14 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count -1))) + (x (copy-seq orig)) + (result (substitute 1 0 x :count -1))) (and (equalp orig x) - result)) + result)) #*010101) (deftest substitute-bit-vector.15 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count 1 :from-end t))) + (x (copy-seq orig)) + (result (substitute 1 0 x :count 1 :from-end t))) (and (equalp orig x) - result)) + result)) #*010111) (deftest substitute-bit-vector.16 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count 0 :from-end t))) + (x (copy-seq orig)) + (result (substitute 1 0 x :count 0 :from-end t))) (and (equalp orig x) - result)) + result)) #*010101) (deftest substitute-bit-vector.17 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count -1 :from-end t))) + (x (copy-seq orig)) + (result (substitute 1 0 x :count -1 :from-end t))) (and (equalp orig x) - result)) + result)) #*010101) (deftest substitute-bit-vector.18 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count nil))) + (x (copy-seq orig)) + (result (substitute 1 0 x :count nil))) (and (equalp orig x) - result)) + result)) #*111111) (deftest substitute-bit-vector.19 (let* ((orig #*010101) - (x (copy-seq orig)) - (result (substitute 1 0 x :count nil :from-end t))) + (x (copy-seq orig)) + (result (substitute 1 0 x :count nil :from-end t))) (and (equalp orig x) - result)) + result)) #*111111) (deftest substitute-bit-vector.20 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*0000000000) - (x (copy-seq orig)) - (y (substitute 1 0 x :start i :end j :count c))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-bit-vector - (make-list i :initial-element 0) - (make-list c :initial-element 1) - (make-list (- 10 (+ i c)) :initial-element 0)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*0000000000) + (x (copy-seq orig)) + (y (substitute 1 0 x :start i :end j :count c))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list i :initial-element 0) + (make-list c :initial-element 1) + (make-list (- 10 (+ i c)) :initial-element 0)))))))) t) (deftest substitute-bit-vector.21 (loop for i from 0 to 9 always - (loop for j from i to 10 always - (loop for c from 0 to (- j i) always - (let* ((orig #*1111111111) - (x (copy-seq orig)) - (y (substitute 0 1 x :start i :end j :count c :from-end t))) - (and (equalp orig x) - (equalp y (concatenate - 'simple-bit-vector - (make-list (- j c) :initial-element 1) - (make-list c :initial-element 0) - (make-list (- 10 j) :initial-element 1)))))))) + (loop for j from i to 10 always + (loop for c from 0 to (- j i) always + (let* ((orig #*1111111111) + (x (copy-seq orig)) + (y (substitute 0 1 x :start i :end j :count c :from-end t))) + (and (equalp orig x) + (equalp y (concatenate + 'simple-bit-vector + (make-list (- j c) :initial-element 1) + (make-list c :initial-element 0) + (make-list (- 10 j) :initial-element 1)))))))) t) (deftest substitute-bit-vector.22 (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) + (x (copy-seq orig)) + (c 0) + (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b)))))) (and (equalp orig x) - result)) + result)) #*0111110101) (deftest substitute-bit-vector.23 (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) - (not (and (<= 2 c 5) (= a b))))))) + (x (copy-seq orig)) + (c 0) + (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) + (not (and (<= 2 c 5) (= a b))))))) (and (equalp orig x) - result)) + result)) #*0111110101) (deftest substitute-bit-vector.24 (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) - :from-end t))) + (x (copy-seq orig)) + (c 0) + (result (substitute 1 0 x :test #'(lambda (a b) (incf c) (and (<= 2 c 5) (= a b))) + :from-end t))) (and (equalp orig x) - result)) + result)) #*0101011111) (deftest substitute-bit-vector.25 (let* ((orig #*0101010101) - (x (copy-seq orig)) - (c 0) - (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) - (not (and (<= 2 c 5) (= a b)))) - :from-end t))) + (x (copy-seq orig)) + (c 0) + (result (substitute 1 0 x :test-not #'(lambda (a b) (incf c) + (not (and (<= 2 c 5) (= a b)))) + :from-end t))) (and (equalp orig x) - result)) + result)) #*0101011111) (deftest substitute-bit-vector.26 (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute 1 1 x :key #'1+))) + (x (copy-seq orig)) + (result (substitute 1 1 x :key #'1+))) (and (equalp orig x) - result)) + result)) #*11111111111111111) - + (deftest substitute-bit-vector.27 (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute 1 1 x :key #'1+ :start 1 :end 10))) + (x (copy-seq orig)) + (result (substitute 1 1 x :key #'1+ :start 1 :end 10))) (and (equalp orig x) - result)) + result)) #*01111111111010110) (deftest substitute-bit-vector.28 (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute 0 1 x :key #'1+ :test (complement #'eql)))) + (x (copy-seq orig)) + (result (substitute 0 1 x :key #'1+ :test (complement #'eql)))) (and (equalp orig x) - result)) + result)) #*00000000000000000) (deftest substitute-bit-vector.29 (let* ((orig #*00111001011010110) - (x (copy-seq orig)) - (result (substitute 0 1 x :key #'1+ :test-not #'eql))) + (x (copy-seq orig)) + (result (substitute 0 1 x :key #'1+ :test-not #'eql))) (and (equalp orig x) - result)) + result)) #*00000000000000000) (deftest substitute-bit-vector.30 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute 1 0 x))) + :fill-pointer 5 :element-type 'bit)) + (result (substitute 1 0 x))) result) #*11111) (deftest substitute-bit-vector.31 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute 1 0 x :from-end t))) + :fill-pointer 5 :element-type 'bit)) + (result (substitute 1 0 x :from-end t))) result) #*11111) (deftest substitute-bit-vector.32 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute 1 0 x :count 1))) + :fill-pointer 5 :element-type 'bit)) + (result (substitute 1 0 x :count 1))) result) #*11011) (deftest substitute-bit-vector.33 (let* ((x (make-array '(10) :initial-contents '(0 1 0 1 1 0 1 1 0 1) - :fill-pointer 5 :element-type 'bit)) - (result (substitute 1 0 x :from-end t :count 1))) + :fill-pointer 5 :element-type 'bit)) + (result (substitute 1 0 x :from-end t :count 1))) result) #*01111) @@ -1066,17 +1066,17 @@ (deftest substitute.allow-other-keys.3 (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t - :allow-other-keys nil :bad t) + :allow-other-keys nil :bad t) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.4 (substitute 'a 0 (list 1 2 0 3 1 0 3) :bad t - :allow-other-keys t :allow-other-keys nil) + :allow-other-keys t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.5 (substitute 'a 0 (list 1 2 0 3 1 0 3) - :allow-other-keys t :key #'1-) + :allow-other-keys t :key #'1-) (a 2 0 3 a 0 3)) (deftest substitute.keywords.6 @@ -1085,7 +1085,7 @@ (deftest substitute.allow-other-keys.7 (substitute 'a 0 (list 1 2 0 3 1 0 3) :allow-other-keys t - :bad t :allow-other-keys nil) + :bad t :allow-other-keys nil) (1 2 a 3 1 a 3)) (deftest substitute.allow-other-keys.8 diff --git a/ansi-tests/subtypep-array.lsp b/ansi-tests/subtypep-array.lsp index 42502c04..cca5afcc 100644 --- a/ansi-tests/subtypep-array.lsp +++ b/ansi-tests/subtypep-array.lsp @@ -11,11 +11,11 @@ (deftest subtypep.array.1 (let ((array-types (cons (find-class 'array) - '(array (array) (array *) (array * *))))) + '(array (array) (array *) (array * *))))) (loop for tp1 in array-types append - (loop for tp2 in array-types - unless (subtypep tp1 tp2) - collect (list tp1 tp2)))) + (loop for tp2 in array-types + unless (subtypep tp1 tp2) + collect (list tp1 tp2)))) nil) (deftest subtypep.array.2 @@ -26,24 +26,24 @@ (deftest subtypep.array.3 (loop for i from 0 below (min 16 array-rank-limit) - for type = `(array * ,i) - for type2 = `(array * ,(make-list i :initial-element '*)) - unless (and (subtypep type 'array) - (subtypep type '(array)) - (subtypep type '(array *)) - (subtypep type '(array * *)) - (subtypep type type2)) - collect type) + for type = `(array * ,i) + for type2 = `(array * ,(make-list i :initial-element '*)) + unless (and (subtypep type 'array) + (subtypep type '(array)) + (subtypep type '(array *)) + (subtypep type '(array * *)) + (subtypep type type2)) + collect type) nil) (deftest subtypep.array.4 (loop for i from 0 below (min 16 array-rank-limit) - for type = `(array t ,i) - for type2 = `(array t ,(make-list i :initial-element '*)) - unless (and (subtypep type '(array t)) - (subtypep type '(array t *)) - (subtypep type type2)) - collect type) + for type = `(array t ,i) + for type2 = `(array t ,(make-list i :initial-element '*)) + unless (and (subtypep type '(array t)) + (subtypep type '(array t *)) + (subtypep type type2)) + collect type) nil) (deftest subtypep.array.5 @@ -51,26 +51,26 @@ for element-type in (cons '* *array-element-types*) nconc (loop for i from 0 below (min 16 array-rank-limit) - for type = `(array ,element-type ,i) - for type2 = `(array ,element-type ,(make-list i :initial-element '0)) - for type3 = `(array ,element-type ,(make-list i :initial-element '1)) - unless - (and (subtypep type2 type) - (subtypep type3 type) - (loop for j from 0 to i - always - (and - (subtypep - `(array ,element-type - (,@(make-list j :initial-element '*) - ,@(make-list (- i j) :initial-element 2))) - type) - (subtypep - `(array ,element-type - (,@(make-list j :initial-element 2) - ,@(make-list (- i j) :initial-element '*))) - type)))) - collect type)) + for type = `(array ,element-type ,i) + for type2 = `(array ,element-type ,(make-list i :initial-element '0)) + for type3 = `(array ,element-type ,(make-list i :initial-element '1)) + unless + (and (subtypep type2 type) + (subtypep type3 type) + (loop for j from 0 to i + always + (and + (subtypep + `(array ,element-type + (,@(make-list j :initial-element '*) + ,@(make-list (- i j) :initial-element 2))) + type) + (subtypep + `(array ,element-type + (,@(make-list j :initial-element 2) + ,@(make-list (- i j) :initial-element '*))) + type)))) + collect type)) nil) (deftest subtypep.array.6 @@ -79,7 +79,7 @@ append (check-equivalence `(and (array ,etype (* 10 * * *)) - (array ,etype (* * * 29 *))) + (array ,etype (* * * 29 *))) `(array ,etype (* 10 * 29 *)))) nil) @@ -90,34 +90,34 @@ for uaetp1 = (upgraded-array-element-type etp1) append (loop for etp2 in etypes - for uaetp2 = (upgraded-array-element-type etp2) - when (equal (multiple-value-list (subtypep* uaetp1 uaetp2)) - '(nil t)) - append (check-disjointness `(array ,etp1) `(array ,etp2))))) + for uaetp2 = (upgraded-array-element-type etp2) + when (equal (multiple-value-list (subtypep* uaetp1 uaetp2)) + '(nil t)) + append (check-disjointness `(array ,etp1) `(array ,etp2))))) nil) (deftest subtypep.array.8 (let ((limit (min 16 array-rank-limit))) (loop for i below limit - for type1 = `(array t ,i) - nconc - (loop for j below limit - for type2 = `(array t ,j) - when (and (/= i j) - (subtypep type1 type2)) - collect (list type1 type2)))) + for type1 = `(array t ,i) + nconc + (loop for j below limit + for type2 = `(array t ,j) + when (and (/= i j) + (subtypep type1 type2)) + collect (list type1 type2)))) nil) (deftest subtypep.array.9 (let ((limit (min 16 array-rank-limit))) (loop for i below limit - for type1 = `(array t ,(make-list i :initial-element 1)) - nconc - (loop for j below limit - for type2 = `(array t ,(make-list j :initial-element 1)) - when (and (/= i j) - (subtypep type1 type2)) - collect (list type1 type2)))) + for type1 = `(array t ,(make-list i :initial-element 1)) + nconc + (loop for j below limit + for type2 = `(array t ,(make-list j :initial-element 1)) + when (and (/= i j) + (subtypep type1 type2)) + collect (list type1 type2)))) nil) (deftest subtypep.array.10 diff --git a/ansi-tests/subtypep-complex.lsp b/ansi-tests/subtypep-complex.lsp index b4203671..841dcbfd 100644 --- a/ansi-tests/subtypep-complex.lsp +++ b/ansi-tests/subtypep-complex.lsp @@ -17,100 +17,100 @@ (defun check-not-complex-type (type) (let ((result1 (multiple-value-list (subtypep* type 'complex))) - (result2 (multiple-value-list (subtypep* 'complex type)))) + (result2 (multiple-value-list (subtypep* 'complex type)))) (if (and (equal result1 '(nil t)) - (equal result2 '(nil t))) - nil + (equal result2 '(nil t))) + nil (list (list type result1 result2))))) (deftest subtypep-complex.3 (mapcan #'check-not-complex-type - '(bit unsigned-byte integer rational ratio real float short-float - single-float double-float long-float fixnum bignum)) + '(bit unsigned-byte integer rational ratio real float short-float + single-float double-float long-float fixnum bignum)) nil) (deftest subtypep-complex.4 (loop for i from 1 to 100 - nconc (check-not-complex-type `(unsigned-byte ,i))) + nconc (check-not-complex-type `(unsigned-byte ,i))) nil) - + (deftest subtypep-complex.5 (loop for i from 1 to 100 - nconc (check-not-complex-type `(signed-byte ,i))) + nconc (check-not-complex-type `(signed-byte ,i))) nil) (deftest subtypep-complex.7 (let ((types '(complex (complex) (complex *)))) (loop for tp1 in types - nconc (loop for tp2 in types - for result = (multiple-value-list (subtypep* tp1 tp2)) - unless (equal result '(t t)) - collect (list tp1 tp2 result)))) + nconc (loop for tp2 in types + for result = (multiple-value-list (subtypep* tp1 tp2)) + unless (equal result '(t t)) + collect (list tp1 tp2 result)))) nil) (defun check-complex-upgrading (t1 t2) (let* ((ucpt1 (upgraded-complex-part-type t1)) - (ucpt2 (upgraded-complex-part-type t2)) - (result (multiple-value-list - (subtypep* `(complex ,t1) `(complex ,t2))))) + (ucpt2 (upgraded-complex-part-type t2)) + (result (multiple-value-list + (subtypep* `(complex ,t1) `(complex ,t2))))) (cond ((or (equal ucpt1 ucpt2) - (subtypep t1 t2)) + (subtypep t1 t2)) (unless (equal result '(t t)) - (list (list :case1 t1 t2 ucpt1 ucpt2 result)))) + (list (list :case1 t1 t2 ucpt1 ucpt2 result)))) (t (multiple-value-bind - (ucpt-sub1? good1?) - (subtypep* ucpt1 ucpt2) - (multiple-value-bind - (ucpt-sub2? good2?) - (subtypep* ucpt2 ucpt1) - (cond - ;; the second is not a subtype of the first - ((and good2? ucpt-sub1? (not ucpt-sub2?)) - (assert good1?) - (unless (equal result '(nil t)) - (list (list :case2 t1 t2 ucpt1 ucpt2 result)))) - ;; the first is not a subtype of the second - ((and good1? (not ucpt-sub1?) ucpt-sub2?) - (assert good2?) - (unless (equal result '(nil t)) - (list (list :case3 t1 t2 ucpt1 ucpt2 result)))) - ;; they are both subtypes of each other, and so represent - ;; the same set of objects - ((and ucpt-sub1? ucpt-sub2?) - (assert good1?) - (assert good2?) - (unless (equal result '(t t)) - (list (list :case4 t1 t2 ucpt1 ucpt2 result))))))))))) + (ucpt-sub1? good1?) + (subtypep* ucpt1 ucpt2) + (multiple-value-bind + (ucpt-sub2? good2?) + (subtypep* ucpt2 ucpt1) + (cond + ;; the second is not a subtype of the first + ((and good2? ucpt-sub1? (not ucpt-sub2?)) + (assert good1?) + (unless (equal result '(nil t)) + (list (list :case2 t1 t2 ucpt1 ucpt2 result)))) + ;; the first is not a subtype of the second + ((and good1? (not ucpt-sub1?) ucpt-sub2?) + (assert good2?) + (unless (equal result '(nil t)) + (list (list :case3 t1 t2 ucpt1 ucpt2 result)))) + ;; they are both subtypes of each other, and so represent + ;; the same set of objects + ((and ucpt-sub1? ucpt-sub2?) + (assert good1?) + (assert good2?) + (unless (equal result '(t t)) + (list (list :case4 t1 t2 ucpt1 ucpt2 result))))))))))) (deftest subtypep-complex.8 (let ((types (reverse - '(bit fixnum bignum integer unsigned-byte rational ratio - short-float single-float double-float long-float - float real))) - (float-types - (remove-duplicates '(short-float single-float double-float long-float) - :test #'(lambda (t1 t2) - (eql (coerce 0 t1) (coerce 0 t2)))))) + '(bit fixnum bignum integer unsigned-byte rational ratio + short-float single-float double-float long-float + float real))) + (float-types + (remove-duplicates '(short-float single-float double-float long-float) + :test #'(lambda (t1 t2) + (eql (coerce 0 t1) (coerce 0 t2)))))) (loop for i in '(1 2 3 4 6 8 13 16 17 28 29 31 32 48 64) - do (push `(unsigned-byte ,i) types) - do (push `(signed-byte ,i) types) - do (loop for ftp in float-types - do (push `(,ftp ,(coerce 0 ftp) - ,(coerce i ftp)) - types) - do (push `(,ftp (,(coerce (- i) ftp)) - ,(coerce i ftp)) - types)) - do (push `(float ,(coerce 0 'single-float) - ,(coerce i 'single-float)) - types)) + do (push `(unsigned-byte ,i) types) + do (push `(signed-byte ,i) types) + do (loop for ftp in float-types + do (push `(,ftp ,(coerce 0 ftp) + ,(coerce i ftp)) + types) + do (push `(,ftp (,(coerce (- i) ftp)) + ,(coerce i ftp)) + types)) + do (push `(float ,(coerce 0 'single-float) + ,(coerce i 'single-float)) + types)) (setq types (reverse types)) (let ((results - (mapcan #'(lambda (t1) - (mapcan #'(lambda (t2) (check-complex-upgrading t1 t2)) - types)) - types))) + (mapcan #'(lambda (t1) + (mapcan #'(lambda (t2) (check-complex-upgrading t1 t2)) + types)) + types))) (subseq results 0 (min 100 (length results))))) nil) diff --git a/ansi-tests/subtypep-cons.lsp b/ansi-tests/subtypep-cons.lsp index 6d46f264..7cb110a0 100644 --- a/ansi-tests/subtypep-cons.lsp +++ b/ansi-tests/subtypep-cons.lsp @@ -11,57 +11,57 @@ (defvar *cons-types* '(cons (cons) (cons *) (cons * *) (cons t) (cons t t) - (cons t *) (cons * t))) + (cons t *) (cons * t))) (deftest subtypep.cons.1 (loop for t1 in *cons-types* - append (loop for t2 in *cons-types* - unless (equal (mapcar #'notnot - (multiple-value-list - (subtypep t1 t2))) - '(t t)) - collect (list t1 t2))) + append (loop for t2 in *cons-types* + unless (equal (mapcar #'notnot + (multiple-value-list + (subtypep t1 t2))) + '(t t)) + collect (list t1 t2))) nil) (deftest subtypep.cons.2 (loop for t1 in '((cons nil) (cons nil *) (cons nil t) - (cons * nil) (cons t nil) (cons nil nil)) - unless (subtypep t1 nil) - collect t1) + (cons * nil) (cons t nil) (cons nil nil)) + unless (subtypep t1 nil) + collect t1) nil) (deftest subtypep.cons.3 (check-equivalence '(and (cons symbol *) (cons * symbol)) - '(cons symbol symbol)) + '(cons symbol symbol)) nil) (deftest subtypep.cons.4 (check-equivalence '(and (cons (integer 0 10) *) - (cons (integer 5 15) (integer 10 20)) - (cons * (integer 15 25))) - '(cons (integer 5 10) (integer 15 20))) + (cons (integer 5 15) (integer 10 20)) + (cons * (integer 15 25))) + '(cons (integer 5 10) (integer 15 20))) nil) (deftest subtypep.cons.5 (check-equivalence '(and cons (not (cons symbol symbol))) '(or (cons (not symbol) *) - (cons * (not symbol)))) + (cons * (not symbol)))) nil) (deftest subtypep.cons.6 (check-equivalence '(or (cons integer symbol) (cons integer integer) - (cons symbol integer) (cons symbol symbol)) + (cons symbol integer) (cons symbol symbol)) '(cons (or integer symbol) (or integer symbol))) nil) (deftest subtypep.cons.7 (check-equivalence '(or (cons (integer 0 8) (integer 5 15)) - (cons (integer 0 7) (integer 0 6)) - (cons (integer 6 15) (integer 0 9)) - (cons (integer 3 15) (integer 4 15))) + (cons (integer 0 7) (integer 0 6)) + (cons (integer 6 15) (integer 0 9)) + (cons (integer 3 15) (integer 4 15))) '(cons (integer 0 15) (integer 0 15))) nil) @@ -77,7 +77,7 @@ (cons integer (cons integer integer)) (cons integer (cons symbol symbol))) '(cons (or symbol integer) - (cons (or symbol integer) (or symbol integer)))) + (cons (or symbol integer) (or symbol integer)))) nil) (deftest subtypep.cons.9 @@ -117,9 +117,9 @@ (deftest subtypep.cons.12 (check-all-not-subtypep '(cons (or integer symbol) - (or integer symbol)) + (or integer symbol)) '(or (cons integer symbol) - (cons symbol integer))) + (cons symbol integer))) nil) (deftest subtypep.cons.13 @@ -131,7 +131,7 @@ (deftest subtypep.cons.14 (check-all-subtypep '(and (or (cons (not symbol)) (cons * integer)) - (cons symbol)) + (cons symbol)) '(cons * integer)) nil) @@ -139,7 +139,7 @@ (deftest subtypep.cons.15 (check-all-subtypep '(and (or (cons (not symbol)) (cons * integer)) - (cons * (not integer))) + (cons * (not integer))) '(cons (not symbol))) nil) @@ -147,21 +147,21 @@ (deftest subtypep.cons.16 (check-all-subtypep '(and (or (cons symbol (cons * *)) - (cons * (cons integer *))) - (or (cons * (cons (not integer) *)) - (cons * (cons * float)))) + (cons * (cons integer *))) + (or (cons * (cons (not integer) *)) + (cons * (cons * float)))) '(or (cons symbol (cons * *)) - (cons * (cons * float)))) + (cons * (cons * float)))) nil) (deftest subtypep.cons.17 (check-all-subtypep '(and (or (cons symbol (cons * *)) - (cons * (cons integer *))) - (or (cons * (cons (not integer))) - (cons * (cons * float))) - (or (cons * (cons * (not float))) - (cons symbol (cons * *)))) + (cons * (cons integer *))) + (or (cons * (cons (not integer))) + (cons * (cons * float))) + (or (cons * (cons * (not float))) + (cons symbol (cons * *)))) '(cons symbol)) nil) @@ -169,7 +169,7 @@ (check-all-subtypep '(cons symbol) '(or (cons symbol (not integer)) - (cons * integer))) + (cons * integer))) nil) (deftest subtypep.cons.19 @@ -199,7 +199,7 @@ (cons (eql b) (eql x)) (cons (eql c) (eql y))) '(and (cons (member a b c) (member x y z)) - (not (cons (eql c) (eql z))))) + (not (cons (eql c) (eql z))))) nil) ;;; Test case that came up in SBCL @@ -219,86 +219,86 @@ (deftest subtype.cons.23 (let ((t1 '(cons t (cons (not long-float) symbol))) - (t2 '(not (cons symbol (cons integer integer))))) + (t2 '(not (cons symbol (cons integer integer))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.24 (let ((t1 '(cons (eql 3671) (cons short-float (eql -663423073525)))) - (t2 '(not (cons t (cons (not complex) (cons integer t)))))) + (t2 '(not (cons t (cons (not complex) (cons integer t)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.25 (let ((t1 '(cons t (cons (not long-float) (integer 44745969 61634129)))) - (t2 '(not (cons (eql -3) (cons short-float (cons t float)))))) + (t2 '(not (cons (eql -3) (cons short-float (cons t float)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.26 (let ((t1 '(cons integer (cons single-float (cons t t)))) - (t2 '(cons t (cons (not complex) (not (eql 8)))))) + (t2 '(cons t (cons (not complex) (not (eql 8)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.27 (let ((t1 '(cons (not (integer -27 30)) - (cons rational (cons integer integer)))) - (t2 '(not (cons integer (cons integer (eql 378132631)))))) + (cons rational (cons integer integer)))) + (t2 '(not (cons integer (cons integer (eql 378132631)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtype.cons.28 (let ((t1 '(cons (integer -1696888 -1460338) - (cons single-float symbol))) - (t2 '(not (cons (not (integer -14 20)) - (cons (not integer) cons))))) + (cons single-float symbol))) + (t2 '(not (cons (not (integer -14 20)) + (cons (not integer) cons))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtypep.cons.29 (let ((t2 '(or (not (cons unsigned-byte cons)) - (not (cons (integer -6 22) rational))))) + (not (cons (integer -6 22) rational))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.30 (let ((t1 '(not (cons t (cons t (cons cons t))))) - (t2 '(or (or (cons (cons t integer) t) - (not (cons t (cons t cons)))) - (not (cons (cons (eql -27111309) t) - (cons t (eql 1140730))))))) + (t2 '(or (or (cons (cons t integer) t) + (not (cons t (cons t cons)))) + (not (cons (cons (eql -27111309) t) + (cons t (eql 1140730))))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) (deftest subtypep.cons.31 (let ((t2 '(or - (not - (cons (or (cons t ratio) (cons short-float t)) - (cons (cons (eql -7418623) (integer -9 53)) - (cons cons t)))) - (not - (cons (cons t (eql -265039)) - (cons (cons t cons) t)))))) + (not + (cons (or (cons t ratio) (cons short-float t)) + (cons (cons (eql -7418623) (integer -9 53)) + (cons cons t)))) + (not + (cons (cons t (eql -265039)) + (cons (cons t cons) t)))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.32 (let ((t2 '(cons t - (or (not (cons integer (eql 0))) - (not (cons (or float (eql 0)) cons)))))) + (or (not (cons integer (eql 0))) + (not (cons (or float (eql 0)) cons)))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.33 (let ((t2 '(or (not (cons (cons t cons) (cons t (cons unsigned-byte t)))) - (not (cons (cons integer t) (cons t (cons cons t))))))) + (not (cons (cons integer t) (cons t (cons cons t))))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) (deftest subtypep.cons.34 (let ((t2 '(or (not (cons (or (eql 0) ratio) (not cons))) - (not (cons integer cons))))) + (not (cons integer cons))))) (subtypep-and-contrapositive-are-consistent 'cons t2)) t) @@ -316,7 +316,7 @@ (deftest subtypep.cons.38 (let ((t1 '(cons t (complex (real -32 0)))) - (t2 `(not (cons t (complex (integer * -500)))))) + (t2 `(not (cons t (complex (integer * -500)))))) (subtypep-and-contrapositive-are-consistent t1 t2)) t) @@ -328,7 +328,7 @@ (deftest subtypep.cons.40 (let ((type1 '(cons (eql 0) cons)) - (type2 '(cons unsigned-byte symbol))) + (type2 '(cons unsigned-byte symbol))) (values (subtypep* type1 type2) (subtypep* `(not ,type2) `(not ,type1)))) @@ -338,20 +338,20 @@ (deftest subtypep.cons.41 (let ((type1 '(cons t (complex (real -10 -4)))) - (type2 '(not (cons t (complex (integer -200 -100)))))) + (type2 '(not (cons t (complex (integer -200 -100)))))) (multiple-value-bind (sub1 success1) - (subtypep* type1 type2) + (subtypep* type1 type2) (multiple-value-bind (sub2 success2) - (subtypep* `(not ,type2) `(not ,type1)) - (if (and success1 success2 (not (eq sub1 sub2))) - (values sub1 sub2) - nil)))) + (subtypep* `(not ,type2) `(not ,type1)) + (if (and success1 success2 (not (eq sub1 sub2))) + (values sub1 sub2) + nil)))) nil) (deftest subtypep.cons.42 (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons) (integer -234496 215373)) - integer)) - (t2 '(cons (cons (cons integer integer) (integer -234496 215373)) t))) + integer)) + (t2 '(cons (cons (cons integer integer) (integer -234496 215373)) t))) (values (subtypep `(not ,t2) `(not ,t1)))) nil) @@ -359,18 +359,18 @@ (deftest subtypep.cons.43 (let* ((n -3.926510009989861d7) - (t1 '(not (cons float t))) - (t2 `(or (not (cons (eql 0) (real ,n ,n))) - (not (cons t (eql 0)))))) - (multiple-value-bind + (t1 '(not (cons float t))) + (t2 `(or (not (cons (eql 0) (real ,n ,n))) + (not (cons t (eql 0)))))) + (multiple-value-bind (sub1 good1) (subtypep* t1 t2) (multiple-value-bind (sub2 good2) (subtypep* `(not ,t2) `(not ,t1)) (or (not good1) - (not good2) - (and sub1 sub2) - (and (not sub1) (not sub2)))))) + (not good2) + (and sub1 sub2) + (and (not sub1) (not sub2)))))) t) diff --git a/ansi-tests/subtypep-eql.lsp b/ansi-tests/subtypep-eql.lsp index b965aeae..75ec441f 100644 --- a/ansi-tests/subtypep-eql.lsp +++ b/ansi-tests/subtypep-eql.lsp @@ -9,20 +9,20 @@ (deftest subtypep.eql.1 (let ((s1 (copy-seq "abc")) - (s2 (copy-seq "abc"))) + (s2 (copy-seq "abc"))) (let ((t1 `(eql ,s1)) - (t2 `(eql ,s2))) + (t2 `(eql ,s2))) (cond ((subtypep t1 t2) "T1 is subtype of T2") ((subtypep t2 t1) "T2 is subtype of T1") (t (check-disjointness t1 t2))))) nil) - + (deftest subtypep.eql.2 (let ((s1 (copy-seq '(a b c))) - (s2 (copy-seq '(a b c)))) + (s2 (copy-seq '(a b c)))) (let ((t1 `(eql ,s1)) - (t2 `(eql ,s2))) + (t2 `(eql ,s2))) (cond ((subtypep t1 t2) "T1 is subtype of T2") ((subtypep t2 t1) "T2 is subtype of T1") @@ -31,7 +31,7 @@ (deftest subtypep.eql.3 (let ((i1 (1+ most-positive-fixnum)) - (i2 (1+ most-positive-fixnum))) + (i2 (1+ most-positive-fixnum))) (check-equivalence `(eql ,i1) `(eql ,i2))) nil) diff --git a/ansi-tests/subtypep-float.lsp b/ansi-tests/subtypep-float.lsp index effaf4d5..9f544be5 100644 --- a/ansi-tests/subtypep-float.lsp +++ b/ansi-tests/subtypep-float.lsp @@ -11,21 +11,21 @@ (deftest subtypep.float.1 (loop for tp in +float-types+ - append (check-subtypep tp 'float t t)) + append (check-subtypep tp 'float t t)) nil) (deftest subtypep.float.2 (if (subtypep 'short-float 'long-float) (loop for tp in +float-types+ - append - (loop for tp2 in +float-types+ - append (check-subtypep tp tp2 t t))) + append + (loop for tp2 in +float-types+ + append (check-subtypep tp tp2 t t))) nil) nil) (deftest subtypep.float.3 (if (and (not (subtypep 'short-float 'single-float)) - (subtypep 'single-float 'long-float)) + (subtypep 'single-float 'long-float)) (append (check-equivalence 'single-float 'double-float) (check-equivalence 'single-float 'long-float) @@ -38,22 +38,22 @@ (deftest subtypep.float.4 (if (and (subtypep 'single-float 'short-float) - (subtypep 'double-float 'long-float) - (not (subtypep 'short-float 'double-float))) + (subtypep 'double-float 'long-float) + (not (subtypep 'short-float 'double-float))) (append (check-equivalence 'short-float 'single-float) (check-equivalence 'double-float 'long-float) (loop for tp in '(short-float single-float) - append - (loop for tp2 in '(double-float long-float) - append (classes-are-disjoint tp tp2)))) + append + (loop for tp2 in '(double-float long-float) + append (classes-are-disjoint tp tp2)))) nil) nil) (deftest subtypep.float.5 (if (and (not (subtypep 'single-float 'short-float)) - (not (subtypep 'single-float 'double-float)) - (subtypep 'double-float 'long-float)) + (not (subtypep 'single-float 'double-float)) + (subtypep 'double-float 'long-float)) (append (classes-are-disjoint 'short-float 'single-float) (classes-are-disjoint 'short-float 'double-float) @@ -66,8 +66,8 @@ (deftest subtypep.float.6 (if (and (subtypep 'single-float 'short-float) - (not (subtypep 'single-float 'double-float)) - (not (subtypep 'double-float 'long-float))) + (not (subtypep 'single-float 'double-float)) + (not (subtypep 'double-float 'long-float))) (append (check-equivalence 'short-float 'single-float) (classes-are-disjoint 'single-float 'double-float) @@ -78,13 +78,13 @@ (deftest subtypep.float.7 (if (and (not (subtypep 'single-float 'short-float)) - (not (subtypep 'single-float 'double-float)) - (not (subtypep 'double-float 'long-float))) + (not (subtypep 'single-float 'double-float)) + (not (subtypep 'double-float 'long-float))) (loop for tp in +float-types+ - append - (loop for tp2 in +float-types+ - unless (eq tp tp2) - append (classes-are-disjoint tp tp2))) + append + (loop for tp2 in +float-types+ + unless (eq tp tp2) + append (classes-are-disjoint tp tp2))) nil) nil) @@ -154,44 +154,44 @@ (deftest subtypep.float.24 (check-equivalence '(and (short-float 0.0s0 2.0s0) - (short-float 1.0s0 3.0s0)) - '(short-float 1.0s0 2.0s0)) + (short-float 1.0s0 3.0s0)) + '(short-float 1.0s0 2.0s0)) nil) (deftest subtypep.float.25 (check-equivalence '(and (single-float 0.0f0 2.0f0) - (single-float 1.0f0 3.0f0)) - '(single-float 1.0f0 2.0f0)) + (single-float 1.0f0 3.0f0)) + '(single-float 1.0f0 2.0f0)) nil) (deftest subtypep.float.26 (check-equivalence '(and (double-float 0.0d0 2.0d0) - (double-float 1.0d0 3.0d0)) - '(double-float 1.0d0 2.0d0)) + (double-float 1.0d0 3.0d0)) + '(double-float 1.0d0 2.0d0)) nil) (deftest subtypep.float.27 (check-equivalence '(and (long-float 0.0l0 2.0l0) - (long-float 1.0l0 3.0l0)) - '(long-float 1.0l0 2.0l0)) + (long-float 1.0l0 3.0l0)) + '(long-float 1.0l0 2.0l0)) nil) ;;; Signed zero tests (deftest subtypep.short-float.zero.1 (check-equivalence '(short-float 0.0s0 *) - '(or (short-float (0.0s0) *) - (member -0.0s0 0.0s0))) + '(or (short-float (0.0s0) *) + (member -0.0s0 0.0s0))) nil) (unless (eql 0.0s0 -0.0s0) (deftest subtypep.short-float.zero.2a (values (subtypep '(short-float 0.0s0) - '(or (short-float (0.0s0)) (member 0.0s0)))) + '(or (short-float (0.0s0)) (member 0.0s0)))) nil) (deftest subtypep.short-float.zero.2b (values (subtypep '(short-float 0.0s0) - '(or (short-float (0.0s0)) (member -0.0s0)))) + '(or (short-float (0.0s0)) (member -0.0s0)))) nil)) (deftest subtypep.short-float.zero.3 @@ -264,18 +264,18 @@ (deftest subtypep.single-float.zero.1 (check-equivalence '(single-float 0.0f0 *) - '(or (single-float (0.0f0) *) - (member -0.0f0 0.0f0))) + '(or (single-float (0.0f0) *) + (member -0.0f0 0.0f0))) nil) (unless (eql 0.0f0 -0.0f0) (deftest subtypep.single-float.zero.2a (values (subtypep '(single-float 0.0f0) - '(or (single-float (0.0f0)) (member 0.0f0)))) + '(or (single-float (0.0f0)) (member 0.0f0)))) nil) (deftest subtypep.single-float.zero.2b (values (subtypep '(single-float 0.0f0) - '(or (single-float (0.0f0)) (member -0.0f0)))) + '(or (single-float (0.0f0)) (member -0.0f0)))) nil)) (deftest subtypep.single-float.zero.3 @@ -314,18 +314,18 @@ (deftest subtypep.long-float.zero.1 (check-equivalence '(long-float 0.0l0 *) - '(or (long-float (0.0l0) *) - (member -0.0l0 0.0l0))) + '(or (long-float (0.0l0) *) + (member -0.0l0 0.0l0))) nil) (unless (eql 0.0l0 -0.0l0) (deftest subtypep.long-float.zero.2a (values (subtypep '(long-float 0.0l0) - '(or (long-float (0.0l0)) (member 0.0l0)))) + '(or (long-float (0.0l0)) (member 0.0l0)))) nil) (deftest subtypep.long-float.zero.2b (values (subtypep '(long-float 0.0l0) - '(or (long-float (0.0l0)) (member -0.0l0)))) + '(or (long-float (0.0l0)) (member -0.0l0)))) nil)) (deftest subtypep.long-float.zero.3 @@ -364,18 +364,18 @@ (deftest subtypep.double-float.zero.1 (check-equivalence '(double-float 0.0d0 *) - '(or (double-float (0.0d0) *) - (member -0.0d0 0.0d0))) + '(or (double-float (0.0d0) *) + (member -0.0d0 0.0d0))) nil) (unless (eql 0.0d0 -0.0d0) (deftest subtypep.double-float.zero.2a (values (subtypep '(double-float 0.0d0) - '(or (double-float (0.0d0)) (member 0.0d0)))) + '(or (double-float (0.0d0)) (member 0.0d0)))) nil) (deftest subtypep.double-float.zero.2b (values (subtypep '(double-float 0.0d0) - '(or (double-float (0.0d0)) (member -0.0d0)))) + '(or (double-float (0.0d0)) (member -0.0d0)))) nil)) (deftest subtypep.double-float.zero.3 diff --git a/ansi-tests/subtypep-integer.lsp b/ansi-tests/subtypep-integer.lsp index 9cae0962..c6bbd6f0 100644 --- a/ansi-tests/subtypep-integer.lsp +++ b/ansi-tests/subtypep-integer.lsp @@ -13,13 +13,13 @@ (deftest subtypep.fixnum.integer (check-equivalence `(integer ,most-negative-fixnum ,most-positive-fixnum) - 'fixnum) + 'fixnum) nil) (deftest subtypep.bignum.integer (check-equivalence `(or (integer * (,most-negative-fixnum)) - (integer (,most-positive-fixnum) *)) + (integer (,most-positive-fixnum) *)) 'bignum) nil) @@ -220,7 +220,7 @@ (deftest subtypep.integer.25 (check-equivalence '(and (or (integer 0 10) (integer 20 30)) - (or (integer 5 15) (integer 25 35))) + (or (integer 5 15) (integer 25 35))) '(or (integer 5 10) (integer 25 30))) nil) @@ -276,48 +276,48 @@ (deftest subtypep.integer.real.4 (loop for int-type in '(integer (integer) (integer *) (integer * *)) - append (loop for real-type in '(real (real) (real *) (real * *)) - unless (equal (multiple-value-list - (subtypep* int-type real-type)) - '(t t)) - collect (list int-type real-type))) + append (loop for real-type in '(real (real) (real *) (real * *)) + unless (equal (multiple-value-list + (subtypep* int-type real-type)) + '(t t)) + collect (list int-type real-type))) nil) (deftest subtypep.integer.real.5 (loop for int-type in '((integer 10) (integer 10 *)) - append (loop for real-type in '(real (real) (real *) (real * *) - (real 10.0) (real 10.0 *) - (real 10) (real 10 *)) - unless (equal (multiple-value-list - (subtypep* int-type real-type)) - '(t t)) - collect (list int-type real-type))) + append (loop for real-type in '(real (real) (real *) (real * *) + (real 10.0) (real 10.0 *) + (real 10) (real 10 *)) + unless (equal (multiple-value-list + (subtypep* int-type real-type)) + '(t t)) + collect (list int-type real-type))) nil) (deftest subtypep.integer.real.6 (loop for int-type in '((integer * 10) (integer * 5)) - append (loop for real-type in '(real (real) (real *) (real * *) - (real * 10.0) - (real * 10) (real * 1000000000000)) - unless (equal (multiple-value-list - (subtypep* int-type real-type)) - '(t t)) - collect (list int-type real-type))) + append (loop for real-type in '(real (real) (real *) (real * *) + (real * 10.0) + (real * 10) (real * 1000000000000)) + unless (equal (multiple-value-list + (subtypep* int-type real-type)) + '(t t)) + collect (list int-type real-type))) nil) (deftest subtypep.integer.real.7 (loop for int-type in '((integer 0 10) (integer 2 5)) - append (loop for real-type in '(real (real) (real *) (real * *) - (real * 10) (real * 1000000000000) - (real -10) (real -10.0) - (real -10 *) (real -10.0 *) - (real 0) (real 0.0) - (real 0 10) (real * 10) - (real 0 *) (real 0 10)) - unless (equal (multiple-value-list - (subtypep* int-type real-type)) - '(t t)) - collect (list int-type real-type))) + append (loop for real-type in '(real (real) (real *) (real * *) + (real * 10) (real * 1000000000000) + (real -10) (real -10.0) + (real -10 *) (real -10.0 *) + (real 0) (real 0.0) + (real 0 10) (real * 10) + (real 0 *) (real 0 10)) + unless (equal (multiple-value-list + (subtypep* int-type real-type)) + '(t t)) + collect (list int-type real-type))) nil) (deftest subtypep.integer.real.8 @@ -369,52 +369,52 @@ (deftest subtypep.integer.rational.4 (loop for int-type in '(integer (integer) (integer *) (integer * *)) - append (loop for rational-type - in '(rational (rational) (rational *) (rational * *)) - unless (equal (multiple-value-list - (subtypep* int-type rational-type)) - '(t t)) - collect (list int-type rational-type))) + append (loop for rational-type + in '(rational (rational) (rational *) (rational * *)) + unless (equal (multiple-value-list + (subtypep* int-type rational-type)) + '(t t)) + collect (list int-type rational-type))) nil) (deftest subtypep.integer.rational.5 (loop for int-type in '((integer 10) (integer 10 *)) - append (loop for rational-type - in '(rational (rational) (rational *) (rational * *) - (rational 19/2) (rational 19/2 *) - (rational 10) (rational 10 *)) - unless (equal (multiple-value-list - (subtypep* int-type rational-type)) - '(t t)) - collect (list int-type rational-type))) + append (loop for rational-type + in '(rational (rational) (rational *) (rational * *) + (rational 19/2) (rational 19/2 *) + (rational 10) (rational 10 *)) + unless (equal (multiple-value-list + (subtypep* int-type rational-type)) + '(t t)) + collect (list int-type rational-type))) nil) (deftest subtypep.integer.rational.6 (loop for int-type in '((integer * 10) (integer * 5)) - append (loop for rational-type - in '(rational (rational) (rational *) (rational * *) - (rational * 21/2) - (rational * 10) (rational * 1000000000000)) - unless (equal (multiple-value-list - (subtypep* int-type rational-type)) - '(t t)) - collect (list int-type rational-type))) + append (loop for rational-type + in '(rational (rational) (rational *) (rational * *) + (rational * 21/2) + (rational * 10) (rational * 1000000000000)) + unless (equal (multiple-value-list + (subtypep* int-type rational-type)) + '(t t)) + collect (list int-type rational-type))) nil) (deftest subtypep.integer.rational.7 (loop for int-type in '((integer 0 10) (integer 2 5)) - append (loop for rational-type in - '(rational (rational) (rational *) (rational * *) - (rational * 10) (rational * 1000000000000) - (rational -1) (rational -1/2) - (rational -1 *) (rational -1/2 *) - (rational 0) - (rational 0 10) (rational * 10) - (rational 0 *) (rational 0 10)) - unless (equal (multiple-value-list - (subtypep* int-type rational-type)) - '(t t)) - collect (list int-type rational-type))) + append (loop for rational-type in + '(rational (rational) (rational *) (rational * *) + (rational * 10) (rational * 1000000000000) + (rational -1) (rational -1/2) + (rational -1 *) (rational -1/2 *) + (rational 0) + (rational 0 10) (rational * 10) + (rational 0 *) (rational 0 10)) + unless (equal (multiple-value-list + (subtypep* int-type rational-type)) + '(t t)) + collect (list int-type rational-type))) nil) (deftest subtypep.integer.rational.8 diff --git a/ansi-tests/subtypep-member.lsp b/ansi-tests/subtypep-member.lsp index db21a63e..9f17bf80 100644 --- a/ansi-tests/subtypep-member.lsp +++ b/ansi-tests/subtypep-member.lsp @@ -43,7 +43,7 @@ (deftest subtypep.member.9 (let ((b1 (1+ most-positive-fixnum)) - (b2 (1+ most-positive-fixnum))) + (b2 (1+ most-positive-fixnum))) (check-all-subtypep `(member 10 ,b1 20) `(member 10 20 ,b2))) nil) @@ -53,7 +53,7 @@ (deftest subtypep.member.11 (let ((b1 (copy-list '(a))) - (b2 (copy-list '(a)))) + (b2 (copy-list '(a)))) (check-all-not-subtypep `(member 10 ,b1 20) `(member 10 20 ,b2))) nil) @@ -80,9 +80,9 @@ (deftest subtypep.member.17 (let ((s1 (copy-seq "abc")) - (s2 (copy-seq "abc"))) + (s2 (copy-seq "abc"))) (let ((t1 `(member ,s1)) - (t2 `(member ,s2))) + (t2 `(member ,s2))) (cond ((subtypep t1 t2) "T1 is subtype of T2") ((subtypep t2 t1) "T2 is subtype of T1") @@ -91,9 +91,9 @@ (deftest subtypep.member.18 (let ((s1 (copy-seq '(a b c))) - (s2 (copy-seq '(a b c)))) + (s2 (copy-seq '(a b c)))) (let ((t1 `(member ,s1)) - (t2 `(member ,s2))) + (t2 `(member ,s2))) (cond ((subtypep t1 t2) "T1 is subtype of T2") ((subtypep t2 t1) "T2 is subtype of T1") @@ -102,33 +102,33 @@ (deftest subtypep.member.19 (let ((i1 (1+ most-positive-fixnum)) - (i2 (1+ most-positive-fixnum))) + (i2 (1+ most-positive-fixnum))) (check-equivalence `(member 0 ,i1) `(member 0 ,i2))) nil) (deftest subtypep.member.20 (check-equivalence '(and (member a b c d) (member e d b f g)) - '(member b d)) + '(member b d)) nil) (deftest subtypep.member.21 (check-equivalence '(and (member a b c d) (member e d f g)) - '(eql d)) + '(eql d)) nil) (deftest subtypep.member.22 (check-equivalence '(and (member a b c d) (member e f g)) - nil) + nil) nil) (deftest subtypep.member.23 (check-equivalence '(or (member a b c) (member z b w)) - '(member z a b w c)) + '(member z a b w c)) nil) (deftest subtypep.member.24 (check-equivalence '(or (member a b c) (eql d)) - '(member d c b a)) + '(member d c b a)) nil) (deftest subtypep.member.25 @@ -137,7 +137,7 @@ (deftest subtypep.member.26 (check-equivalence '(or (eql a) (eql b)) - '(member a b)) + '(member a b)) nil) (deftest subtypep.member.27 @@ -189,14 +189,14 @@ (deftest subtypep.member.38 (check-equivalence '(and (member a b c d e f g) - (not (member b f))) + (not (member b f))) '(member a c d e g)) nil) (deftest subtypep.member.39 (check-equivalence '(and (not (member b d e f g)) - (not (member x y b z d))) + (not (member x y b z d))) '(not (member b d e f g x y z))) nil) diff --git a/ansi-tests/subtypep-rational.lsp b/ansi-tests/subtypep-rational.lsp index f957b644..8afced93 100644 --- a/ansi-tests/subtypep-rational.lsp +++ b/ansi-tests/subtypep-rational.lsp @@ -11,90 +11,90 @@ (deftest subtypep.rational.1 (loop for tp1 in '((rational 10) (rational 10 *) - (rational 10 20) - (rational (10) 20) - (rational 10 (20)) - (rational (10) (20)) - (rational 10 1000000000000000) - (rational (10)) (rational (10) *)) - append - (loop for tp2 in '(rational (rational) (rational *) - (rational * *) (rational 10) (rational 10 *) - (rational 0) (rational 0 *) - (rational 19/2) (rational 19/2 *) - (rational -1000000000000000) - real (real) (real *) - (real * *) (real 10) (real 10 *) - (real 0) (real 0 *) - (real 19/2) (real 19/2 *) - (real -1000000000000000)) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(t t)) - collect (list tp1 tp2))) + (rational 10 20) + (rational (10) 20) + (rational 10 (20)) + (rational (10) (20)) + (rational 10 1000000000000000) + (rational (10)) (rational (10) *)) + append + (loop for tp2 in '(rational (rational) (rational *) + (rational * *) (rational 10) (rational 10 *) + (rational 0) (rational 0 *) + (rational 19/2) (rational 19/2 *) + (rational -1000000000000000) + real (real) (real *) + (real * *) (real 10) (real 10 *) + (real 0) (real 0 *) + (real 19/2) (real 19/2 *) + (real -1000000000000000)) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(t t)) + collect (list tp1 tp2))) nil) (deftest subtypep.rational.2 (loop for tp1 in '((rational * 10) - (rational 0 10) - (rational 0 (10)) - (rational (0) 10) - (rational (0) (10)) - (rational -1000000000000000 10) - (rational * (10))) - append - (loop for tp2 in '(rational (rational) (rational *) - (rational * *) (rational * 10) - (rational * 21/2) - (rational * 1000000000000000) - real (real) (real *) - (real * *) (real * 10) - (real * 21/2) - (real * 1000000000000000)) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(t t)) - collect (list tp1 tp2))) + (rational 0 10) + (rational 0 (10)) + (rational (0) 10) + (rational (0) (10)) + (rational -1000000000000000 10) + (rational * (10))) + append + (loop for tp2 in '(rational (rational) (rational *) + (rational * *) (rational * 10) + (rational * 21/2) + (rational * 1000000000000000) + real (real) (real *) + (real * *) (real * 10) + (real * 21/2) + (real * 1000000000000000)) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(t t)) + collect (list tp1 tp2))) nil) (deftest subtypep.rational.3 (loop for tp1 in '((rational 10) (rational 10 *) - (rational 10 20) - (rational 10 (21)) - (rational 10 1000000000000000)) - append - (loop for tp2 in '((rational 11) (rational 11 *) - (rational (10)) (rational (10) *) - (integer 10) (integer 10 *) - (real 11) - (real (10)) - (real 11 *) - (real (10) *) - (rational * (20)) - (rational * 19) - (real * (20)) - (real * 19)) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(nil t)) - collect (list tp1 tp2))) + (rational 10 20) + (rational 10 (21)) + (rational 10 1000000000000000)) + append + (loop for tp2 in '((rational 11) (rational 11 *) + (rational (10)) (rational (10) *) + (integer 10) (integer 10 *) + (real 11) + (real (10)) + (real 11 *) + (real (10) *) + (rational * (20)) + (rational * 19) + (real * (20)) + (real * 19)) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(nil t)) + collect (list tp1 tp2))) nil) (deftest subtypep.rational.4 (loop for tp1 in '((rational * 10) - (rational 0 10) - (rational (0) 10) - (rational -1000000000000000 10)) - append - (loop for tp2 in '((rational * 9) - (rational * (10)) - (integer * 10) - (real * 9) - (real * (10))) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(nil t)) - collect (list tp1 tp2))) + (rational 0 10) + (rational (0) 10) + (rational -1000000000000000 10)) + append + (loop for tp2 in '((rational * 9) + (rational * (10)) + (integer * 10) + (real * 9) + (real * (10))) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(nil t)) + collect (list tp1 tp2))) nil) (deftest subtypep.rational.5 @@ -147,22 +147,22 @@ (deftest subtypep.rational.13 (check-equivalence '(and integer (rational -1/2 1/2)) - '(integer 0 0)) + '(integer 0 0)) nil) (deftest subtypep.rational.14 (check-equivalence '(and integer (rational -1/2 1/2)) - '(eql 0)) + '(eql 0)) nil) (deftest subtypep.rational.15 (check-equivalence '(and integer (rational (-1/2) 1/2)) - '(integer 0 0)) + '(integer 0 0)) nil) (deftest subtypep.rational.16 (check-equivalence '(and integer (rational (-1/2) (1/2))) - '(integer 0 0)) + '(integer 0 0)) nil) (deftest subtypep.rational.17 diff --git a/ansi-tests/subtypep-real.lsp b/ansi-tests/subtypep-real.lsp index 64670970..6b503413 100644 --- a/ansi-tests/subtypep-real.lsp +++ b/ansi-tests/subtypep-real.lsp @@ -11,83 +11,83 @@ (deftest subtypep.real.1 (loop for tp1 in '((real 10) (real 10 *) - (real 10 20) - (real (10) 20) - (real 10 (20)) - (real (10) (20)) - (real 10 1000000000000000) - (real (10)) (real (10) *)) - append - (loop for tp2 in '(real (real) (real *) - (real * *) (real 10) (real 10 *) - (real 0) (real 0 *) - (real 19/2) (real 19/2 *) - (real 9.5) (real 9.5 *) - (real -1000000000000000)) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(t t)) - collect (list tp1 tp2))) + (real 10 20) + (real (10) 20) + (real 10 (20)) + (real (10) (20)) + (real 10 1000000000000000) + (real (10)) (real (10) *)) + append + (loop for tp2 in '(real (real) (real *) + (real * *) (real 10) (real 10 *) + (real 0) (real 0 *) + (real 19/2) (real 19/2 *) + (real 9.5) (real 9.5 *) + (real -1000000000000000)) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(t t)) + collect (list tp1 tp2))) nil) (deftest subtypep.real.2 (loop for tp1 in '((real * 10) - (real 0 10) - (real 0 (10)) - (real (0) 10) - (real (0) (10)) - (real -1000000000000000 10) - (real * (10))) - append - (loop for tp2 in '(real (real) (real *) - (real * *) (real * 10) - (real * 21/2) - (real * 10.5) - (real * 1000000000000000)) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(t t)) - collect (list tp1 tp2))) + (real 0 10) + (real 0 (10)) + (real (0) 10) + (real (0) (10)) + (real -1000000000000000 10) + (real * (10))) + append + (loop for tp2 in '(real (real) (real *) + (real * *) (real * 10) + (real * 21/2) + (real * 10.5) + (real * 1000000000000000)) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(t t)) + collect (list tp1 tp2))) nil) (deftest subtypep.real.3 (loop for tp1 in '((real 10) (real 10 *) - (real 10 20) - (real 10 (21)) - (real 10 1000000000000000)) - append - (loop for tp2 in '((real 11) (real 11 *) - (real (10)) (real (10) *) - (integer 10) (integer 10 *) - (real 11) - (real (10)) - (real 11 *) - (real (10) *) - (real * (20)) - (real * 19) - (real * (20)) - (real * 19)) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(nil t)) - collect (list tp1 tp2))) + (real 10 20) + (real 10 (21)) + (real 10 1000000000000000)) + append + (loop for tp2 in '((real 11) (real 11 *) + (real (10)) (real (10) *) + (integer 10) (integer 10 *) + (real 11) + (real (10)) + (real 11 *) + (real (10) *) + (real * (20)) + (real * 19) + (real * (20)) + (real * 19)) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(nil t)) + collect (list tp1 tp2))) nil) (deftest subtypep.real.4 (loop for tp1 in '((real * 10) - (real 0 10) - (real (0) 10) - (real -1000000000000000 10)) - append - (loop for tp2 in '((real * 9) - (real * (10)) - (integer * 10) - (real * 9) - (real * (10))) - unless (equal (multiple-value-list - (subtypep* tp1 tp2)) - '(nil t)) - collect (list tp1 tp2))) + (real 0 10) + (real (0) 10) + (real -1000000000000000 10)) + append + (loop for tp2 in '((real * 9) + (real * (10)) + (integer * 10) + (real * 9) + (real * (10))) + unless (equal (multiple-value-list + (subtypep* tp1 tp2)) + '(nil t)) + collect (list tp1 tp2))) nil) (deftest subtypep.real.5 @@ -140,22 +140,22 @@ (deftest subtypep.real.13 (check-equivalence '(and integer (real -1/2 1/2)) - '(integer 0 0)) + '(integer 0 0)) nil) (deftest subtypep.real.14 (check-equivalence '(and integer (real -1/2 1/2)) - '(eql 0)) + '(eql 0)) nil) (deftest subtypep.real.15 (check-equivalence '(and integer (real (-1/2) 1/2)) - '(integer 0 0)) + '(integer 0 0)) nil) (deftest subtypep.real.16 (check-equivalence '(and integer (real (-1/2) (1/2))) - '(integer 0 0)) + '(integer 0 0)) nil) (deftest subtypep.real.17 @@ -164,27 +164,27 @@ (deftest subtypep.real.18 (check-equivalence '(and rational (real 0 10)) - '(rational 0 10)) + '(rational 0 10)) nil) (deftest subtypep.real.19 (check-equivalence '(and rational (real 0 (10))) - '(rational 0 (10))) + '(rational 0 (10))) nil) (deftest subtypep.real.20 (check-equivalence '(and rational (real (0) (10))) - '(rational (0) (10))) + '(rational (0) (10))) nil) (deftest subtypep.real.21 (check-equivalence '(and rational (real 1/2 7/3)) - '(rational 1/2 7/3)) + '(rational 1/2 7/3)) nil) (deftest subtypep.real.22 (check-equivalence '(and rational (real (1/11) (8/37))) - '(rational (1/11) (8/37))) + '(rational (1/11) (8/37))) nil) (deftest subtypep.real.23 diff --git a/ansi-tests/subtypep.lsp b/ansi-tests/subtypep.lsp index 1bc48754..44774ae5 100644 --- a/ansi-tests/subtypep.lsp +++ b/ansi-tests/subtypep.lsp @@ -13,7 +13,7 @@ (let ((i 0) x y) (values (notnot (subtypep (progn (setf x (incf i)) t) - (progn (setf y (incf i)) t))) + (progn (setf y (incf i)) t))) i x y)) t 2 1 2) @@ -23,43 +23,43 @@ (deftest subtype.env.1 (mapcar #'notnot - (multiple-value-list (subtypep 'bit 'integer nil))) + (multiple-value-list (subtypep 'bit 'integer nil))) (t t)) (deftest subtype.env.2 (macrolet ((%foo (&environment env) - (list 'quote - (mapcar #'notnot - (multiple-value-list - (subtypep 'bit 'integer env)))))) + (list 'quote + (mapcar #'notnot + (multiple-value-list + (subtypep 'bit 'integer env)))))) (%foo)) (t t)) (deftest subtype.env.3 (macrolet ((%foo (&environment env) - (multiple-value-bind (sub good) - (subtypep nil (type-of env)) - (or (not good) (notnot sub))))) + (multiple-value-bind (sub good) + (subtypep nil (type-of env)) + (or (not good) (notnot sub))))) (%foo)) t) (deftest subtype.env.4 (macrolet ((%foo (&environment env) - (multiple-value-bind (sub good) - (subtypep (type-of env) (type-of env)) - (or (not good) (notnot sub))))) + (multiple-value-bind (sub good) + (subtypep (type-of env) (type-of env)) + (or (not good) (notnot sub))))) (%foo)) t) (deftest subtype.env.5 (macrolet ((%foo (&environment env) - (multiple-value-bind (sub good) - (subtypep (type-of env) t) - (or (not good) (notnot sub))))) + (multiple-value-bind (sub good) + (subtypep (type-of env) t) + (or (not good) (notnot sub))))) (%foo)) t) @@ -137,25 +137,25 @@ (deftest subtypep.and/or.1 (check-equivalence '(and (or symbol (integer 0 15)) - (or symbol (integer 10 25))) + (or symbol (integer 10 25))) '(or symbol (integer 10 15))) nil) (deftest subtypep.and/or.2 (check-equivalence '(and (or (not symbol) (integer 0 10)) - (or symbol (integer 11 25))) + (or symbol (integer 11 25))) '(integer 11 25)) nil) (deftest subtypep.and.1 (loop for type in *types-list3* - append (check-equivalence `(and ,type ,type) type)) + append (check-equivalence `(and ,type ,type) type)) nil) (deftest subtypep.or.1 (loop for type in *types-list3* - append (check-equivalence `(or ,type ,type) type)) + append (check-equivalence `(or ,type ,type) type)) nil) (deftest subtypep.and.2 @@ -168,35 +168,35 @@ (deftest subtypep.and.3 (loop for type in *types-list3* - append (check-equivalence `(and ,type) type)) + append (check-equivalence `(and ,type) type)) nil) (deftest subtypep.or.3 (loop for type in *types-list3* - append (check-equivalence `(or ,type) type)) + append (check-equivalence `(or ,type) type)) nil) (deftest subtypep.and.4 (let* ((n (length *types-list3*)) - (a (make-array n :initial-contents *types-list3*))) + (a (make-array n :initial-contents *types-list3*))) (trim-list (loop for i below 1000 - for tp1 = (aref a (random n)) - for tp2 = (aref a (random n)) - append (check-equivalence `(and ,tp1 ,tp2) - `(and ,tp2 ,tp1))) + for tp1 = (aref a (random n)) + for tp2 = (aref a (random n)) + append (check-equivalence `(and ,tp1 ,tp2) + `(and ,tp2 ,tp1))) 100)) nil) (deftest subtypep.or.4 (let* ((n (length *types-list3*)) - (a (make-array n :initial-contents *types-list3*))) + (a (make-array n :initial-contents *types-list3*))) (trim-list (loop for i below 1000 - for tp1 = (aref a (random n)) - for tp2 = (aref a (random n)) - append (check-equivalence `(or ,tp1 ,tp2) - `(or ,tp2 ,tp1))) + for tp1 = (aref a (random n)) + for tp2 = (aref a (random n)) + append (check-equivalence `(or ,tp1 ,tp2) + `(or ,tp2 ,tp1))) 100)) nil) @@ -205,13 +205,13 @@ (deftest subtypep.nil.1 (loop for (type) in *subtype-table* - unless (member type '(nil extended-char)) - append (check-all-not-subtypep type nil)) + unless (member type '(nil extended-char)) + append (check-all-not-subtypep type nil)) nil) (deftest subtypep.nil.2 (loop for (type) in *subtype-table* - for class = (find-class type nil) - unless (or (not class) (member type '(nil extended-char))) - append (check-all-not-subtypep class nil)) + for class = (find-class type nil) + unless (or (not class) (member type '(nil extended-char))) + append (check-all-not-subtypep class nil)) nil) diff --git a/ansi-tests/svref.lsp b/ansi-tests/svref.lsp index f9e405ad..0b8f6d1f 100644 --- a/ansi-tests/svref.lsp +++ b/ansi-tests/svref.lsp @@ -14,27 +14,27 @@ (let ((a (vector 1 2 3 4))) (values (loop for i below 4 - collect (setf (svref a i) (+ i 10))) + collect (setf (svref a i) (+ i 10))) a)) (10 11 12 13) #(10 11 12 13)) (deftest svref.order.1 (let ((v (vector 'a 'b 'c 'd)) - (i 0) a b) + (i 0) a b) (values (svref (progn (setf a (incf i)) v) - (progn (setf b (incf i)) 2)) + (progn (setf b (incf i)) 2)) i a b)) c 2 1 2) (deftest svref.order.2 (let ((v (vector 'a 'b 'c 'd)) - (i 0) a b c) + (i 0) a b c) (values (setf (svref (progn (setf a (incf i)) v) - (progn (setf b (incf i)) 2)) + (progn (setf b (incf i)) 2)) (progn (setf c (incf i)) 'w)) v i a b c)) w #(a b w d) 3 1 2 3) diff --git a/ansi-tests/sxhash.lsp b/ansi-tests/sxhash.lsp index f5682f65..166ba724 100644 --- a/ansi-tests/sxhash.lsp +++ b/ansi-tests/sxhash.lsp @@ -11,11 +11,11 @@ (deftest sxhash.2 (loop for i from 0 below 256 - for c = (code-char i) - when (and c - (not (= (sxhash (string c)) - (sxhash (string c))))) - collect c) + for c = (code-char i) + when (and c + (not (= (sxhash (string c)) + (sxhash (string c))))) + collect c) nil) (deftest sxhash.3 @@ -24,125 +24,125 @@ (deftest sxhash.4 (loop for bv1 in '(#* #*0 #*1 #*01 #*00 #*10 #*11 - #*1100101101100 #*110010101011001011010000111001011) - for bv2 = (copy-seq bv1) - for sx1 = (sxhash bv1) - for sx2 = (sxhash bv2) - always (and (not (eq bv1 bv2)) - (equal bv1 bv2) - (typep sx1 '(and unsigned-byte fixnum)) - (typep sx2 '(and unsigned-byte fixnum)) - (= sx1 sx2))) + #*1100101101100 #*110010101011001011010000111001011) + for bv2 = (copy-seq bv1) + for sx1 = (sxhash bv1) + for sx2 = (sxhash bv2) + always (and (not (eq bv1 bv2)) + (equal bv1 bv2) + (typep sx1 '(and unsigned-byte fixnum)) + (typep sx2 '(and unsigned-byte fixnum)) + (= sx1 sx2))) t) (deftest sxhash.5 (let ((s1 "abcd") - (s2 (make-array 10 :element-type 'character - :initial-contents "abcdefghij" - :fill-pointer 4))) + (s2 (make-array 10 :element-type 'character + :initial-contents "abcdefghij" + :fill-pointer 4))) (and (equalt s1 s2) - (=t (sxhash s1) (sxhash s2)))) + (=t (sxhash s1) (sxhash s2)))) t) (deftest sxhash.6 (let ((s1 #*01101) - (s2 (make-array 10 :element-type 'bit - :initial-contents #*0110111101 - :fill-pointer 5))) + (s2 (make-array 10 :element-type 'bit + :initial-contents #*0110111101 + :fill-pointer 5))) (and (equalt s1 s2) - (=t (sxhash s1) (sxhash s2)))) + (=t (sxhash s1) (sxhash s2)))) t) (deftest sxhash.7 (let* ((a (make-array 10 :initial-element nil)) - (sx1 (sxhash a))) + (sx1 (sxhash a))) (setf (aref a 4) 'x) (let ((sx2 (sxhash a))) (and (typep sx1 '(and unsigned-byte fixnum)) - (eqlt sx1 sx2)))) + (eqlt sx1 sx2)))) t) (deftest sxhash.8 :notes (:nil-vectors-are-strings) (eqlt (sxhash (make-array 0 :element-type nil)) - (sxhash "")) + (sxhash "")) t) (deftest sxhash.9 (let ((s1 (make-array 5 :element-type 'base-char :initial-contents "abcde")) - (s2 (copy-seq "abcde"))) + (s2 (copy-seq "abcde"))) (eqlt (sxhash s1) (sxhash s2))) t) (deftest sxhash.10 (let ((s1 "abcd") - (s2 (make-array 10 :element-type 'base-char - :initial-contents "abcdefghij" - :fill-pointer 4))) + (s2 (make-array 10 :element-type 'base-char + :initial-contents "abcdefghij" + :fill-pointer 4))) (and (equalt s1 s2) - (=t (sxhash s1) (sxhash s2)))) + (=t (sxhash s1) (sxhash s2)))) t) (deftest sxhash.11 (let* ((x (cons 'a 'b)) - (sx1 (sxhash x)) - (sx2 (sxhash '(a . b)))) + (sx1 (sxhash x)) + (sx2 (sxhash '(a . b)))) (setf (car x) 'c) (let* ((sx3 (sxhash x)) - (sx4 (sxhash '(c . b)))) + (sx4 (sxhash '(c . b)))) (and (=t sx1 sx2) - (=t sx3 sx4)))) + (=t sx3 sx4)))) t) (deftest sxhash.12 (let ((x (1+ most-positive-fixnum)) - (y (1+ most-positive-fixnum))) + (y (1+ most-positive-fixnum))) (=t (sxhash x) (sxhash y))) t) (deftest sxhash.13 (let ((sx1 (sxhash (make-symbol "FOO"))) - (sx2 (sxhash (make-symbol "FOO")))) + (sx2 (sxhash (make-symbol "FOO")))) (and (typep sx1 '(and unsigned-byte fixnum)) - (eqlt sx1 sx2))) + (eqlt sx1 sx2))) t) ;; (deftest sxhash.14 ;; (let ((sx1 (sxhash :foo)) -;; (sx2 (sxhash '#:foo))) +;; (sx2 (sxhash '#:foo))) ;; (and (typep sx1 '(and unsigned-byte fixnum)) -;; (eqlt sx1 sx2))) +;; (eqlt sx1 sx2))) ;; t) (deftest sxhash.15 (let* ((package-name - (loop for i from 0 - for name = (format nil "PACKAGE-~A" i) - for package = (find-package name) - unless package do (return name))) - (sx1 - (let* ((package (make-package package-name :nicknames nil :use nil)) - (symbol (intern "FOO" package))) - (prog1 - (sxhash symbol) - (delete-package package)))) - (sx2 - (let* ((package (make-package package-name :nicknames nil :use nil)) - (symbol (intern "FOO" package))) - (prog1 - (sxhash symbol) - (delete-package package))))) + (loop for i from 0 + for name = (format nil "PACKAGE-~A" i) + for package = (find-package name) + unless package do (return name))) + (sx1 + (let* ((package (make-package package-name :nicknames nil :use nil)) + (symbol (intern "FOO" package))) + (prog1 + (sxhash symbol) + (delete-package package)))) + (sx2 + (let* ((package (make-package package-name :nicknames nil :use nil)) + (symbol (intern "FOO" package))) + (prog1 + (sxhash symbol) + (delete-package package))))) (assert (typep sx1 '(and unsigned-byte fixnum))) (if (= sx1 sx2) :good (list sx1 sx2))) :good) (deftest sxhash.16 (let ((c1 (list 'a)) - (c2 (list 'a))) + (c2 (list 'a))) (setf (cdr c1) c1) (setf (cdr c2) c2) (let ((sx1 (sxhash c1)) - (sx2 (sxhash c2))) + (sx2 (sxhash c2))) (or (eqlt sx1 sx2) (list sx1 sx2)))) t) @@ -154,113 +154,113 @@ (deftest sxhash.17 :notes (:negative-zero-is-similar-to-positive-zero) (loop for c1 in '(0.0s0 0.0f0 0.0d0 0.0l0) - for c2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) - for t1 = (type-of c1) - for t2 = (type-of c2) - for sx1 = (sxhash c1) - for sx2 = (sxhash c2) - unless (or (not (subtypep t1 t2)) - (not (subtypep t2 t1)) - (eql sx1 sx2)) - collect (list c1 c2 sx1 sx2)) + for c2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) + for t1 = (type-of c1) + for t2 = (type-of c2) + for sx1 = (sxhash c1) + for sx2 = (sxhash c2) + unless (or (not (subtypep t1 t2)) + (not (subtypep t2 t1)) + (eql sx1 sx2)) + collect (list c1 c2 sx1 sx2)) nil) (deftest sxhash.18 :notes (:negative-zero-is-similar-to-positive-zero) (loop for r1 in '(0.0s0 0.0f0 0.0d0 0.0l0) - for c1 = (complex r1) - for r2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) - for c2 = (complex r2) - for t1 = (type-of c1) - for t2 = (type-of c2) - for sx1 = (sxhash c1) - for sx2 = (sxhash c2) - unless (or (not (subtypep t1 t2)) - (not (subtypep t2 t1)) - (eql sx1 sx2)) - collect (list c1 c2 sx1 sx2)) + for c1 = (complex r1) + for r2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) + for c2 = (complex r2) + for t1 = (type-of c1) + for t2 = (type-of c2) + for sx1 = (sxhash c1) + for sx2 = (sxhash c2) + unless (or (not (subtypep t1 t2)) + (not (subtypep t2 t1)) + (eql sx1 sx2)) + collect (list c1 c2 sx1 sx2)) nil) (deftest sxhash.19 :notes (:negative-zero-is-similar-to-positive-zero) (loop for r1 in '(0.0s0 0.0f0 0.0d0 0.0l0) - for c1 = (complex 0 r1) - for r2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) - for c2 = (complex 0 r2) - for t1 = (type-of c1) - for t2 = (type-of c2) - for sx1 = (sxhash c1) - for sx2 = (sxhash c2) - unless (or (not (subtypep t1 t2)) - (not (subtypep t2 t1)) - (eql sx1 sx2)) - collect (list c1 c2 sx1 sx2)) + for c1 = (complex 0 r1) + for r2 in '(-0.0s0 -0.0f0 -0.0d0 -0.0l0) + for c2 = (complex 0 r2) + for t1 = (type-of c1) + for t2 = (type-of c2) + for sx1 = (sxhash c1) + for sx2 = (sxhash c2) + unless (or (not (subtypep t1 t2)) + (not (subtypep t2 t1)) + (eql sx1 sx2)) + collect (list c1 c2 sx1 sx2)) nil) ;;; Similar pathnames have the same hash (deftest sxhash.20 (let* ((pathspec "sxhash.lsp") - (sx1 (sxhash (pathname (copy-seq pathspec)))) - (sx2 (sxhash (pathname (copy-seq pathspec))))) + (sx1 (sxhash (pathname (copy-seq pathspec)))) + (sx2 (sxhash (pathname (copy-seq pathspec))))) (if (and (typep sx1 '(and fixnum unsigned-byte)) - (eql sx1 sx2)) - :good + (eql sx1 sx2)) + :good (list sx1 sx2))) :good) ;;; Similarity for strings (deftest sxhash.21 (let* ((s1 "abc") - (s2 (make-array '(3) :element-type 'character - :initial-contents s1)) - (s3 (make-array '(3) :element-type 'base-char - :initial-contents s1)) - (s4 (make-array '(3) :element-type 'standard-char - :initial-contents s1)) - (s5 (make-array '(3) :element-type 'character - :adjustable t - :initial-contents "abc")) - (s6 (make-array '(5) :element-type 'character - :fill-pointer 3 - :initial-contents "abcde")) - (s7 (make-array '(3) :element-type 'character - :displaced-to s2 - :displaced-index-offset 0)) - (s8 (make-array '(3) :element-type 'character - :displaced-to (make-array '(7) :element-type 'character - :initial-contents "xxabcyy") - :displaced-index-offset 2)) - (strings (list s1 s2 s3 s4 s5 s6 s7 s8)) - (hashes (mapcar #'sxhash strings))) + (s2 (make-array '(3) :element-type 'character + :initial-contents s1)) + (s3 (make-array '(3) :element-type 'base-char + :initial-contents s1)) + (s4 (make-array '(3) :element-type 'standard-char + :initial-contents s1)) + (s5 (make-array '(3) :element-type 'character + :adjustable t + :initial-contents "abc")) + (s6 (make-array '(5) :element-type 'character + :fill-pointer 3 + :initial-contents "abcde")) + (s7 (make-array '(3) :element-type 'character + :displaced-to s2 + :displaced-index-offset 0)) + (s8 (make-array '(3) :element-type 'character + :displaced-to (make-array '(7) :element-type 'character + :initial-contents "xxabcyy") + :displaced-index-offset 2)) + (strings (list s1 s2 s3 s4 s5 s6 s7 s8)) + (hashes (mapcar #'sxhash strings))) (if (and (every #'(lambda (h) (typep h '(and unsigned-byte fixnum))) hashes) - (not (position (car hashes) hashes :test #'/=))) - :good + (not (position (car hashes) hashes :test #'/=))) + :good hashes)) :good) ;;; Similarity for bit vectors (deftest sxhash.22 (let* ((bv1 #*010) - (bv2 (make-array '(3) :element-type 'bit - :initial-contents bv1)) - (bv5 (make-array '(3) :element-type 'bit - :adjustable t - :initial-contents bv1)) - (bv6 (make-array '(5) :element-type 'bit - :fill-pointer 3 - :initial-contents #*01010)) - (bv7 (make-array '(3) :element-type 'bit - :displaced-to bv2 - :displaced-index-offset 0)) - (bv8 (make-array '(3) :element-type 'bit - :displaced-to (make-array '(7) :element-type 'bit - :initial-contents #*1101001) - :displaced-index-offset 2)) - (bit-vectors (list bv1 bv2 bv5 bv6 bv7 bv8)) - (hashes (mapcar #'sxhash bit-vectors))) + (bv2 (make-array '(3) :element-type 'bit + :initial-contents bv1)) + (bv5 (make-array '(3) :element-type 'bit + :adjustable t + :initial-contents bv1)) + (bv6 (make-array '(5) :element-type 'bit + :fill-pointer 3 + :initial-contents #*01010)) + (bv7 (make-array '(3) :element-type 'bit + :displaced-to bv2 + :displaced-index-offset 0)) + (bv8 (make-array '(3) :element-type 'bit + :displaced-to (make-array '(7) :element-type 'bit + :initial-contents #*1101001) + :displaced-index-offset 2)) + (bit-vectors (list bv1 bv2 bv5 bv6 bv7 bv8)) + (hashes (mapcar #'sxhash bit-vectors))) (if (and (every #'(lambda (h) (typep h '(and unsigned-byte fixnum))) hashes) - (not (position (car hashes) hashes :test #'/=))) - :good + (not (position (car hashes) hashes :test #'/=))) + :good hashes)) :good) @@ -270,12 +270,12 @@ (safely-delete-package "A") (defpackage "A" (:use)) (let* ((pkg (find-package "A")) - (sym (intern "FOO" pkg)) - (hash (sxhash sym))) + (sym (intern "FOO" pkg)) + (hash (sxhash sym))) (unintern sym pkg) (let ((hash2 (sxhash sym))) - (if (eql hash hash2) nil (list hash hash2))))) - nil) + (if (eql hash hash2) nil (list hash hash2))))) + nil) ;;; Error cases diff --git a/ansi-tests/symbol-function.lsp b/ansi-tests/symbol-function.lsp index 9aa6b64c..19659a8e 100644 --- a/ansi-tests/symbol-function.lsp +++ b/ansi-tests/symbol-function.lsp @@ -7,7 +7,7 @@ (deftest symbol-function.1 (let ((sym (gensym)) - (f #'(lambda () (values 1 2 3)))) + (f #'(lambda () (values 1 2 3)))) (values (eqt (setf (symbol-function sym) f) f) (multiple-value-list (eval (list sym))))) @@ -29,16 +29,16 @@ (deftest symbol-function.error.4 (check-type-error #'(lambda (x) (setf (symbol-function x) #'identity)) - #'symbolp) + #'symbolp) nil) (deftest symbol-function.error.5 (let ((sym (gensym))) (handler-case (progn (symbol-function sym) nil) - (undefined-function - (c) - (assert (eq (cell-error-name c) sym)) - :good))) + (undefined-function + (c) + (assert (eq (cell-error-name c) sym)) + :good))) :good) diff --git a/ansi-tests/symbol-macrolet.lsp b/ansi-tests/symbol-macrolet.lsp index 9dde62ff..dc331cbe 100644 --- a/ansi-tests/symbol-macrolet.lsp +++ b/ansi-tests/symbol-macrolet.lsp @@ -7,9 +7,9 @@ (deftest symbol-macrolet.1 (loop for s in *cl-non-variable-constant-symbols* - for form = `(ignore-errors (symbol-macrolet ((,s 17)) ,s)) - unless (eql (eval form) 17) - collect s) + for form = `(ignore-errors (symbol-macrolet ((,s 17)) ,s)) + unless (eql (eval form) 17) + collect s) nil) (deftest symbol-macrolet.2 @@ -30,17 +30,17 @@ (let ((x 10)) (symbol-macrolet ((y x)) (list x - y - (let ((x 20)) x) - (let ((y 30)) x) - (let ((y 50)) y) - x - y))) + y + (let ((x 20)) x) + (let ((y 30)) x) + (let ((y 50)) y) + x + y))) (10 10 20 10 50 10 10)) (deftest symbol-macrolet.6 (symbol-macrolet () (values))) - + (deftest symbol-macrolet.7 (symbol-macrolet () (values 'a 'b 'c 'd 'e)) a b c d e) @@ -52,7 +52,7 @@ (symbol-macrolet () (declare (special x)) x))) :good) -;;; Error tests +;;; Error tests (deftest symbol-macrolet.error.1 (signals-error @@ -66,13 +66,13 @@ (deftest symbol-macrolet.error.2 (signals-error (symbol-macrolet ((constant-for-symbol-macrolet.error.2 'a)) - constant-for-symbol-macrolet.error.2) - program-error) + constant-for-symbol-macrolet.error.2) + program-error) t) (deftest symbol-macrolet.error.3 (signals-error (symbol-macrolet ((*pathnames* 19)) *pathnames*) - program-error) + program-error) t) ;;; Test that explicit calls to macroexpand in subforms diff --git a/ansi-tests/synonym-stream-symbol.lsp b/ansi-tests/synonym-stream-symbol.lsp index 11eb6e63..c71c298a 100644 --- a/ansi-tests/synonym-stream-symbol.lsp +++ b/ansi-tests/synonym-stream-symbol.lsp @@ -15,9 +15,9 @@ (deftest synonym-stream-symbol.error.2 (signals-error (synonym-stream-symbol - (make-synonym-stream '*terminal-io*) - nil) - program-error) + (make-synonym-stream '*terminal-io*) + nil) + program-error) t) diff --git a/ansi-tests/syntax-tokens.lsp b/ansi-tests/syntax-tokens.lsp index 82f9bdff..debfd0e4 100644 --- a/ansi-tests/syntax-tokens.lsp +++ b/ansi-tests/syntax-tokens.lsp @@ -16,50 +16,50 @@ #| (def-syntax-test syntax.number-token.error.2 (loop for f in (list most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float) - for c across "sfdl" - for r = (float-radix f) - for x = (nth-value 1 (decode-float f)) - for n = (1+ (ceiling (* (log r 10) x))) - for s = (format nil "1.0~C~D" c n) - for vals = (multiple-value-list - (eval `(signals-error (read-from-string ,s) - reader-error))) - unless (equal vals '(t)) - collect (list f c r x n s vals)) + most-positive-single-float + most-positive-double-float + most-positive-long-float) + for c across "sfdl" + for r = (float-radix f) + for x = (nth-value 1 (decode-float f)) + for n = (1+ (ceiling (* (log r 10) x))) + for s = (format nil "1.0~C~D" c n) + for vals = (multiple-value-list + (eval `(signals-error (read-from-string ,s) + reader-error))) + unless (equal vals '(t)) + collect (list f c r x n s vals)) nil) |# (def-syntax-test syntax.number-token.3 (loop for tp in '(short-float single-float double-float long-float) - for c across "sfdl" - for s = (concatenate 'string "1.0" - (make-string 1000 :initial-element #\0) - "1" (string c) "0") - for n = (read-from-string s) - unless (and (typep n tp) - (<= 1 n) - (< n 2)) - collect (list c tp s n)) + for c across "sfdl" + for s = (concatenate 'string "1.0" + (make-string 1000 :initial-element #\0) + "1" (string c) "0") + for n = (read-from-string s) + unless (and (typep n tp) + (<= 1 n) + (< n 2)) + collect (list c tp s n)) nil) (def-syntax-test syntax.number-token.4 (loop for type in '(short-float single-float double-float long-float) - nconc - (let* ((*read-default-float-format* type) - (s (concatenate 'string - "1." (make-string 1000 :initial-element #\0) - "1")) - (n (read-from-string s))) - (unless (and (typep n type) - (<= 1 n) - (< n 2)) - (list (list type s n))))) + nconc + (let* ((*read-default-float-format* type) + (s (concatenate 'string + "1." (make-string 1000 :initial-element #\0) + "1")) + (n (read-from-string s))) + (unless (and (typep n type) + (<= 1 n) + (< n 2)) + (list (list type s n))))) nil) - + ;;; Dot tokens (def-syntax-test syntax.dot-token.1 diff --git a/ansi-tests/syntax.lsp b/ansi-tests/syntax.lsp index a9b5a18d..d8f6a79a 100644 --- a/ansi-tests/syntax.lsp +++ b/ansi-tests/syntax.lsp @@ -11,28 +11,28 @@ ;; Check that various standard or semistandard characters are whitespace[2] (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page"))) (loop for name in names - for c = (name-char name) - nconc - (when c - (let* ((s (concatenate 'string (string c) "123")) - (val (read-from-string s))) - (unless (eql val 123) - (list (list name c s val))))))) + for c = (name-char name) + nconc + (when c + (let* ((s (concatenate 'string (string c) "123")) + (val (read-from-string s))) + (unless (eql val 123) + (list (list name c s val))))))) nil) (def-syntax-test syntax.constituent.1 ;; Tests of various characters that they are constituent characters, ;; and parse to symbols (let ((chars (concatenate - 'string - "!$%&*<=>?@[]^_-{}+/" - "abcdefghijklmnopqrstuvwxyz" - "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))) + 'string + "!$%&*<=>?@[]^_-{}+/" + "abcdefghijklmnopqrstuvwxyz" + "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))) (loop for c across chars - for s = (string c) - for sym = (read-from-string s) - unless (string= (symbol-name sym) (string-upcase s)) - collect (list c sym))) + for s = (string c) + for sym = (read-from-string s) + unless (string= (symbol-name sym) (string-upcase s)) + collect (list c sym))) nil) ;;; Backspace is an invalid constituent character @@ -55,110 +55,110 @@ (def-syntax-test syntax.digits.alphabetic.1 (loop for base from 2 to 9 - nconc - (let ((*read-base* base)) - (loop for digit-val from base to 9 - for c = (elt "0123456789" digit-val) - for s = (string c) - for val = (read-from-string s) - unless (and (symbolp val) - (string= s (symbol-name val))) - collect (list base digit-val c s val)))) + nconc + (let ((*read-base* base)) + (loop for digit-val from base to 9 + for c = (elt "0123456789" digit-val) + for s = (string c) + for val = (read-from-string s) + unless (and (symbolp val) + (string= s (symbol-name val))) + collect (list base digit-val c s val)))) nil) ;;; Reading escaped characters (def-syntax-test syntax.escaped.1 (loop for c across +standard-chars+ - for s0 = (string c) - for s = (concatenate 'string "\\" s0) - for sym = (read-from-string s) - unless (and (symbolp sym) - (string= (symbol-name sym) s0)) - collect (list c s0 s sym)) + for s0 = (string c) + for s = (concatenate 'string "\\" s0) + for sym = (read-from-string s) + unless (and (symbolp sym) + (string= (symbol-name sym) s0)) + collect (list c s0 s sym)) nil) (def-syntax-test syntax.escaped.2 (let ((count 0)) (loop for i from 0 below (min 65536 char-code-limit) - for c = (code-char i) - for s0 = (and c (string c)) - for s = (and c (concatenate 'string "\\" s0)) - for sym = (and c (read-from-string s)) - unless (or (not c) - (and (symbolp sym) - (string= (symbol-name sym) s0))) - collect (progn - (when (> (incf count) 100) (loop-finish)) - (list i c s0 s sym)))) + for c = (code-char i) + for s0 = (and c (string c)) + for s = (and c (concatenate 'string "\\" s0)) + for sym = (and c (read-from-string s)) + unless (or (not c) + (and (symbolp sym) + (string= (symbol-name sym) s0))) + collect (progn + (when (> (incf count) 100) (loop-finish)) + (list i c s0 s sym)))) nil) (def-syntax-test syntax.escaped.3 (loop for i = (random (min char-code-limit (ash 1 24))) - for c = (code-char i) - for s0 = (and c (string c)) - for s = (and c (concatenate 'string "\\" s0)) - for sym = (and c (read-from-string s)) - repeat 1000 - unless (or (not c) - (and (symbolp sym) - (string= (symbol-name sym) s0))) - collect (list i c s0 s sym)) + for c = (code-char i) + for s0 = (and c (string c)) + for s = (and c (concatenate 'string "\\" s0)) + for sym = (and c (read-from-string s)) + repeat 1000 + unless (or (not c) + (and (symbolp sym) + (string= (symbol-name sym) s0))) + collect (list i c s0 s sym)) nil) (def-syntax-test syntax.escaped.4 (loop for c across +standard-chars+ - for bad = (find c "\\|") - for s0 = (string c) - for s = (concatenate 'string "|" s0 "|") - for sym = (and (not bad) (read-from-string s)) - unless (or bad - (and (symbolp sym) - (string= (symbol-name sym) s0))) - collect (list c s0 s sym)) + for bad = (find c "\\|") + for s0 = (string c) + for s = (concatenate 'string "|" s0 "|") + for sym = (and (not bad) (read-from-string s)) + unless (or bad + (and (symbolp sym) + (string= (symbol-name sym) s0))) + collect (list c s0 s sym)) nil) (def-syntax-test syntax.escaped.5 (let ((count 0)) (loop for i from 0 below (min 65536 char-code-limit) - for c = (code-char i) - for bad = (or (not c) (find c "\\|")) - for s0 = (and c (string c)) - for s = (and c (concatenate 'string "|" s0 "|")) - for sym = (and c (not bad) (read-from-string s)) - unless (or bad - (and (symbolp sym) - (string= (symbol-name sym) s0))) - collect (progn - (when (> (incf count) 100) (loop-finish)) - (list c s0 s sym)))) + for c = (code-char i) + for bad = (or (not c) (find c "\\|")) + for s0 = (and c (string c)) + for s = (and c (concatenate 'string "|" s0 "|")) + for sym = (and c (not bad) (read-from-string s)) + unless (or bad + (and (symbolp sym) + (string= (symbol-name sym) s0))) + collect (progn + (when (> (incf count) 100) (loop-finish)) + (list c s0 s sym)))) nil) (def-syntax-test syntax.escaped.6 (loop for i = (random (min char-code-limit (ash 1 24))) - for c = (code-char i) - for bad = (or (not c) (find c "\\|")) - for s0 = (and c (string c)) - for s = (and c (concatenate 'string "|" s0 "|")) - for sym = (and (not bad) (read-from-string s)) - repeat 1000 - unless (or bad - (and (symbolp sym) - (string= (symbol-name sym) s0))) - collect (list c s0 s sym)) + for c = (code-char i) + for bad = (or (not c) (find c "\\|")) + for s0 = (and c (string c)) + for s = (and c (concatenate 'string "|" s0 "|")) + for sym = (and (not bad) (read-from-string s)) + repeat 1000 + unless (or bad + (and (symbolp sym) + (string= (symbol-name sym) s0))) + collect (list c s0 s sym)) nil) (def-syntax-test syntax.escape.whitespace.1 (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page" - "Rubout" "Backspace"))) + "Rubout" "Backspace"))) (loop for name in names - for c = (name-char name) - nconc - (when c - (let* ((s (concatenate 'string "\\" (string c))) - (val (read-from-string s))) - (unless (eql val (intern (string c))) - (list (list name c s val))))))) + for c = (name-char name) + nconc + (when c + (let* ((s (concatenate 'string "\\" (string c))) + (val (read-from-string s))) + (unless (eql val (intern (string c))) + (list (list name c s val))))))) nil) ;;; @@ -169,28 +169,28 @@ (def-syntax-test syntax.escape.whitespace.2 (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page"))) (loop for name in names - for c = (name-char name) - nconc - (when c - (let* ((s (concatenate 'string "|" (string c) "|")) - (val (read-from-string s))) - (unless (eql val (intern (string c))) - (list (list name c s val))))))) + for c = (name-char name) + nconc + (when c + (let* ((s (concatenate 'string "|" (string c) "|")) + (val (read-from-string s))) + (unless (eql val (intern (string c))) + (list (list name c s val))))))) nil) #| (def-syntax-test syntax.multiple-escape.invalid.backspace (let ((c (name-char "Backspace"))) (or (not c) - (let ((s (concatenate 'string "|" (string c) "|"))) - (eval `(signals-error (read-from-string ',s) reader-error))))) + (let ((s (concatenate 'string "|" (string c) "|"))) + (eval `(signals-error (read-from-string ',s) reader-error))))) t) (def-syntax-test syntax.multiple-escape.invalid.rubout (let ((c (name-char "Rubout"))) (or (not c) - (let ((s (concatenate 'string "|" (string c) "|"))) - (eval `(signals-error (read-from-string ',s) reader-error))))) + (let ((s (concatenate 'string "|" (string c) "|"))) + (eval `(signals-error (read-from-string ',s) reader-error))))) t) |# @@ -199,90 +199,90 @@ (def-syntax-test syntax.sharp-backslash.1 (loop for c across +standard-chars+ - for s = (concatenate 'string "#\\" (string c)) - for c2 = (read-from-string s) - unless (eql c c2) - collect (list c s c2)) + for s = (concatenate 'string "#\\" (string c)) + for c2 = (read-from-string s) + unless (eql c c2) + collect (list c s c2)) nil) (def-syntax-test syntax.sharp-backslash.2 (let ((count 0)) (loop for i below (min 65536 char-code-limit) - for c = (code-char i) - for s = (and c (concatenate 'string "#\\" (string c))) - for c2 = (and c (read-from-string s)) - unless (eql c c2) - collect (progn (when (> (incf count) 100) (loop-finish)) - (list c s c2)))) + for c = (code-char i) + for s = (and c (concatenate 'string "#\\" (string c))) + for c2 = (and c (read-from-string s)) + unless (eql c c2) + collect (progn (when (> (incf count) 100) (loop-finish)) + (list c s c2)))) nil) (def-syntax-test syntax.sharp-backslash.3 (loop for i = (random (min (ash 1 24) char-code-limit)) - for c = (code-char i) - for s = (and c (concatenate 'string "#\\" (string c))) - for c2 = (and c (read-from-string s)) - repeat 1000 - unless (eql c c2) - collect (list i c s c2)) + for c = (code-char i) + for s = (and c (concatenate 'string "#\\" (string c))) + for c2 = (and c (read-from-string s)) + repeat 1000 + unless (eql c c2) + collect (list i c s c2)) nil) (def-syntax-test syntax.sharp-backslash.4 (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) (loop for s in '("SPACE" "NEWLINE" "TAB" "RUBOUT" "BACKSPACE" "PAGE" "LINEFEED" "RETURN") - for c = (name-char s) - unless (or (null c) - (and (eql (%f s) c) - (eql (%f (string-downcase s)) c) - (eql (%f (string-capitalize s)) c))) - collect (list s c))) + for c = (name-char s) + unless (or (null c) + (and (eql (%f s) c) + (eql (%f (string-downcase s)) c) + (eql (%f (string-capitalize s)) c))) + collect (list s c))) nil) (def-syntax-test syntax.sharp-backslash.5 (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) (let ((good-chars (concatenate 'string +alphanumeric-chars+ - "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) + "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) (loop for c across +standard-chars+ - for name = (char-name c) - unless (or (null name) - (string/= "" (string-trim good-chars name)) - (and (eql (%f name) c) - (eql (%f (string-downcase name)) c) - (eql (%f (string-upcase name)) c) - (eql (%f (string-capitalize name)) c))) - collect (list c name)))) + for name = (char-name c) + unless (or (null name) + (string/= "" (string-trim good-chars name)) + (and (eql (%f name) c) + (eql (%f (string-downcase name)) c) + (eql (%f (string-upcase name)) c) + (eql (%f (string-capitalize name)) c))) + collect (list c name)))) nil) (def-syntax-test syntax.sharp-backslash.6 (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) (let ((good-chars (concatenate 'string +alphanumeric-chars+ - "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) + "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) (loop for i below (min 65536 char-code-limit) - for c = (code-char i) - for name = (and c (char-name c)) - unless (or (null name) - (string/= "" (string-trim good-chars name)) - (and (eql (%f name) c) - (eql (%f (string-downcase name)) c) - (eql (%f (string-upcase name)) c) - (eql (%f (string-capitalize name)) c))) - collect (list i c name)))) + for c = (code-char i) + for name = (and c (char-name c)) + unless (or (null name) + (string/= "" (string-trim good-chars name)) + (and (eql (%f name) c) + (eql (%f (string-downcase name)) c) + (eql (%f (string-upcase name)) c) + (eql (%f (string-capitalize name)) c))) + collect (list i c name)))) nil) (def-syntax-test syntax.sharp-backslash.7 (flet ((%f (s) (read-from-string (concatenate 'string "#\\" s)))) (let ((good-chars (concatenate 'string +alphanumeric-chars+ - "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) + "<,.>\"':/?[]{}~`!@#$%^&*_-+="))) (loop for i = (random (min (ash 1 24) char-code-limit)) - for c = (code-char i) - for name = (and c (char-name c)) - repeat 1000 - unless (or (null name) - (string/= "" (string-trim good-chars name)) - (and (eql (%f name) c) - (eql (%f (string-downcase name)) c) - (eql (%f (string-upcase name)) c) - (eql (%f (string-capitalize name)) c))) - collect (list i c name)))) + for c = (code-char i) + for name = (and c (char-name c)) + repeat 1000 + unless (or (null name) + (string/= "" (string-trim good-chars name)) + (and (eql (%f name) c) + (eql (%f (string-downcase name)) c) + (eql (%f (string-upcase name)) c) + (eql (%f (string-capitalize name)) c))) + collect (list i c name)))) nil) @@ -596,21 +596,21 @@ (def-syntax-test syntax.sharp-r.1 (loop for i = (random (ash 1 (+ 2 (random 32)))) - for base = (+ 2 (random 35)) - for s = (write-to-string i :radix nil :base base :readably nil) - for c = (random-from-seq "rR") - for s2 = (format nil "#~d~c~a" base c s) - for s3 = (rcase (1 (string-upcase s2)) - (1 (string-downcase s2)) - (1 (string-capitalize s2)) - (1 s2)) - for base2 = (+ 2 (random 35)) - for vals = (let ((*read-base* base2)) - (multiple-value-list - (read-from-string s3))) - repeat 1000 - unless (equal vals (list i (length s3) )) - collect (list i base s c s2 s3 base2 vals)) + for base = (+ 2 (random 35)) + for s = (write-to-string i :radix nil :base base :readably nil) + for c = (random-from-seq "rR") + for s2 = (format nil "#~d~c~a" base c s) + for s3 = (rcase (1 (string-upcase s2)) + (1 (string-downcase s2)) + (1 (string-capitalize s2)) + (1 s2)) + for base2 = (+ 2 (random 35)) + for vals = (let ((*read-base* base2)) + (multiple-value-list + (read-from-string s3))) + repeat 1000 + unless (equal vals (list i (length s3) )) + collect (list i base s c s2 s3 base2 vals)) nil) (def-syntax-test syntax.sharp-r.2 @@ -665,20 +665,20 @@ (def-syntax-test syntax.sharp-c.6 (loop for format in '(short-float single-float double-float long-float) - for c = (let ((*read-default-float-format* format)) - (read-from-string "#c(1.0 0.0)")) - unless (eql c (complex (coerce 1 format) - (coerce 0 format))) - collect (list format c)) + for c = (let ((*read-default-float-format* format)) + (read-from-string "#c(1.0 0.0)")) + unless (eql c (complex (coerce 1 format) + (coerce 0 format))) + collect (list format c)) nil) (def-syntax-test syntax.sharp-c.7 (loop for format in '(short-float single-float double-float long-float) - for c = (let ((*read-default-float-format* format)) - (read-from-string "#C(0.0 1.0)")) - unless (eql c (complex (coerce 0 format) - (coerce 1 format))) - collect (list format c)) + for c = (let ((*read-default-float-format* format)) + (read-from-string "#C(0.0 1.0)")) + unless (eql c (complex (coerce 0 format) + (coerce 1 format))) + collect (list format c)) nil) ;;; Tests of #a @@ -1080,29 +1080,29 @@ (def-syntax-test syntax.sharp-bar.8 (loop for c across +standard-chars+ - for s = (concatenate 'string "\#| " (string c) " |\#1") - for vals = (multiple-value-list (read-from-string s)) - unless (equal vals '(1 8)) - collect (list c s vals)) + for s = (concatenate 'string "\#| " (string c) " |\#1") + for vals = (multiple-value-list (read-from-string s)) + unless (equal vals '(1 8)) + collect (list c s vals)) nil) (def-syntax-test syntax.sharp-bar.9 (loop for i below (min (ash 1 16) char-code-limit) - for c = (code-char i) - for s = (and c (concatenate 'string "\#| " (string c) " |\#1")) - for vals = (and c (multiple-value-list (read-from-string s))) - unless (or (not c) (equal vals '(1 8))) - collect (list i c s vals)) + for c = (code-char i) + for s = (and c (concatenate 'string "\#| " (string c) " |\#1")) + for vals = (and c (multiple-value-list (read-from-string s))) + unless (or (not c) (equal vals '(1 8))) + collect (list i c s vals)) nil) (def-syntax-test syntax.sharp-bar.10 (loop for i = (random (min (ash 1 24) char-code-limit)) - for c = (code-char i) - for s = (and c (concatenate 'string "\#| " (string c) " |\#1")) - for vals = (and c (multiple-value-list (read-from-string s))) - repeat 1000 - unless (or (not c) (equal vals '(1 8))) - collect (list i c s vals)) + for c = (code-char i) + for s = (and c (concatenate 'string "\#| " (string c) " |\#1")) + for vals = (and c (multiple-value-list (read-from-string s))) + repeat 1000 + unless (or (not c) (equal vals '(1 8))) + collect (list i c s vals)) nil) ;;;; Various error cases @@ -1110,15 +1110,15 @@ (def-syntax-test syntax.sharp-whitespace.1 (let ((names '("Tab" "Newline" "Linefeed" "Space" "Return" "Page"))) (loop for name in names - for c = (name-char name) - when c - nconc - (let* ((form `(signals-error - (read-from-string ,(concatenate 'string "#" (string c))) - reader-error)) - (vals (multiple-value-list (eval form)))) - (unless (equal vals '(t)) - (list (list name c form vals)))))) + for c = (name-char name) + when c + nconc + (let* ((form `(signals-error + (read-from-string ,(concatenate 'string "#" (string c))) + reader-error)) + (vals (multiple-value-list (eval form)))) + (unless (equal vals '(t)) + (list (list name c form vals)))))) nil) (def-syntax-test syntax.sharp-less-than.1 diff --git a/ansi-tests/tagbody.lsp b/ansi-tests/tagbody.lsp index cea5ba3d..f6561c82 100644 --- a/ansi-tests/tagbody.lsp +++ b/ansi-tests/tagbody.lsp @@ -53,9 +53,9 @@ (macrolet ((%m () 'a)) (tagbody (tagbody - (go a) - (%m) - (setq x 1)) + (go a) + (%m) + (setq x 1)) a )) x) 0) @@ -148,14 +148,14 @@ (deftest tagbody.16 (let* ((t1 (1+ most-positive-fixnum)) - (t2 (1+ most-positive-fixnum)) - (form `(block done - (tagbody - (go around) - ,t1 - (return-from done 'good) - around - (go ,t2))))) + (t2 (1+ most-positive-fixnum)) + (form `(block done + (tagbody + (go around) + ,t1 + (return-from done 'good) + around + (go ,t2))))) (eval form)) good) @@ -167,10 +167,10 @@ (tagbody (macrolet ((foo () 'tag)) (let (tag) - (tagbody - (go tag) - (foo) - (return-from done :bad)))) + (tagbody + (go tag) + (foo) + (return-from done :bad)))) tag (return-from done :good))) :good) diff --git a/ansi-tests/tailp.lsp b/ansi-tests/tailp.lsp index 22505712..f21bc77d 100644 --- a/ansi-tests/tailp.lsp +++ b/ansi-tests/tailp.lsp @@ -31,7 +31,7 @@ (deftest tailp.4 (notnot-mv (tailp 10203040506070 - (list* 'a 'b (1- 10203040506071)))) + (list* 'a 'b (1- 10203040506071)))) t) (deftest tailp.5 @@ -54,13 +54,13 @@ (deftest tailp.6 (let* ((x (copy-list '(a b c d e))) - (y (cddr x))) + (y (cddr x))) (let ((xcopy (make-scaffold-copy x)) - (ycopy (make-scaffold-copy y))) - (and - (tailp y x) - (check-scaffold-copy x xcopy) - (check-scaffold-copy y ycopy)))) + (ycopy (make-scaffold-copy y))) + (and + (tailp y x) + (check-scaffold-copy x xcopy) + (check-scaffold-copy y ycopy)))) t) ;; Note! The spec is ambiguous on whether this next test @@ -78,20 +78,20 @@ (loop for x in *universe* count (and (not (listp x)) - (eqt 'type-error - (catch-type-error (tailp x x)))))) + (eqt 'type-error + (catch-type-error (tailp x x)))))) (deftest tailp.7 (tailp.7-body) 0) |# - + (deftest tailp.order.1 (let ((i 0) x y) (values (notnot (tailp (progn (setf x (incf i)) 'd) - (progn (setf y (incf i)) '(a b c . d)))) + (progn (setf y (incf i)) '(a b c . d)))) i x y)) t 2 1 2) diff --git a/ansi-tests/tan.lsp b/ansi-tests/tan.lsp index 778ed1fe..db6e0e74 100644 --- a/ansi-tests/tan.lsp +++ b/ansi-tests/tan.lsp @@ -7,38 +7,38 @@ (deftest tan.1 (loop for i from -1000 to 1000 - for rlist = (multiple-value-list (tan i)) - for y = (car rlist) - always (and (null (cdr rlist)) - (or (rationalp y) (typep y 'single-float)))) + for rlist = (multiple-value-list (tan i)) + for y = (car rlist) + always (and (null (cdr rlist)) + (or (rationalp y) (typep y 'single-float)))) t) (deftest tan.2 (loop for x = (- (random 2000.0s0) 1000.0s0) - for y = (safe-tan x 0.0s0) - repeat 1000 - always (typep y 'short-float)) + for y = (safe-tan x 0.0s0) + repeat 1000 + always (typep y 'short-float)) t) (deftest tan.3 (loop for x = (- (random 2000.0f0) 1000.0f0) - for y = (safe-tan x 0.0) - repeat 1000 - always (typep y 'single-float)) + for y = (safe-tan x 0.0) + repeat 1000 + always (typep y 'single-float)) t) (deftest tan.4 (loop for x = (- (random 2000.0d0) 1000.0d0) - for y = (safe-tan x 0.0d0) - repeat 1000 - always (typep y 'double-float)) + for y = (safe-tan x 0.0d0) + repeat 1000 + always (typep y 'double-float)) t) (deftest tan.5 (loop for x = (- (random 2000.0l0) 1000.0l0) - for y = (safe-tan 0.0l0) - repeat 1000 - always (typep y 'long-float)) + for y = (safe-tan 0.0l0) + repeat 1000 + always (typep y 'long-float)) t) (deftest tan.6 @@ -64,8 +64,8 @@ (deftest tan.11 (loop for i from 1 to 100 - unless (approx= (tan i) (tan (coerce i 'single-float))) - collect i) + unless (approx= (tan i) (tan (coerce i 'single-float))) + collect i) nil) (deftest tan.12 @@ -102,42 +102,42 @@ (deftest tan.20 (loop for r = (- (random 2000) 1000) - for i = (- (random 20) 10) - for y = (safe-tan (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20) 10) + for y = (safe-tan (complex r i)) + repeat 1000 + always (numberp y)) t) (deftest tan.21 (loop for r = (- (random 2000.0s0) 1000.0s0) - for i = (- (random 20.0s0) 10.0s0) - for y = (safe-tan (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20.0s0) 10.0s0) + for y = (safe-tan (complex r i)) + repeat 1000 + always (numberp y)) t) (deftest tan.22 (loop for r = (- (random 2000.0f0) 1000.0f0) - for i = (- (random 20.0f0) 10.0f0) - for y = (safe-tan (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20.0f0) 10.0f0) + for y = (safe-tan (complex r i)) + repeat 1000 + always (numberp y)) t) (deftest tan.23 (loop for r = (- (random 2000.0d0) 1000.0d0) - for i = (- (random 20.0d0) 10.0d0) - for y = (safe-tan (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20.0d0) 10.0d0) + for y = (safe-tan (complex r i)) + repeat 1000 + always (numberp y)) t) (deftest tan.24 (loop for r = (- (random 2000.0l0) 1000.0l0) - for i = (- (random 20.0l0) 10.0l0) - for y = (safe-tan (complex r i)) - repeat 1000 - always (numberp y)) + for i = (- (random 20.0l0) 10.0l0) + for y = (safe-tan (complex r i)) + repeat 1000 + always (numberp y)) t) ;;; FIXME diff --git a/ansi-tests/tanh.lsp b/ansi-tests/tanh.lsp index b36feb20..f120e6d0 100644 --- a/ansi-tests/tanh.lsp +++ b/ansi-tests/tanh.lsp @@ -8,62 +8,62 @@ (deftest tanh.1 (let ((result (tanh 0))) (or (eqlt result 0) - (eqlt result 0.0))) + (eqlt result 0.0))) t) (deftest tanh.2 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 type) - unless (equal (multiple-value-list (tanh zero)) - (list zero)) - collect type) + for zero = (coerce 0 type) + unless (equal (multiple-value-list (tanh zero)) + (list zero)) + collect type) nil) (deftest tanh.3 (loop for type in '(short-float single-float double-float long-float) - for zero = (coerce 0 `(complex ,type)) - unless (equal (multiple-value-list (tanh zero)) - (list zero)) - collect type) + for zero = (coerce 0 `(complex ,type)) + unless (equal (multiple-value-list (tanh zero)) + (list zero)) + collect type) nil) (deftest tanh.4 (loop for den = (1+ (random 10000)) - for num = (random (* 10 den)) - for x = (/ num den) - for rlist = (multiple-value-list (tanh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (numberp y)) - collect (list x rlist)) + for num = (random (* 10 den)) + for x = (/ num den) + for rlist = (multiple-value-list (tanh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (numberp y)) + collect (list x rlist)) nil) (deftest tanh.5 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (tanh x)) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y type)) - collect (list x rlist))) + nconc + (loop + for x = (- (random (coerce 20 type)) 10) + for rlist = (multiple-value-list (tanh x)) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y type)) + collect (list x rlist))) nil) (deftest tanh.6 (loop for type in '(short-float single-float double-float long-float) - nconc - (loop - for x1 = (- (random (coerce 20 type)) 10) - for x2 = (- (random (coerce 20 type)) 10) - for rlist = (multiple-value-list (tanh (complex x1 x2))) - for y = (car rlist) - repeat 1000 - unless (and (null (cdr rlist)) - (typep y `(complex ,type))) - collect (list x1 x2 rlist))) + nconc + (loop + for x1 = (- (random (coerce 20 type)) 10) + for x2 = (- (random (coerce 20 type)) 10) + for rlist = (multiple-value-list (tanh (complex x1 x2))) + for y = (car rlist) + repeat 1000 + unless (and (null (cdr rlist)) + (typep y `(complex ,type))) + collect (list x1 x2 rlist))) nil) ;;; FIXME diff --git a/ansi-tests/the.lsp b/ansi-tests/the.lsp index a292d08d..ace4c1a7 100644 --- a/ansi-tests/the.lsp +++ b/ansi-tests/the.lsp @@ -14,46 +14,46 @@ (deftest the.3 (check-predicate #'(lambda (e) - (let ((x (multiple-value-list (eval `(the (values) (quote ,e)))))) - (and x (not (cdr x)) (eql (car x) e))))) + (let ((x (multiple-value-list (eval `(the (values) (quote ,e)))))) + (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.4 (check-predicate #'(lambda (e) - (let ((x (multiple-value-list (eval `(the ,(type-of e) (quote ,e)))))) - (and x (not (cdr x)) (eql (car x) e))))) + (let ((x (multiple-value-list (eval `(the ,(type-of e) (quote ,e)))))) + (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.5 (check-predicate #'(lambda (e) - (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) (quote ,e)))))) - (and x (not (cdr x)) (eql (car x) e))))) + (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) (quote ,e)))))) + (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.6 (check-predicate #'(lambda (e) - (let ((x (multiple-value-list (eval `(the (values ,(type-of e) t) (quote ,e)))))) - (and x (not (cdr x)) (eql (car x) e))))) + (let ((x (multiple-value-list (eval `(the (values ,(type-of e) t) (quote ,e)))))) + (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.7 (check-predicate #'(lambda (e) (let ((x (multiple-value-list (eval `(the (values ,(type-of e)) - (values (quote ,e) :ignored)))))) - (and (eql (length x) 2) - (eql (car x) e) - (eql (cadr x) :ignored))))) + (values (quote ,e) :ignored)))))) + (and (eql (length x) 2) + (eql (car x) e) + (eql (cadr x) :ignored))))) nil) (deftest the.8 (check-predicate #'(lambda (e) (or (not (constantp e)) - (eql (eval `(the ,(type-of e) ,e)) e)))) + (eql (eval `(the ,(type-of e) ,e)) e)))) nil) (deftest the.9 (check-predicate #'(lambda (e) (or (not (constantp e)) - (eql (eval `(the ,(class-of e) ,e)) e)))) + (eql (eval `(the ,(class-of e) ,e)) e)))) nil) (deftest the.10 @@ -64,17 +64,17 @@ (check-predicate #'(lambda (e) (let* ((type (type-of e)) - (x (multiple-value-list (eval `(the ,type (the ,type (quote ,e))))))) - (and x (not (cdr x)) (eql (car x) e))))) + (x (multiple-value-list (eval `(the ,type (the ,type (quote ,e))))))) + (and x (not (cdr x)) (eql (car x) e))))) nil) (deftest the.12 (let ((lexpr - `(lambda () - (and - ,@(loop for e in *mini-universe* - for type = (type-of e) - collect `(eqlt (quote ,e) (the ,type (quote ,e)))))))) + `(lambda () + (and + ,@(loop for e in *mini-universe* + for type = (type-of e) + collect `(eqlt (quote ,e) (the ,type (quote ,e)))))))) (funcall (compile nil lexpr))) t) diff --git a/ansi-tests/time.lsp b/ansi-tests/time.lsp index 41baebf3..9494e617 100644 --- a/ansi-tests/time.lsp +++ b/ansi-tests/time.lsp @@ -7,64 +7,64 @@ (deftest time.1 (let ((s (with-output-to-string - (*trace-output*) - (assert (null (time nil)))))) + (*trace-output*) + (assert (null (time nil)))))) (= (length s) 0)) nil) (deftest time.2 (let ((s (with-output-to-string - (*trace-output*) - (let ((x (cons 'a 'b))) - (assert (eq (time x) x)))))) + (*trace-output*) + (let ((x (cons 'a 'b))) + (assert (eq (time x) x)))))) (= (length s) 0)) nil) (deftest time.3 (let ((s (with-output-to-string - (*trace-output*) - (let ((x (cons 'a 'b))) - (flet ((%f () x)) - (assert (eq (time (%f)) x))))))) + (*trace-output*) + (let ((x (cons 'a 'b))) + (flet ((%f () x)) + (assert (eq (time (%f)) x))))))) (= (length s) 0)) nil) (deftest time.4 (let ((s (with-output-to-string - (*trace-output*) - (assert (null (multiple-value-list (time (values)))))))) + (*trace-output*) + (assert (null (multiple-value-list (time (values)))))))) (= (length s) 0)) nil) (deftest time.5 (let ((s (with-output-to-string - (*trace-output*) - (assert (equal '(a b c d) - (multiple-value-list (time (values 'a 'b 'c 'd)))))))) + (*trace-output*) + (assert (equal '(a b c d) + (multiple-value-list (time (values 'a 'b 'c 'd)))))))) (= (length s) 0)) nil) (deftest time.6 (let ((fn (compile nil '(lambda () (time nil))))) (let ((s (with-output-to-string - (*trace-output*) - (assert (null (funcall fn)))))) + (*trace-output*) + (assert (null (funcall fn)))))) (= (length s) 0))) nil) (deftest time.7 (flet ((%f () (time nil))) (let ((s (with-output-to-string - (*trace-output*) - (assert (null (%f)))))) + (*trace-output*) + (assert (null (%f)))))) (= (length s) 0))) nil) (deftest time.8 (let ((s (with-output-to-string - (*trace-output*) - (macrolet ((%m () 1)) - (assert (eql (time (%m)) 1)))))) + (*trace-output*) + (macrolet ((%m () 1)) + (assert (eql (time (%m)) 1)))))) (= (length s) 0)) nil) @@ -74,11 +74,11 @@ #| (deftest time.9 (let ((s (with-output-to-string - (*trace-output*) - (block done - (time (return-from done nil)))))) + (*trace-output*) + (block done + (time (return-from done nil)))))) (= (length s) 0)) nil) |# - \ No newline at end of file + diff --git a/ansi-tests/times-aux.lsp b/ansi-tests/times-aux.lsp index 2839d7f6..64137b70 100644 --- a/ansi-tests/times-aux.lsp +++ b/ansi-tests/times-aux.lsp @@ -19,7 +19,7 @@ (if (= x 0) 0 (let ((lo (if (oddp x) y 0)) - (hi (nat-times (ash x -1) y))) + (hi (nat-times (ash x -1) y))) (+ lo (+ hi hi))))) (defun rat-times (x y) diff --git a/ansi-tests/times.lsp b/ansi-tests/times.lsp index 6b1b2e3e..22c10f2f 100644 --- a/ansi-tests/times.lsp +++ b/ansi-tests/times.lsp @@ -14,64 +14,64 @@ (deftest *.2 (loop for x in *numbers* - unless (eql x (* x)) - collect x) + unless (eql x (* x)) + collect x) nil) (deftest *.3 (loop for x in *numbers* - for x1 = (* x 1) - for x2 = (* 1 x) - unless (and (eql x x1) (eql x x2) (eql x1 x2)) - collect (list x x1 x2)) + for x1 = (* x 1) + for x2 = (* 1 x) + unless (and (eql x x1) (eql x x2) (eql x1 x2)) + collect (list x x1 x2)) nil) (deftest *.4 (loop for x in *numbers* - for x1 = (* x 0) - for x2 = (* 0 x) - unless (and (= x1 0) (= x2 0)) - collect (list x x1 x2)) + for x1 = (* x 0) + for x2 = (* 0 x) + unless (and (= x1 0) (= x2 0)) + collect (list x x1 x2)) nil) (deftest *.5 (loop for bound in '(1.0s0 1.0f0 1.0d0 1.0l0) - nconc - (loop for x = (random bound) - for x1 = (* x -1) - for x2 = (* -1 x) - for x3 = (* x bound) - for x4 = (* bound x) - repeat 1000 - unless (and (eql (- x) x1) (eql (- x) x2) - (eql x x3) (eql x x4)) - collect (list x x1 x2 x3 x4))) + nconc + (loop for x = (random bound) + for x1 = (* x -1) + for x2 = (* -1 x) + for x3 = (* x bound) + for x4 = (* bound x) + repeat 1000 + unless (and (eql (- x) x1) (eql (- x) x2) + (eql x x3) (eql x x4)) + collect (list x x1 x2 x3 x4))) nil) (deftest *.6 (let* ((upper-bound (* 1000 1000 1000 1000)) - (lower-bound (- upper-bound)) - (spread (1+ (- upper-bound lower-bound)))) + (lower-bound (- upper-bound)) + (spread (1+ (- upper-bound lower-bound)))) (loop for x = (random-from-interval upper-bound) - for y = (random-from-interval upper-bound) - for prod = (* x y) - for prod2 = (integer-times x y) - repeat 1000 - unless (eql prod prod2) - collect (list x y prod prod2))) + for y = (random-from-interval upper-bound) + for prod = (* x y) + for prod2 = (integer-times x y) + repeat 1000 + unless (eql prod prod2) + collect (list x y prod prod2))) nil) (deftest *.7 (let* ((upper-bound (* 1000 1000 1000)) - (lower-bound (- upper-bound)) - (spread (1+ (- upper-bound lower-bound)))) + (lower-bound (- upper-bound)) + (spread (1+ (- upper-bound lower-bound)))) (loop for x = (+ (rational (random (float spread 1.0f0))) lower-bound) - for y = (+ (rational (random (float spread 1.0f0))) lower-bound) - for prod = (* x y) - for prod2 = (rat-times x y) - repeat 1000 - unless (eql prod prod2) - collect (list x y prod prod2))) + for y = (+ (rational (random (float spread 1.0f0))) lower-bound) + for prod = (* x y) + for prod2 = (rat-times x y) + repeat 1000 + unless (eql prod prod2) + collect (list x y prod prod2))) nil) ;; Testing of multiplication by integer constants @@ -81,61 +81,61 @@ for x = (random bound) for y = (random bound) for f = (eval `(function (lambda (z) - (declare (optimize (speed 3) (safety 0))) - (declare (type (integer 0 (,bound)) z)) - (* ,x z)))) + (declare (optimize (speed 3) (safety 0))) + (declare (type (integer 0 (,bound)) z)) + (* ,x z)))) for prod = (funcall f y) repeat 100 unless (and (eql prod (* x y)) - (eql prod (integer-times x y))) + (eql prod (integer-times x y))) collect (progn (format t "Failed on ~A~%" (list x y prod)) - (list x y prod (* x y) (integer-times x y))))) + (list x y prod (* x y) (integer-times x y))))) nil) (deftest *.9 (let* ((upper-bound (* 1000 1000 1000 1000))) (flet ((%r () (random-from-interval upper-bound))) (loop for xr = (%r) - for xc = (%r) - for x = (complex xr xc) - for yr = (%r) - for yc = (%r) - for y = (complex yr yc) - for prod = (* x y) - repeat 1000 - unless (and (eql (realpart prod) (- (integer-times xr yr) - (integer-times xc yc))) - (eql (imagpart prod) (+ (integer-times xr yc) - (integer-times xc yr)))) - collect (list x y prod)))) + for xc = (%r) + for x = (complex xr xc) + for yr = (%r) + for yc = (%r) + for y = (complex yr yc) + for prod = (* x y) + repeat 1000 + unless (and (eql (realpart prod) (- (integer-times xr yr) + (integer-times xc yc))) + (eql (imagpart prod) (+ (integer-times xr yc) + (integer-times xc yr)))) + collect (list x y prod)))) nil) (deftest *.10 (let* ((upper-bound (* 1000 1000 1000 1000)) - (lower-bound (- upper-bound)) - (spread (1+ (- upper-bound lower-bound)))) + (lower-bound (- upper-bound)) + (spread (1+ (- upper-bound lower-bound)))) (flet ((%r () (+ (rational (random (float spread 1.0f0))) lower-bound))) (loop for xr = (%r) - for xc = (%r) - for x = (complex xr xc) - for yr = (%r) - for yc = (%r) - for y = (complex yr yc) - for prod = (* x y) - repeat 1000 - unless (and (eql (realpart prod) (- (rat-times xr yr) - (rat-times xc yc))) - (eql (imagpart prod) (+ (rat-times xr yc) - (rat-times xc yr)))) - collect (list x y prod)))) + for xc = (%r) + for x = (complex xr xc) + for yr = (%r) + for yc = (%r) + for y = (complex yr yc) + for prod = (* x y) + repeat 1000 + unless (and (eql (realpart prod) (- (rat-times xr yr) + (rat-times xc yc))) + (eql (imagpart prod) (+ (rat-times xr yc) + (rat-times xc yr)))) + collect (list x y prod)))) nil) (deftest *.11 (let ((prod 1) (args nil)) (loop for i from 1 to (min 256 (1- call-arguments-limit)) - do (push i args) - do (setq prod (* prod i)) - always (eql (apply #'* args) prod))) + do (push i args) + do (setq prod (* prod i)) + always (eql (apply #'* args) prod))) t) (deftest *.12 @@ -145,16 +145,16 @@ for (k eps-r eps-f) = (multiple-value-list (find-epsilon x)) nconc (loop for i from 1 to k - for y = (+ x (expt radix (- i))) - nconc - (loop for j from 1 to (- k i) - for z = (+ x (expt radix (- j))) - unless (eql (* y z) - (+ x - (expt radix (- i)) - (expt radix (- j)) - (expt radix (- (+ i j))))) - collect (list x i j)))) + for y = (+ x (expt radix (- i))) + nconc + (loop for j from 1 to (- k i) + for z = (+ x (expt radix (- j))) + unless (eql (* y z) + (+ x + (expt radix (- i)) + (expt radix (- j)) + (expt radix (- (+ i j))))) + collect (list x i j)))) nil) (deftest *.13 @@ -164,16 +164,16 @@ for (k eps-r eps-f) = (multiple-value-list (find-epsilon x)) nconc (loop for i from 1 to k - for y = (- x (expt radix (- i))) - nconc - (loop for j from 1 to (- k i) - for z = (- x (expt radix (- j))) - unless (eql (* y z) - (+ x - (- (expt radix (- i))) - (- (expt radix (- j))) - (expt radix (- (+ i j))))) - collect (list x i j)))) + for y = (- x (expt radix (- i))) + nconc + (loop for j from 1 to (- k i) + for z = (- x (expt radix (- j))) + unless (eql (* y z) + (+ x + (- (expt radix (- i))) + (- (expt radix (- j))) + (expt radix (- (+ i j))))) + collect (list x i j)))) nil) ;;; Float contagion @@ -181,117 +181,117 @@ (deftest *.14 (let ((bound (- (sqrt most-positive-short-float) 1))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'short-float)) - collect (list x y p))) - nil) + for y = (random-from-interval bound) + for p = (* x y) + repeat 1000 + unless (and (eql p (* y x)) + (typep p 'short-float)) + collect (list x y p))) + nil) (deftest *.15 (let ((bound (- (sqrt most-positive-single-float) 1))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'single-float)) - collect (list x y p))) - nil) + for y = (random-from-interval bound) + for p = (* x y) + repeat 1000 + unless (and (eql p (* y x)) + (typep p 'single-float)) + collect (list x y p))) + nil) (deftest *.16 (let ((bound (- (sqrt most-positive-double-float) 1))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'double-float)) - collect (list x y p))) + for y = (random-from-interval bound) + for p = (* x y) + repeat 1000 + unless (and (eql p (* y x)) + (typep p 'double-float)) + collect (list x y p))) nil) (deftest *.17 (let ((bound (- (sqrt most-positive-long-float) 1))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'long-float)) - collect (list x y p))) + for y = (random-from-interval bound) + for p = (* x y) + repeat 1000 + unless (and (eql p (* y x)) + (typep p 'long-float)) + collect (list x y p))) nil) (deftest *.18 (let ((bound (- (sqrt most-positive-short-float) 1)) - (bound2 (- (sqrt most-positive-single-float) 1))) + (bound2 (- (sqrt most-positive-single-float) 1))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound2) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'single-float)) - collect (list x y p))) + for y = (random-from-interval bound2) + for p = (* x y) + repeat 1000 + unless (and (eql p (* y x)) + (typep p 'single-float)) + collect (list x y p))) nil) (deftest *.19 (let ((bound (- (sqrt most-positive-short-float) 1)) - (bound2 (- (sqrt most-positive-double-float) 1))) + (bound2 (- (sqrt most-positive-double-float) 1))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound2) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'double-float)) - collect (list x y p))) + for y = (random-from-interval bound2) + for p = (* x y) + repeat 1000 + unless (and (eql p (* y x)) + (typep p 'double-float)) + collect (list x y p))) nil) (deftest *.20 (let ((bound (- (sqrt most-positive-short-float) 1)) - (bound2 (- (sqrt most-positive-long-float) 1))) + (bound2 (- (sqrt most-positive-long-float) 1))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound2) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'long-float)) - collect (list x y p))) + for y = (random-from-interval bound2) + for p = (* x y) + repeat 1000 + unless (and (eql p (* y x)) + (typep p 'long-float)) + collect (list x y p))) nil) (deftest *.21 (let ((bound (- (sqrt most-positive-single-float) 1)) - (bound2 (- (sqrt most-positive-double-float) 1))) + (bound2 (- (sqrt most-positive-double-float) 1))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound2) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'double-float)) - collect (list x y p))) + for y = (random-from-interval bound2) + for p = (* x y) + repeat 1000 + unless (and (eql p (* y x)) + (typep p 'double-float)) + collect (list x y p))) nil) (deftest *.22 (let ((bound (- (sqrt most-positive-single-float) 1)) - (bound2 (- (sqrt most-positive-long-float) 1))) + (bound2 (- (sqrt most-positive-long-float) 1))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound2) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'long-float)) - collect (list x y p))) + for y = (random-from-interval bound2) + for p = (* x y) + repeat 1000 + unless (and (eql p (* y x)) + (typep p 'long-float)) + collect (list x y p))) nil) (deftest *.23 (let ((bound (- (sqrt most-positive-double-float) 1)) - (bound2 (- (sqrt most-positive-long-float) 1))) + (bound2 (- (sqrt most-positive-long-float) 1))) (loop for x = (random-from-interval bound) - for y = (random-from-interval bound2) - for p = (* x y) - repeat 1000 - unless (and (eql p (* y x)) - (typep p 'long-float)) - collect (list x y p))) + for y = (random-from-interval bound2) + for p = (* x y) + repeat 1000 + unless (and (eql p (* y x)) + (typep p 'long-float)) + collect (list x y p))) nil) (deftest *.24 @@ -301,14 +301,14 @@ for bound = (ash 1 (floor bits 2)) nconc (loop for i = (random bound) - for x = (coerce i type) - for j = (random bound) - for y = (coerce j type) - for prod = (* x y) - repeat 1000 - unless (and (eql prod (coerce (* i j) type)) - (eql prod (* y x))) - collect (list i j x y (* x y) (coerce (* i j) type)))) + for x = (coerce i type) + for j = (random bound) + for y = (coerce j type) + for prod = (* x y) + repeat 1000 + unless (and (eql prod (coerce (* i j) type)) + (eql prod (* y x))) + collect (list i j x y (* x y) (coerce (* i j) type)))) nil) (deftest *.25 @@ -319,23 +319,23 @@ when (= (float-radix (coerce 1.0 type)) 2) nconc (loop for i = (random bound) - for x = (coerce i type) - for j = (* i 2) - for y = (coerce j type) - repeat 1000 - unless (eql (* 2 x) y) - collect (list i j x (* 2 x) y))) + for x = (coerce i type) + for j = (* i 2) + for y = (coerce j type) + repeat 1000 + unless (eql (* 2 x) y) + collect (list i j x (* 2 x) y))) nil) ;;; Shows a compiler bug in sbcl/cmucl (deftest *.26 (eqlt (funcall (compile nil - '(lambda (x y) - (declare (type (single-float -10.0 10.0) x) - (type (double-float -1.0d100 1.0d100) y)) - (* x y))) - 1.0f0 1.0d0) - 1.0d0) + '(lambda (x y) + (declare (type (single-float -10.0 10.0) x) + (type (double-float -1.0d100 1.0d100) y)) + (* x y))) + 1.0f0 1.0d0) + 1.0d0) t) (deftest *.27 @@ -345,18 +345,18 @@ for bound = (ash 1 (floor bits 2)) nconc (loop for i = (random bound) - for x = (coerce i type) - for j = (random bound) - for y = (coerce j type) - for one = (coerce 1.0 type) - for cx = (complex one x) - for cy = (complex one y) - for prod = (* cx cy) - repeat 1000 - unless (and (eql prod (complex (coerce (- 1 (* i j)) type) - (coerce (+ i j) type))) - (eql prod (* cy cx))) - collect (list type i j x y (* cx cy)))) + for x = (coerce i type) + for j = (random bound) + for y = (coerce j type) + for one = (coerce 1.0 type) + for cx = (complex one x) + for cy = (complex one y) + for prod = (* cx cy) + repeat 1000 + unless (and (eql prod (complex (coerce (- 1 (* i j)) type) + (coerce (+ i j) type))) + (eql prod (* cy cx))) + collect (list type i j x y (* cx cy)))) nil) ;;; Test that explicit calls to macroexpand in subforms @@ -364,10 +364,10 @@ (deftest *.28 (macrolet ((%m (z) z)) - (values - (* (expand-in-current-env (%m 2))) - (* (expand-in-current-env (%m 3)) 4) - (* 5 (expand-in-current-env (%m 3))))) + (values + (* (expand-in-current-env (%m 2))) + (* (expand-in-current-env (%m 3)) 4) + (* 5 (expand-in-current-env (%m 3))))) 2 12 15) ;;; Order of evaluation tests @@ -376,7 +376,7 @@ (let ((i 0) x y) (values (* (progn (setf x (incf i)) 2) - (progn (setf y (incf i)) 3)) + (progn (setf y (incf i)) 3)) i x y)) 6 2 1 2) @@ -384,7 +384,7 @@ (let ((i 0) x y z) (values (* (progn (setf x (incf i)) 2) - (progn (setf y (incf i)) 3) - (progn (setf z (incf i)) 5)) + (progn (setf y (incf i)) 3) + (progn (setf z (incf i)) 5)) i x y z)) 30 3 1 2 3) diff --git a/ansi-tests/trace.lsp b/ansi-tests/trace.lsp index cea34e50..a9834586 100644 --- a/ansi-tests/trace.lsp +++ b/ansi-tests/trace.lsp @@ -10,8 +10,8 @@ (defun (setf function-to-trace) (val arg) (setf (car arg) val)) (declaim (notinline function-to-trace - another-function-to-trace - (setf function-to-trace))) + another-function-to-trace + (setf function-to-trace))) (deftest trace.1 (progn @@ -25,8 +25,8 @@ (progn (trace function-to-trace) (equal "" (with-output-to-string - (*trace-output*) - (assert (eql (function-to-trace '(b)) 'b))))) + (*trace-output*) + (assert (eql (function-to-trace '(b)) 'b))))) nil) (deftest trace.3 @@ -44,7 +44,7 @@ (untrace) (trace function-to-trace) (handler-bind ((warning #'muffle-warning)) - (trace function-to-trace)) + (trace function-to-trace)) (prog1 (trace) (untrace) (assert (null (trace))))) @@ -64,7 +64,7 @@ (untrace) (trace (setf function-to-trace)) (handler-bind ((warning #'muffle-warning)) - (trace (setf function-to-trace))) + (trace (setf function-to-trace))) (prog1 (trace) (untrace) (assert (null (trace))))) @@ -76,8 +76,8 @@ (with-output-to-string (*trace-output*) (let ((x (list nil))) - (assert (eql (setf (function-to-trace x) 'a) 'a)) - (assert (equal x '(a)))))) + (assert (eql (setf (function-to-trace x) 'a) 'a)) + (assert (equal x '(a)))))) "") (deftest trace.8 @@ -85,11 +85,11 @@ (untrace) (trace (setf function-to-trace)) (equal "" - (with-output-to-string - (*trace-output*) - (let ((x (list nil))) - (assert (eql (setf (function-to-trace x) 'a) 'a)) - (assert (equal x '(a))))))) + (with-output-to-string + (*trace-output*) + (let ((x (list nil))) + (assert (eql (setf (function-to-trace x) 'a) 'a)) + (assert (equal x '(a))))))) nil) (deftest trace.9 @@ -97,16 +97,16 @@ (untrace) (trace function-to-trace another-function-to-trace) (assert (not (equal "" (with-output-to-string - (*trace-output*) - (assert (eql (function-to-trace '(b)) 'b)))))) + (*trace-output*) + (assert (eql (function-to-trace '(b)) 'b)))))) (assert (not (equal "" (with-output-to-string - (*trace-output*) - (assert (eql (another-function-to-trace '(c . d)) - 'd)))))) + (*trace-output*) + (assert (eql (another-function-to-trace '(c . d)) + 'd)))))) (prog1 - (sort (copy-list (trace)) - #'(lambda (k1 k2) (string< (symbol-name k1) - (symbol-name k2)))) + (sort (copy-list (trace)) + #'(lambda (k1 k2) (string< (symbol-name k1) + (symbol-name k2)))) (untrace))) (another-function-to-trace function-to-trace)) @@ -158,11 +158,11 @@ (trace generic-function-to-trace) (eval '(defmethod generic-function-to-trace ((x t)(y t)) nil)) (assert (not (equal (with-output-to-string - (*trace-output*) - (assert (null (generic-function-to-trace 'a 'b)))) - ""))) + (*trace-output*) + (assert (null (generic-function-to-trace 'a 'b)))) + ""))) (prog1 - (trace) + (trace) (untrace generic-function-to-trace) (assert (null (trace))))) (generic-function-to-trace)) @@ -173,11 +173,11 @@ (progn (untrace) (let* ((gf (eval '(defgeneric generic-function-to-trace2 (x y)))) - (m (eval '(defmethod generic-function-to-trace2 - ((x integer)(y integer)) - :foo)))) + (m (eval '(defmethod generic-function-to-trace2 + ((x integer)(y integer)) + :foo)))) (eval '(defmethod generic-function-to-trace2 - ((x symbol)(y symbol)) :bar)) + ((x symbol)(y symbol)) :bar)) (assert (eql (generic-function-to-trace2 1 2) :foo)) (assert (eql (generic-function-to-trace2 'a 'b) :bar)) (trace generic-function-to-trace2) diff --git a/ansi-tests/translate-logical-pathname.lsp b/ansi-tests/translate-logical-pathname.lsp index e07edcc3..f8bc3998 100644 --- a/ansi-tests/translate-logical-pathname.lsp +++ b/ansi-tests/translate-logical-pathname.lsp @@ -10,34 +10,34 @@ ;;; Every physical pathname is converted to itself (deftest translate-logical-pathname.1 (loop for p in *pathnames* - unless (or (typep p 'logical-pathname) - (eq p (translate-logical-pathname p))) - collect p) + unless (or (typep p 'logical-pathname) + (eq p (translate-logical-pathname p))) + collect p) nil) ;;; &key arguments are allowed (deftest translate-logical-pathname.2 (loop for p in *pathnames* - unless (or (typep p 'logical-pathname) - (eq p (translate-logical-pathname - p :allow-other-keys t))) - collect p) + unless (or (typep p 'logical-pathname) + (eq p (translate-logical-pathname + p :allow-other-keys t))) + collect p) nil) (deftest translate-logical-pathname.3 (loop for p in *pathnames* - unless (or (typep p 'logical-pathname) - (eq p (translate-logical-pathname - p :allow-other-keys nil))) - collect p) + unless (or (typep p 'logical-pathname) + (eq p (translate-logical-pathname + p :allow-other-keys nil))) + collect p) nil) (deftest translate-logical-pathname.4 (loop for p in *pathnames* - unless (or (typep p 'logical-pathname) - (eq p (translate-logical-pathname - p :foo 1 :allow-other-keys t :bar 2))) - collect p) + unless (or (typep p 'logical-pathname) + (eq p (translate-logical-pathname + p :foo 1 :allow-other-keys t :bar 2))) + collect p) nil) diff --git a/ansi-tests/tree-equal.lsp b/ansi-tests/tree-equal.lsp index 060f5a53..deddb61e 100644 --- a/ansi-tests/tree-equal.lsp +++ b/ansi-tests/tree-equal.lsp @@ -17,7 +17,7 @@ (deftest tree-equal.3 (notnot-mv (tree-equal (list 'a 'b (list 'c 'd)) - (list 'a 'b (list 'c 'd)))) + (list 'a 'b (list 'c 'd)))) t) (deftest tree-equal.4 @@ -27,7 +27,7 @@ (deftest tree-equal.5 (notnot-mv (tree-equal 1 2 :test #'<)) t) - + (deftest tree-equal.6 (notnot-mv (tree-equal 1 2 :test #'(lambda (x y) (values (< x y) t)))) t) @@ -35,15 +35,15 @@ (deftest tree-equal.7 (tree-equal 1 2 :test #'>) nil) - + (deftest tree-equal.8 (tree-equal (list 1) 2 :test (constantly t)) nil) (deftest tree-equal.9 (tree-equal (list 1) (list 2) - :test #'(lambda (x y) (or (and (consp x) (consp y)) - (eql x y)))) + :test #'(lambda (x y) (or (and (consp x) (consp y)) + (eql x y)))) nil) (deftest tree-equal.10 @@ -52,8 +52,8 @@ (deftest tree-equal.11 (let* ((x (list 'a 'b)) - (y (list x x)) - (z (list (list 'a 'b) (list 'a 'b)))) + (y (list x x)) + (z (list (list 'a 'b) (list 'a 'b)))) (notnot-mv (tree-equal y z))) t) @@ -71,13 +71,13 @@ (deftest tree-equal.15 (let ((x (vector 'a 'b 'c)) - (y (vector 'a' 'b 'c))) + (y (vector 'a' 'b 'c))) (tree-equal x y)) nil) (deftest tree-equal.16 (let ((x (copy-seq "")) - (y (copy-seq ""))) + (y (copy-seq ""))) (tree-equal x y)) nil) @@ -103,13 +103,13 @@ (deftest tree-equal.allow-other-keys.4 (notnot-mv (tree-equal '(a b) (list 'a 'b) :allow-other-keys t - :allow-other-keys nil :foo t)) + :allow-other-keys nil :foo t)) t) (deftest tree-equal.keywords.1 (notnot-mv (tree-equal '(a . b) '(b . a) - :test (complement #'eql) - :test #'eql)) + :test (complement #'eql) + :test #'eql)) t) diff --git a/ansi-tests/truename.lsp b/ansi-tests/truename.lsp index 23bf41db..ca123499 100644 --- a/ansi-tests/truename.lsp +++ b/ansi-tests/truename.lsp @@ -7,7 +7,7 @@ (deftest truename.1 (let* ((pn #p"truename.lsp") - (tn (truename pn))) + (tn (truename pn))) (values (notnot (pathnamep pn)) (typep pn 'logical-pathname) @@ -18,8 +18,8 @@ (deftest truename.2 (let* ((name "truename.lsp") - (pn (pathname name)) - (tn (truename name))) + (pn (pathname name)) + (tn (truename name))) (values (notnot (pathnamep pn)) (typep pn 'logical-pathname) @@ -34,11 +34,11 @@ (s pn :direction :input) (let ((tn (truename s))) (values - (notnot (pathnamep pn)) - (typep pn 'logical-pathname) - (equalt (pathname-name pn) (pathname-name tn)) - (equalt (pathname-type pn) (pathname-type tn)) - )))) + (notnot (pathnamep pn)) + (typep pn 'logical-pathname) + (equalt (pathname-name pn) (pathname-name tn)) + (equalt (pathname-type pn) (pathname-type tn)) + )))) t nil t t) (deftest truename.4 @@ -46,26 +46,26 @@ (let ((s (open pn :direction :input))) (close s) (let ((tn (truename s))) - (values - (notnot (pathnamep pn)) - (typep pn 'logical-pathname) - (equalt (pathname-name pn) (pathname-name tn)) - (equalt (pathname-type pn) (pathname-type tn)) - )))) + (values + (notnot (pathnamep pn)) + (typep pn 'logical-pathname) + (equalt (pathname-name pn) (pathname-name tn)) + (equalt (pathname-type pn) (pathname-type tn)) + )))) t nil t t) (deftest truename.5 (let* ((lpn "CLTEST:foo.txt") - (pn (translate-logical-pathname lpn))) + (pn (translate-logical-pathname lpn))) (unless (probe-file lpn) (with-open-file (s lpn :direction :output) (format s "Stuff~%"))) (let ((tn (truename lpn))) (values (notnot (pathnamep pn)) (if (equalt (pathname-name pn) (pathname-name tn)) - t (list (pathname-name pn) (pathname-name tn))) + t (list (pathname-name pn) (pathname-name tn))) (if (equalt (pathname-type pn) (pathname-type tn)) - t (list (pathname-type pn) (pathname-type tn))) + t (list (pathname-type pn) (pathname-type tn))) ))) t t t) @@ -102,7 +102,7 @@ (deftest truename.error.6 (signals-error-always (let ((pn (make-pathname :name :wild - :defaults *default-pathname-defaults*))) + :defaults *default-pathname-defaults*))) (truename pn)) file-error) t t) diff --git a/ansi-tests/truncate-aux.lsp b/ansi-tests/truncate-aux.lsp index 87e46e85..c99d2b50 100644 --- a/ansi-tests/truncate-aux.lsp +++ b/ansi-tests/truncate-aux.lsp @@ -7,107 +7,107 @@ (defun truncate.1-fn () (loop for n = (- (random 2000000000) - 1000000000) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (truncate n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (integerp r) - (if (>= n 0) (< -1 r d) - (< (- d) r 1))) - collect (list n d q r n2))) + 1000000000) + for d = (1+ (random 10000)) + for vals = (multiple-value-list (truncate n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (= n n2) + (integerp r) + (if (>= n 0) (< -1 r d) + (< (- d) r 1))) + collect (list n d q r n2))) (defun truncate.2-fn () (loop for num = (random 1000000000) - for denom = (1+ (random 1000)) - for n = (/ num denom) - for d = (1+ (random 10000)) - for vals = (multiple-value-list (truncate n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (<= 0 r) - (< r d) - (= n n2)) - collect (list n d q r n2))) + for denom = (1+ (random 1000)) + for n = (/ num denom) + for d = (1+ (random 10000)) + for vals = (multiple-value-list (truncate n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (<= 0 r) + (< r d) + (= n n2)) + collect (list n d q r n2))) (defun truncate.3-fn (width) (loop for n = (- (random width) (/ width 2)) - for vals = (multiple-value-list (truncate n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (= n n2) - (if (>= n 0) - (and (<= 0 r) (< r 1)) - (and (< -1 r) (<= r 0))) - ) - collect (list n q r n2))) + for vals = (multiple-value-list (truncate n)) + for (q r) = vals + for n2 = (+ q r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (= n n2) + (if (>= n 0) + (and (<= 0 r) (< r 1)) + (and (< -1 r) (<= r 0))) + ) + collect (list n q r n2))) (defun truncate.7-fn () (loop for numerator = (- (random 10000000000) 5000000000) - for denominator = (1+ (random 100000)) - for n = (/ numerator denominator) - for vals = (multiple-value-list (truncate n)) - for (q r) = vals - for n2 = (+ q r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (= n n2) - (if (>= n 0) - (and (<= 0 r) (< r 1)) - (and (< -1 r) (<= r 0))) - ) - collect (list n q r n2))) + for denominator = (1+ (random 100000)) + for n = (/ numerator denominator) + for vals = (multiple-value-list (truncate n)) + for (q r) = vals + for n2 = (+ q r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (rationalp r) + (= n n2) + (if (>= n 0) + (and (<= 0 r) (< r 1)) + (and (< -1 r) (<= r 0))) + ) + collect (list n q r n2))) (defun truncate.8-fn () (loop for num1 = (- (random 10000000000) 5000000000) - for den1 = (1+ (random 100000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000))) - for den2 = (1+ (random 1000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (truncate n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (if (> n 0) - (and (<= 0 r) (< r (- d))) - (and (>= 0 r) (> r d))) - (= n n2)) - collect (list n q d r n2))) + for den1 = (1+ (random 100000)) + for n = (/ num1 den1) + for num2 = (- (1+ (random 1000000))) + for den2 = (1+ (random 1000000)) + for d = (/ num2 den2) + for vals = (multiple-value-list (truncate n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (rationalp r) + (if (> n 0) + (and (<= 0 r) (< r (- d))) + (and (>= 0 r) (> r d))) + (= n n2)) + collect (list n q d r n2))) (defun truncate.9-fn () (loop for num1 = (- (random 1000000000000000) 500000000000000) - for den1 = (1+ (random 10000000000)) - for n = (/ num1 den1) - for num2 = (- (1+ (random 1000000000))) - for den2 = (1+ (random 10000000)) - for d = (/ num2 den2) - for vals = (multiple-value-list (truncate n d)) - for (q r) = vals - for n2 = (+ (* q d) r) - repeat 1000 - unless (and (eql (length vals) 2) - (integerp q) - (rationalp r) - (if (> n 0) - (and (<= 0 r) (< r (- d))) - (and (>= 0 r) (> r d))) - (= n n2)) - collect (list n q d r n2))) + for den1 = (1+ (random 10000000000)) + for n = (/ num1 den1) + for num2 = (- (1+ (random 1000000000))) + for den2 = (1+ (random 10000000)) + for d = (/ num2 den2) + for vals = (multiple-value-list (truncate n d)) + for (q r) = vals + for n2 = (+ (* q d) r) + repeat 1000 + unless (and (eql (length vals) 2) + (integerp q) + (rationalp r) + (if (> n 0) + (and (<= 0 r) (< r (- d))) + (and (>= 0 r) (> r d))) + (= n n2)) + collect (list n q d r n2))) diff --git a/ansi-tests/truncate.lsp b/ansi-tests/truncate.lsp index d51449c8..40b2e09e 100644 --- a/ansi-tests/truncate.lsp +++ b/ansi-tests/truncate.lsp @@ -56,116 +56,116 @@ (deftest truncate.10 (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (truncate x x)) - unless (and (eql q 1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) + for (q r) = (multiple-value-list (truncate x x)) + unless (and (eql q 1) + (zerop r) + (if (rationalp x) (eql r 0) + (eql r (float 0 x)))) + collect x) nil) (deftest truncate.11 (loop for x in (remove-if #'zerop *reals*) - for (q r) = (multiple-value-list (truncate (- x) x)) - unless (and (eql q -1) - (zerop r) - (if (rationalp x) (eql r 0) - (eql r (float 0 x)))) - collect x) + for (q r) = (multiple-value-list (truncate (- x) x)) + unless (and (eql q -1) + (zerop r) + (if (rationalp x) (eql r 0) + (eql r (float 0 x)))) + collect x) nil) (deftest truncate.12 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (truncate x)) + unless (and (eql q i) + (eql r rrad)) + collect (list i x q r))) nil) (deftest truncate.13 (let* ((radix (float-radix 1.0s0)) - (rad (float radix 1.0s0)) - (rrad (/ 1.0s0 rad))) + (rad (float radix 1.0s0)) + (rrad (/ 1.0s0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (truncate x)) + unless (and (eql q (1- i)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest truncate.14 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (truncate x)) + unless (and (eql q i) + (eql r rrad)) + collect (list i x q r))) nil) (deftest truncate.15 (let* ((radix (float-radix 1.0f0)) - (rad (float radix 1.0f0)) - (rrad (/ 1.0f0 rad))) + (rad (float radix 1.0f0)) + (rrad (/ 1.0f0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (truncate x)) + unless (and (eql q (1- i)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest truncate.16 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (truncate x)) + unless (and (eql q i) + (eql r rrad)) + collect (list i x q r))) nil) (deftest truncate.17 (let* ((radix (float-radix 1.0d0)) - (rad (float radix 1.0d0)) - (rrad (/ 1.0d0 rad))) + (rad (float radix 1.0d0)) + (rrad (/ 1.0d0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (truncate x)) + unless (and (eql q (1- i)) + (eql r rrad)) + collect (list i x q r))) nil) (deftest truncate.18 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 - for x = (+ i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q i) - (eql r rrad)) - collect (list i x q r))) + for x = (+ i rrad) + for (q r) = (multiple-value-list (truncate x)) + unless (and (eql q i) + (eql r rrad)) + collect (list i x q r))) nil) (deftest truncate.19 (let* ((radix (float-radix 1.0l0)) - (rad (float radix 1.0l0)) - (rrad (/ 1.0l0 rad))) + (rad (float radix 1.0l0)) + (rrad (/ 1.0l0 rad))) (loop for i from 1 to 1000 - for x = (- i rrad) - for (q r) = (multiple-value-list (truncate x)) - unless (and (eql q (1- i)) - (eql r rrad)) - collect (list i x q r))) + for x = (- i rrad) + for (q r) = (multiple-value-list (truncate x)) + unless (and (eql q (1- i)) + (eql r rrad)) + collect (list i x q r))) nil) diff --git a/ansi-tests/two-way-stream-input-stream.lsp b/ansi-tests/two-way-stream-input-stream.lsp index 1d96e010..139916ee 100644 --- a/ansi-tests/two-way-stream-input-stream.lsp +++ b/ansi-tests/two-way-stream-input-stream.lsp @@ -7,10 +7,10 @@ (deftest two-way-stream-input-stream.1 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (equalt (multiple-value-list (two-way-stream-input-stream s)) - (list is))) + (list is))) t) (deftest two-way-stream-input-stream.error.1 @@ -19,8 +19,8 @@ (deftest two-way-stream-input-stream.error.2 (signals-error (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (two-way-stream-input-stream s nil)) - program-error) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) + (two-way-stream-input-stream s nil)) + program-error) t) diff --git a/ansi-tests/two-way-stream-output-stream.lsp b/ansi-tests/two-way-stream-output-stream.lsp index a8415e0d..3fa39b1a 100644 --- a/ansi-tests/two-way-stream-output-stream.lsp +++ b/ansi-tests/two-way-stream-output-stream.lsp @@ -7,10 +7,10 @@ (deftest two-way-stream-output-stream.1 (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) (equalt (multiple-value-list (two-way-stream-output-stream s)) - (list os))) + (list os))) t) (deftest two-way-stream-output-stream.error.1 @@ -19,8 +19,8 @@ (deftest two-way-stream-output-stream.error.2 (signals-error (let* ((is (make-string-input-stream "foo")) - (os (make-string-output-stream)) - (s (make-two-way-stream is os))) - (two-way-stream-output-stream s nil)) - program-error) + (os (make-string-output-stream)) + (s (make-two-way-stream is os))) + (two-way-stream-output-stream s nil)) + program-error) t) diff --git a/ansi-tests/type-of.lsp b/ansi-tests/type-of.lsp index 6bf2f2c5..662f6dd7 100644 --- a/ansi-tests/type-of.lsp +++ b/ansi-tests/type-of.lsp @@ -12,12 +12,12 @@ (deftest type-of.1 :notes :type-of/strict-builtins (loop for x in *universe* - for tp = (type-of x) - for failures = (loop for tp2 in *cl-all-type-symbols* - when (and (typep x tp2) - (not (subtypep tp tp2))) - collect tp2) - when failures collect (list x failures)) + for tp = (type-of x) + for failures = (loop for tp2 in *cl-all-type-symbols* + when (and (typep x tp2) + (not (subtypep tp tp2))) + collect tp2) + when failures collect (list x failures)) nil) ;;; Some have objected to that (in type-of.1) interpretation @@ -27,13 +27,13 @@ (deftest type-of.1-relaxed (loop for x in *universe* - for builtins = (remove x *cl-all-type-symbols* - :test (complement #'typep)) - for tp = (type-of x) - when (and builtins - (not (loop for tp2 in builtins - thereis (subtypep tp tp2)))) - collect x) + for builtins = (remove x *cl-all-type-symbols* + :test (complement #'typep)) + for tp = (type-of x) + when (and builtins + (not (loop for tp2 in builtins + thereis (subtypep tp tp2)))) + collect x) nil) ;;; 1. For any object that is an element of some built-in type: @@ -45,33 +45,33 @@ (deftest type-of.2 (loop for x in *universe* - for tp = (type-of x) - when (and (consp tp) - (member (car tp) '(and eql member not or satisfies values - function))) - collect x) + for tp = (type-of x) + when (and (consp tp) + (member (car tp) '(and eql member not or satisfies values + function))) + collect x) nil) (deftest type-of.3 (loop for x in *universe* - unless (typep x (type-of x)) - collect x) + unless (typep x (type-of x)) + collect x) nil) (deftest type-of.4 (loop for x in *universe* - for tp = (type-of x) - for class = (class-of x) - unless (equal (multiple-value-list (subtypep* tp class)) '(t t)) - collect x) + for tp = (type-of x) + for class = (class-of x) + unless (equal (multiple-value-list (subtypep* tp class)) '(t t)) + collect x) nil) (deftest type-of.5 (loop for x in *cl-condition-type-symbols* - for cnd = (make-condition x) - for tp = (type-of cnd) - unless (eq x tp) - collect x) + for cnd = (make-condition x) + for tp = (type-of cnd) + unless (eq x tp) + collect x) nil) (defstruct type-of.example-struct a b c) @@ -100,14 +100,14 @@ (deftest type-of.10 (let* ((class (eval '(defclass type-of.example-class-4 () ((a) (b) (c))))) - (obj (make-instance class))) + (obj (make-instance class))) (setf (class-name class) nil) (notnot-mv (typep obj class))) t) (deftest type-of.11 (let* ((c #c(-1 1/2)) - (type (type-of c))) + (type (type-of c))) (notnot (typep c type))) t) @@ -119,5 +119,5 @@ (deftest type-of.error.2 (signals-error (type-of nil nil) program-error) - t) + t) diff --git a/ansi-tests/type.lsp b/ansi-tests/type.lsp index a8818067..17244f41 100644 --- a/ansi-tests/type.lsp +++ b/ansi-tests/type.lsp @@ -20,43 +20,43 @@ (let ((x 1)) (declare (type (integer -1 1) x)) (locally (declare (type (integer 0 2) x)) - (values - x - (setq x 0) - (1+ x)))) + (values + x + (setq x 0) + (1+ x)))) 1 0 1) (deftest type.3 (loop for x in *mini-universe* - for tp = (type-of x) - for form = `(let ((y ',x)) - (declare (type ,tp y)) - y) - for val = (eval form) - unless (eql val x) - collect (list x tp form val)) + for tp = (type-of x) + for form = `(let ((y ',x)) + (declare (type ,tp y)) + y) + for val = (eval form) + unless (eql val x) + collect (list x tp form val)) nil) (deftest type.4 (loop for x in *mini-universe* - for tp = (type-of x) - for form = `(let ((y ',x)) - (declare (,tp y)) - y) - for val = (eval form) - unless (eql val x) - collect (list x tp form val)) + for tp = (type-of x) + for form = `(let ((y ',x)) + (declare (,tp y)) + y) + for val = (eval form) + unless (eql val x) + collect (list x tp form val)) nil) (deftest type.5 (loop for x in *mini-universe* - for class = (class-of x) - for form = `(let ((y ',x)) - (declare (,class y)) - y) - for val = (eval form) - unless (eql val x) - collect (list x class form val)) + for class = (class-of x) + for form = `(let ((y ',x)) + (declare (,class y)) + y) + for val = (eval form) + unless (eql val x) + collect (list x class form val)) nil) ;;; Free TYPE declaration diff --git a/ansi-tests/typecase.lsp b/ansi-tests/typecase.lsp index 777e0f7a..50a02817 100644 --- a/ansi-tests/typecase.lsp +++ b/ansi-tests/typecase.lsp @@ -75,8 +75,8 @@ (block done (tagbody (typecase 'a (symbol (go 10) - 10 - (return-from done 'bad))) + 10 + (return-from done 'bad))) 10 (return-from done 'good))) good) @@ -87,34 +87,34 @@ (typecase 'a (integer 'bad) (t (go 10) - 10 - (return-from done 'bad))) + 10 + (return-from done 'bad))) 10 (return-from done 'good))) good) (deftest typecase.18 (loop for x in '(a 1 1.4 "c") - collect (typecase x - (t :good) - (otherwise :bad))) + collect (typecase x + (t :good) + (otherwise :bad))) (:good :good :good :good)) ;;; A randomized test (deftest typecase.19 (let* ((u (coerce *universe* 'vector)) - (len1 (length u)) - (types (coerce *cl-all-type-symbols* 'vector)) - (len2 (length types))) + (len1 (length u)) + (types (coerce *cl-all-type-symbols* 'vector)) + (len2 (length types))) (loop for n = (random 10) for my-types = (loop repeat n collect (elt types (random len2))) for val = (elt u (random len1)) for i = (position val my-types :test #'typep) for form = `(typecase ',val - ,@(loop for i from 0 for type in my-types collect `(,type ,i)) - (otherwise nil)) + ,@(loop for i from 0 for type in my-types collect `(,type ,i)) + (otherwise nil)) for j = (eval form) repeat 1000 unless (eql i j) @@ -128,18 +128,18 @@ (macrolet ((%m (z) z)) (typecase (expand-in-current-env (%m 2)) - ((integer 0 1) :bad1) - ((integer 2 10) :good) - (t :bad2))) + ((integer 0 1) :bad1) + ((integer 2 10) :good) + (t :bad2))) :good) (deftest typecase.21 (macrolet ((%m (z) z)) (typecase 2 - ((integer 0 1) (expand-in-current-env (%m :bad1))) - ((integer 2 10) (expand-in-current-env (%m :good))) - (t (expand-in-current-env (%m :bad2))))) + ((integer 0 1) (expand-in-current-env (%m :bad1))) + ((integer 2 10) (expand-in-current-env (%m :good))) + (t (expand-in-current-env (%m :bad2))))) :good) ;;; Error cases @@ -150,13 +150,13 @@ (deftest typecase.error.2 (signals-error (funcall (macro-function 'typecase) - '(typecase t)) program-error) + '(typecase t)) program-error) t) (deftest typecase.error.3 (signals-error (funcall (macro-function 'typecase) - '(typecase t) - nil nil) program-error) + '(typecase t) + nil nil) program-error) t) diff --git a/ansi-tests/typep.lsp b/ansi-tests/typep.lsp index 5fc8dfdb..12ee7bb5 100644 --- a/ansi-tests/typep.lsp +++ b/ansi-tests/typep.lsp @@ -52,13 +52,13 @@ (deftest typep.env.2 (macrolet ((%foo (&environment env) - (notnot-mv (typep 0 'bit env)))) + (notnot-mv (typep 0 'bit env)))) (%foo)) t) (deftest typep.env.3 (macrolet ((%foo (&environment env) - (notnot-mv (typep env (type-of env))))) + (notnot-mv (typep env (type-of env))))) (%foo)) t) @@ -130,13 +130,13 @@ (deftest typep.16 (let ((c1 (find-class 'number)) - (c2 (find-class 'symbol))) + (c2 (find-class 'symbol))) (notnot-mv (typep 'a `(or ,c1 ,c2)))) t) (deftest typep.17 (let ((c1 (find-class 'number)) - (c2 (find-class 'symbol))) + (c2 (find-class 'symbol))) (notnot-mv (typep 'a `(or ,c2 ,c1)))) t) @@ -150,19 +150,19 @@ (defun typep.19-fn (reps &optional (prob .5)) (let* ((vec "abcdefghijklmnopqrstuvwxyz")) (flet ((%make-random-type - () - `(and character (member ,@(loop for e across vec - when (< (random 1.0) prob) - collect e))))) - (loop + () + `(and character (member ,@(loop for e across vec + when (< (random 1.0) prob) + collect e))))) + (loop for t1 = (%make-random-type) for t2 = (%make-random-type) for t3 = `(and ,t1 ,t2) for result1 = (loop for e across vec - when (if (typep e t3) - (or (not (typep e t1)) (not (typep e t2))) - (and (typep e t1) (typep e t2))) - collect e) + when (if (typep e t3) + (or (not (typep e t1)) (not (typep e t2))) + (and (typep e t1) (typep e t2))) + collect e) repeat reps when result1 nconc (list result1 t1 t2 t3))))) @@ -171,5 +171,5 @@ (deftest typep.19 (typep.19-fn 1000) nil) - - + + diff --git a/ansi-tests/types-and-class-2.lsp b/ansi-tests/types-and-class-2.lsp index 3c518956..b11f147b 100644 --- a/ansi-tests/types-and-class-2.lsp +++ b/ansi-tests/types-and-class-2.lsp @@ -11,11 +11,11 @@ (deftest type-or-not-type-is-everything (loop for l in *disjoint-types-list2* - append - (loop - for type in l - append (check-subtypep t `(or ,type (not ,type)) t) - append (check-subtypep t `(or (not ,type) ,type) t))) + append + (loop + for type in l + append (check-subtypep t `(or ,type (not ,type)) t) + append (check-subtypep t `(or (not ,type) ,type) t))) nil) (defclass tac-1-class () (a b c)) @@ -24,10 +24,10 @@ (deftest user-class-disjointness (loop for l in *disjoint-types-list2* - append - (loop - for type in l - append (classes-are-disjoint type 'tac-1-class))) + append + (loop + for type in l + append (classes-are-disjoint type 'tac-1-class))) nil) (deftest user-class-disjointness-2 @@ -40,10 +40,10 @@ (deftest user-struct-disjointness (loop for l in *disjoint-types-list2* - append - (loop - for type in l - append (check-disjointness type 'tac-2-struct))) + append + (loop + for type in l + append (check-disjointness type 'tac-2-struct))) nil) (deftest user-struct-disjointness-2 @@ -126,12 +126,12 @@ (deftest tac-3.17 (check-equivalence '(and (or tac-3-a tac-3-b) - (or (not tac-3-a) (not tac-3-b)) - (or tac-3-a tac-3-c) - (or (not tac-3-a) (not tac-3-c)) - (or tac-3-b tac-3-c) - (or (not tac-3-b) (not tac-3-c))) - nil) + (or (not tac-3-a) (not tac-3-b)) + (or tac-3-a tac-3-c) + (or (not tac-3-a) (not tac-3-c)) + (or tac-3-b tac-3-c) + (or (not tac-3-b) (not tac-3-c))) + nil) nil) ;;; @@ -140,10 +140,10 @@ ;;; (deftest universe-elements-in-at-most-one-disjoint-type (loop for e in *universe* - for types = (remove-if-not #'(lambda (x) (typep e x)) - *disjoint-types-list*) - when (> (length types) 1) - collect (list e types)) + for types = (remove-if-not #'(lambda (x) (typep e x)) + *disjoint-types-list*) + when (> (length types) 1) + collect (list e types)) nil) diff --git a/ansi-tests/types-and-class.lsp b/ansi-tests/types-and-class.lsp index f217f6a1..29150a89 100644 --- a/ansi-tests/types-and-class.lsp +++ b/ansi-tests/types-and-class.lsp @@ -46,41 +46,41 @@ #| (defun types.4-body () (let ((parent-table (make-hash-table :test #'equal)) - (types nil)) + (types nil)) (loop - for p in *subtype-table* do - (let ((tp (first p)) - (parent (second p))) - (pushnew tp types) - (pushnew parent types) - (let ((parents (gethash tp parent-table))) - (pushnew parent parents) - ;; (format t "~S ==> ~S~%" tp parent) - (loop - for pp in (gethash parent parent-table) do - ;; (format t "~S ==> ~S~%" tp pp) - (pushnew pp parents)) - (setf (gethash tp parent-table) parents)))) + for p in *subtype-table* do + (let ((tp (first p)) + (parent (second p))) + (pushnew tp types) + (pushnew parent types) + (let ((parents (gethash tp parent-table))) + (pushnew parent parents) + ;; (format t "~S ==> ~S~%" tp parent) + (loop + for pp in (gethash parent parent-table) do + ;; (format t "~S ==> ~S~%" tp pp) + (pushnew pp parents)) + (setf (gethash tp parent-table) parents)))) ;; parent-table now contains lists of ancestors (loop - for tp in types sum - (let ((parents (gethash tp parent-table))) - (loop - for tp2 in types sum - (cond - ((and (not (eqt tp tp2)) - (not (eqt tp2 'standard-object)) - (not (eqt tp2 'structure-object)) - (not (member tp2 parents)) - (subtypep* tp tp2) - (not (and (member tp +float-types+) - (member tp2 +float-types+))) - (not (and (eqt tp2 'structure-object) - (member 'standard-object parents)))) - (format t "~%Improper subtype: ~S of ~S" - tp tp2) - 1) - (t 0))))) + for tp in types sum + (let ((parents (gethash tp parent-table))) + (loop + for tp2 in types sum + (cond + ((and (not (eqt tp tp2)) + (not (eqt tp2 'standard-object)) + (not (eqt tp2 'structure-object)) + (not (member tp2 parents)) + (subtypep* tp tp2) + (not (and (member tp +float-types+) + (member tp2 +float-types+))) + (not (and (eqt tp2 'structure-object) + (member 'standard-object parents)))) + (format t "~%Improper subtype: ~S of ~S" + tp tp2) + 1) + (t 0))))) )) (deftest types.4 @@ -98,21 +98,21 @@ (deftest types.7b (loop for e on *disjoint-types-list* - for tp1 = (first e) - append - (loop for tp2 in (rest e) - append (classes-are-disjoint tp1 tp2))) + for tp1 = (first e) + append + (loop for tp2 in (rest e) + append (classes-are-disjoint tp1 tp2))) nil) (deftest types.7c (loop for e on *disjoint-types-list2* - for list1 = (first e) - append - (loop for tp1 in list1 append - (loop for list2 in (rest e) - append - (loop for tp2 in list2 append - (classes-are-disjoint tp1 tp2))))) + for list1 = (first e) + append + (loop for tp1 in list1 append + (loop for list2 in (rest e) + append + (loop for tp2 in list2 append + (classes-are-disjoint tp1 tp2))))) nil) (deftest types.8 @@ -120,7 +120,7 @@ for tp in *disjoint-types-list* count (cond ((and (not (eqt tp 'cons)) - (not (subtypep* tp 'atom))) + (not (subtypep* tp 'atom))) (format t "~%Should be atomic, but isn't: ~S" tp) t))) 0) @@ -166,10 +166,10 @@ (deftest all-classes-are-type-equivalent-to-their-names.2 (loop for x in *universe* - for cl = (class-of x) - for name = (class-name cl) - when name - append (check-equivalence name cl)) + for cl = (class-of x) + for name = (class-name cl) + when name + append (check-equivalence name cl)) nil) ;;; Check that all class names in CL that name standard-classes or @@ -178,48 +178,48 @@ (deftest all-standard-classes-are-subtypes-of-standard-object (loop for sym being the external-symbols of "COMMON-LISP" - for class = (find-class sym nil) - when (and class - (typep class 'standard-class) - (or (not (subtypep sym 'standard-object)) - (not (subtypep class 'standard-object)))) - collect sym) + for class = (find-class sym nil) + when (and class + (typep class 'standard-class) + (or (not (subtypep sym 'standard-object)) + (not (subtypep class 'standard-object)))) + collect sym) nil) (deftest all-standard-classes-are-subtypes-of-standard-object.2 (loop for x in *universe* - for class = (class-of x) - when (and (typep class 'standard-class) - (not (subtypep class 'standard-object))) - collect x) + for class = (class-of x) + when (and (typep class 'standard-class) + (not (subtypep class 'standard-object))) + collect x) nil) (deftest all-structure-classes-are-subtypes-of-structure-object (loop for sym being the external-symbols of "COMMON-LISP" - for class = (find-class sym nil) - when (and class - (typep class 'structure-class) - (or (not (subtypep sym 'structure-object)) - (not (subtypep class 'structure-object)))) - collect sym) + for class = (find-class sym nil) + when (and class + (typep class 'structure-class) + (or (not (subtypep sym 'structure-object)) + (not (subtypep class 'structure-object)))) + collect sym) nil) (deftest all-structure-classes-are-subtypes-of-structure-object.2 (loop for x in *universe* - for cl = (class-of x) - when (and (typep cl 'structure-class) - (not (subtypep cl 'structure-object))) - collect x) + for cl = (class-of x) + when (and (typep cl 'structure-class) + (not (subtypep cl 'structure-object))) + collect x) nil) - + ;;; Confirm that only the symbols exported from CL that are supposed ;;; to be types are actually classes (see section 11.1.2.1.1) (deftest all-exported-cl-class-names-are-valid (loop for sym being the external-symbols of "COMMON-LISP" - when (and (find-class sym nil) - (not (member sym *cl-all-type-symbols* :test #'eq))) - collect sym) + when (and (find-class sym nil) + (not (member sym *cl-all-type-symbols* :test #'eq))) + collect sym) nil) ;;; Confirm that all standard generic functions are instances of @@ -227,10 +227,10 @@ (deftest all-standard-generic-functions-are-instances-of-that-class (loop for sym in *cl-standard-generic-function-symbols* - for fun = (and (fboundp sym) (symbol-function sym)) - unless (and (typep fun 'generic-function) - (typep fun 'standard-generic-function)) - collect (list sym fun)) + for fun = (and (fboundp sym) (symbol-function sym)) + unless (and (typep fun 'generic-function) + (typep fun 'standard-generic-function)) + collect (list sym fun)) nil) ;;; Canonical metaobjects are in the right classes @@ -266,7 +266,7 @@ (deftest type-error-expected-type.1 (let ((c (make-condition 'type-error - :datum 'a :expected-type 'integer))) + :datum 'a :expected-type 'integer))) (type-error-expected-type c)) integer) @@ -279,20 +279,20 @@ (deftest type-error-datum.error.2 (signals-error (let ((c (make-condition 'type-error :datum nil - :expected-type t))) + :expected-type t))) (type-error-datum c nil)) program-error) t) (deftest type-error-expected-type.error.1 (signals-error (type-error-expected-type) - program-error) + program-error) t) (deftest type-error-expected-type.error.2 (signals-error (let ((c (make-condition 'type-error :datum nil - :expected-type t))) + :expected-type t))) (type-error-expected-type c nil)) program-error) t) diff --git a/ansi-tests/types-aux.lsp b/ansi-tests/types-aux.lsp index 7956181e..efbba764 100644 --- a/ansi-tests/types-aux.lsp +++ b/ansi-tests/types-aux.lsp @@ -10,7 +10,7 @@ class, then check for disjointness. Return a non-NIL list of failed subtypep relationships, if any." (and (or (is-builtin-class c1) - (is-builtin-class c2)) + (is-builtin-class c2)) (check-disjointness c1 c2))) (declaim (special *subtype-table*)) @@ -21,16 +21,16 @@ for tp = (car p) append (and (not (member tp '(sequence cons list t))) - (let ((message (check-subtypep tp 'atom t t))) - (if message (list message)))))) + (let ((message (check-subtypep tp 'atom t t))) + (if message (list message)))))) (defparameter *type-list* nil) (defparameter *supertype-table* nil) (defun types.9-body () (let ((tp-list (append '(keyword atom list) - (loop for p in *subtype-table* collect (car p)))) - (result-list)) + (loop for p in *subtype-table* collect (car p)))) + (result-list)) (setf tp-list (remove-duplicates tp-list)) ;; TP-LIST is now a list of unique CL type names ;; Store it in *TYPE-LIST* so we can inspect it later if this test @@ -39,36 +39,36 @@ ;; Compute all pairwise SUBTYPEP relationships among ;; the elements of *TYPE-LIST*. (let ((subs (make-hash-table :test #'eq)) - (sups (make-hash-table :test #'eq))) + (sups (make-hash-table :test #'eq))) (loop - for x in tp-list do - (loop - for y in tp-list do - (multiple-value-bind (result good) - (subtypep* x y) - (declare (ignore good)) - (when result - (pushnew x (gethash y subs)) - (pushnew y (gethash x sups)))))) + for x in tp-list do + (loop + for y in tp-list do + (multiple-value-bind (result good) + (subtypep* x y) + (declare (ignore good)) + (when result + (pushnew x (gethash y subs)) + (pushnew y (gethash x sups)))))) ;; Store the supertype relations for later inspection ;; and use in test TYPES.9A (setf *supertype-table* sups) ;; Check that the relation we just computed is transitive. ;; Return a list of triples on which transitivity fails. (loop - for x in tp-list do - (let ((sub-list (gethash x subs)) - (sup-list (gethash x sups))) - (loop - for t1 in sub-list do - (loop - for t2 in sup-list do - (multiple-value-bind (result good) - (subtypep* t1 t2) - (when (and good (not result)) - (pushnew (list t1 x t2) result-list - :test #'equal))))))) - + for x in tp-list do + (let ((sub-list (gethash x subs)) + (sup-list (gethash x sups))) + (loop + for t1 in sub-list do + (loop + for t2 in sup-list do + (multiple-value-bind (result good) + (subtypep* t1 t2) + (when (and good (not result)) + (pushnew (list t1 x t2) result-list + :test #'equal))))))) + result-list))) ;;; TYPES.9-BODY returns a list of triples (T1 T2 T3) @@ -87,26 +87,26 @@ sum (let ((sups (gethash tp *supertype-table*))) (loop - for x in *universe* - sum - (handler-case - (cond - ((not (typep x tp)) 0) - (t - (loop - for tp2 in sups - count - (handler-case - (and (not (typep x tp2)) - (progn - (format t "Found element of ~S not in ~S: ~S~%" - tp tp2 x) - t)) - (condition (c) (format t "Error ~S occured: ~S~%" - c tp2) - t))))) - (condition (c) (format t "Error ~S occured: ~S~%" c tp) - 1)))))))) + for x in *universe* + sum + (handler-case + (cond + ((not (typep x tp)) 0) + (t + (loop + for tp2 in sups + count + (handler-case + (and (not (typep x tp2)) + (progn + (format t "Found element of ~S not in ~S: ~S~%" + tp tp2 x) + t)) + (condition (c) (format t "Error ~S occured: ~S~%" + c tp2) + t))))) + (condition (c) (format t "Error ~S occured: ~S~%" c tp) + 1)))))))) (defun check-subtypep (type1 type2 is-sub &optional should-be-valid) (multiple-value-bind @@ -115,9 +115,9 @@ (unless (constantp type1) (setq type1 (list 'quote type1))) (unless (constantp type2) (setq type2 (list 'quote type2))) (if (or (and valid sub (not is-sub)) - (and valid (not sub) is-sub) - (and (not valid) should-be-valid)) - `(((SUBTYPEP ,type1 ,type2) :==> ,sub ,valid)) + (and valid (not sub) is-sub) + (and (not valid) should-be-valid)) + `(((SUBTYPEP ,type1 ,type2) :==> ,sub ,valid)) nil))) ;;; Check that the subtype relationships implied @@ -177,12 +177,12 @@ (multiple-value-bind (sub1 success1) (subtypep* t1 t2) (multiple-value-bind (sub2 success2) - (subtypep* `(not ,t2) `(not ,t1)) + (subtypep* `(not ,t2) `(not ,t1)) (or (not success1) - (not success2) - (eqlt sub1 sub2))))) + (not success2) + (eqlt sub1 sub2))))) ;;; For use in deftype tests (deftype even-array (&optional type size) `(and (array ,type ,size) - (satisfies even-size-p))) + (satisfies even-size-p))) diff --git a/ansi-tests/unbound-slot.lsp b/ansi-tests/unbound-slot.lsp index 36045c6b..2da3af5c 100644 --- a/ansi-tests/unbound-slot.lsp +++ b/ansi-tests/unbound-slot.lsp @@ -13,10 +13,10 @@ (handler-case (slot-value obj 'a) (unbound-slot (c) - (values - (typep* c 'cell-error) - (eqt (unbound-slot-instance c) obj) - (cell-error-name c))))) + (values + (typep* c 'cell-error) + (eqt (unbound-slot-instance c) obj) + (cell-error-name c))))) t t a) (defclass ubs-class-02 () @@ -27,10 +27,10 @@ (handler-case (slot-value obj 'b) (unbound-slot (c) - (values - (typep* c 'cell-error) - (eqt (unbound-slot-instance c) obj) - (cell-error-name c))))) + (values + (typep* c 'cell-error) + (eqt (unbound-slot-instance c) obj) + (cell-error-name c))))) t t b) diff --git a/ansi-tests/unexport.lsp b/ansi-tests/unexport.lsp index 628b5a20..d8d7ae50 100644 --- a/ansi-tests/unexport.lsp +++ b/ansi-tests/unexport.lsp @@ -13,95 +13,95 @@ (progn (safely-delete-package "X") (let* ((p (make-package "X" :use nil)) - (r (export (intern "X" p) p)) - (i 0) x y) + (r (export (intern "X" p) p)) + (i 0) x y) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (unexport (progn (setf x (incf i)) sym1) - (progn (setf y (incf i)) p)) + (progn (setf y (incf i)) p)) (multiple-value-bind* - (sym2 access2) - (find-symbol "X" p) - (and (eqt r t) - (eql i 2) (eql x 1) (eql y 2) - (eqt sym1 sym2) - (eqt access1 :external) - (eqt access2 :internal) - (equal (symbol-name sym1) "X") - t))))) + (sym2 access2) + (find-symbol "X" p) + (and (eqt r t) + (eql i 2) (eql x 1) (eql y 2) + (eqt sym1 sym2) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) t) - + (deftest unexport.2 (progn (safely-delete-package "X") (let* ((p (make-package "X" :use nil)) - (r (export (intern "X" p) p))) + (r (export (intern "X" p) p))) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (unexport (list sym1) "X") (multiple-value-bind* - (sym2 access2) - (find-symbol "X" p) - (and (eqt sym1 sym2) - (eqt r t) - (eqt access1 :external) - (eqt access2 :internal) - (equal (symbol-name sym1) "X") - t))))) + (sym2 access2) + (find-symbol "X" p) + (and (eqt sym1 sym2) + (eqt r t) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) t) (deftest unexport.3 (progn (safely-delete-package "X") (let* ((p (make-package "X" :use nil)) - (r1 (export (intern "X" p) p)) - (r2 (export (intern "Y" p) p))) + (r1 (export (intern "X" p) p)) + (r2 (export (intern "Y" p) p))) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (multiple-value-bind* - (sym1a access1a) - (find-symbol "Y" p) - (unexport (list sym1 sym1a) '#:|X|) - (multiple-value-bind* - (sym2 access2) - (find-symbol "X" p) - (multiple-value-bind* - (sym2a access2a) - (find-symbol "Y" p) - (and (eqt sym1 sym2) - (eqt sym1a sym2a) - (eqt r1 t) - (eqt r2 t) - (eqt access1 :external) - (eqt access2 :internal) - (eqt access1a :external) - (eqt access2a :internal) - (equal (symbol-name sym1) "X") - (equal (symbol-name sym1a) "Y") - t))))))) + (sym1a access1a) + (find-symbol "Y" p) + (unexport (list sym1 sym1a) '#:|X|) + (multiple-value-bind* + (sym2 access2) + (find-symbol "X" p) + (multiple-value-bind* + (sym2a access2a) + (find-symbol "Y" p) + (and (eqt sym1 sym2) + (eqt sym1a sym2a) + (eqt r1 t) + (eqt r2 t) + (eqt access1 :external) + (eqt access2 :internal) + (eqt access1a :external) + (eqt access2a :internal) + (equal (symbol-name sym1) "X") + (equal (symbol-name sym1a) "Y") + t))))))) t) (deftest unexport.4 (progn (safely-delete-package "X") (let* ((p (make-package "X" :use nil)) - (r (export (intern "X" p) p))) + (r (export (intern "X" p) p))) (multiple-value-bind* (sym1 access1) (find-symbol "X" p) (unexport (list sym1) #\X) (multiple-value-bind* - (sym2 access2) - (find-symbol "X" p) - (and (eqt sym1 sym2) - (eqt r t) - (eqt access1 :external) - (eqt access2 :internal) - (equal (symbol-name sym1) "X") - t))))) + (sym2 access2) + (find-symbol "X" p) + (and (eqt sym1 sym2) + (eqt r t) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) t) ;; Check that it signals a package error when unexporting @@ -123,15 +123,15 @@ (when (find-package "X") (delete-package "X")) (let ((p (make-package "X" :use nil))) (let* ((sym (intern "FOO" p)) - (r (unexport sym p))) - (multiple-value-bind* - (sym2 access) - (find-symbol "FOO" p) - (and (eqt r t) - (eqt access :internal) - (eqt sym sym2) - (equal (symbol-name sym) "FOO") - t))))) + (r (unexport sym p))) + (multiple-value-bind* + (sym2 access) + (find-symbol "FOO" p) + (and (eqt r t) + (eqt access :internal) + (eqt sym sym2) + (equal (symbol-name sym) "FOO") + t))))) t) ;;; Specialized sequence tests @@ -141,20 +141,20 @@ (let ((name ,name-form)) (safely-delete-package name) (let* ((p (make-package name :use nil)) - (r (export (intern "X" p) p))) - (multiple-value-bind* - (sym1 access1) - (find-symbol "X" p) - (unexport (list sym1) name) - (multiple-value-bind* - (sym2 access2) - (find-symbol "X" p) - (and (eqt sym1 sym2) - (eqt r t) - (eqt access1 :external) - (eqt access2 :internal) - (equal (symbol-name sym1) "X") - t))))) + (r (export (intern "X" p) p))) + (multiple-value-bind* + (sym1 access1) + (find-symbol "X" p) + (unexport (list sym1) name) + (multiple-value-bind* + (sym2 access2) + (find-symbol "X" p) + (and (eqt sym1 sym2) + (eqt r t) + (eqt access1 :external) + (eqt access2 :internal) + (equal (symbol-name sym1) "X") + t))))) t)) (def-unexport-test unexport.7 @@ -162,35 +162,35 @@ (def-unexport-test unexport.8 (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) + :fill-pointer 5 :element-type 'base-char)) (def-unexport-test unexport.9 (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) + :fill-pointer 5 :element-type 'character)) (def-unexport-test unexport.10 (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) + :adjustable t :element-type 'base-char)) (def-unexport-test unexport.11 (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) + :adjustable t :element-type 'character)) (def-unexport-test unexport.12 (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + :displaced-to name0 + :displaced-index-offset 5))) (def-unexport-test unexport.13 (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + :displaced-to name0 + :displaced-index-offset 5))) ;;; Error tests diff --git a/ansi-tests/unintern.lsp b/ansi-tests/unintern.lsp index f8039692..e6f2f341 100644 --- a/ansi-tests/unintern.lsp +++ b/ansi-tests/unintern.lsp @@ -15,19 +15,19 @@ (progn (safely-delete-package "H") (prog1 - (let ((p (make-package "H" :use nil)) - (i 0) x y) - (intern "FOO" p) - (multiple-value-bind* - (sym access) - (find-symbol "FOO" p) - (and - (eqt access :internal) - (unintern (progn (setf x (incf i)) sym) - (progn (setf y (incf i)) p)) - (eql i 2) (eql x 1) (eql y 2) - (null (symbol-package sym)) - (not (find-symbol "FOO" p))))) + (let ((p (make-package "H" :use nil)) + (i 0) x y) + (intern "FOO" p) + (multiple-value-bind* + (sym access) + (find-symbol "FOO" p) + (and + (eqt access :internal) + (unintern (progn (setf x (incf i)) sym) + (progn (setf y (incf i)) p)) + (eql i 2) (eql x 1) (eql y 2) + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) t) @@ -37,15 +37,15 @@ (progn (safely-delete-package "H") (prog1 - (let ((*PACKAGE* (make-package "H" :use nil))) - (intern "FOO") - (multiple-value-bind* (sym access) - (find-symbol "FOO") - (and - (eqt access :internal) - (unintern sym) - (null (symbol-package sym)) - (not (find-symbol "FOO"))))) + (let ((*PACKAGE* (make-package "H" :use nil))) + (intern "FOO") + (multiple-value-bind* (sym access) + (find-symbol "FOO") + (and + (eqt access :internal) + (unintern sym) + (null (symbol-package sym)) + (not (find-symbol "FOO"))))) (safely-delete-package "H"))) t) @@ -54,15 +54,15 @@ (progn (safely-delete-package "H") (prog1 - (let ((p (make-package "H" :use nil))) - (intern "FOO" p) - (multiple-value-bind* (sym access) - (find-symbol "FOO" p) - (and - (eqt access :internal) - (unintern sym "H") - (null (symbol-package sym)) - (not (find-symbol "FOO" p))))) + (let ((p (make-package "H" :use nil))) + (intern "FOO" p) + (multiple-value-bind* (sym access) + (find-symbol "FOO" p) + (and + (eqt access :internal) + (unintern sym "H") + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) t) @@ -71,15 +71,15 @@ (progn (safely-delete-package "H") (prog1 - (let ((p (make-package "H" :use nil))) - (intern "FOO" p) - (multiple-value-bind* (sym access) - (find-symbol "FOO" p) - (and - (eqt access :internal) - (unintern sym '#:|H|) - (null (symbol-package sym)) - (not (find-symbol "FOO" p))))) + (let ((p (make-package "H" :use nil))) + (intern "FOO" p) + (multiple-value-bind* (sym access) + (find-symbol "FOO" p) + (and + (eqt access :internal) + (unintern sym '#:|H|) + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) t) @@ -89,15 +89,15 @@ (progn (safely-delete-package "H") (prog1 - (let ((p (make-package "H" :use nil))) - (intern "FOO" p) - (multiple-value-bind* (sym access) - (find-symbol "FOO" p) - (and - (eqt access :internal) - (unintern sym #\H) - (null (symbol-package sym)) - (not (find-symbol "FOO" p))))) + (let ((p (make-package "H" :use nil))) + (intern "FOO" p) + (multiple-value-bind* (sym access) + (find-symbol "FOO" p) + (and + (eqt access :internal) + (unintern sym #\H) + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) (safely-delete-package "H"))) (error (c) c)) t) @@ -119,19 +119,19 @@ ;; At this point, G:FOO is also an external ;; symbol of H. (multiple-value-bind* (sym1 access1) - (find-symbol "FOO" "H") + (find-symbol "FOO" "H") (and sym1 - (eqt access1 :external) - (equal "FOO" (symbol-name sym1)) - (eqt (find-package "G") - (symbol-package sym1)) - (unintern sym1 "H") - (multiple-value-bind* (sym2 access2) - (find-symbol "FOO" "H") - (and (eqt sym1 sym2) - (eqt (symbol-package sym1) - (find-package "G")) - (eqt access2 :inherited)))))) + (eqt access1 :external) + (equal "FOO" (symbol-name sym1)) + (eqt (find-package "G") + (symbol-package sym1)) + (unintern sym1 "H") + (multiple-value-bind* (sym2 access2) + (find-symbol "FOO" "H") + (and (eqt sym1 sym2) + (eqt (symbol-package sym1) + (find-package "G")) + (eqt access2 :inherited)))))) (error (c) c)) t) @@ -142,26 +142,26 @@ (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use (list pg)))) - (handler-case - (shadow "FOO" ph) - (error (c) (return-from failed (list :shadow-error c)))) - (export (intern "FOO" pg) pg) - ;; At this point, H::FOO shadows G:FOO - (multiple-value-bind* (sym1 access1) - (find-symbol "FOO" ph) - (and - sym1 - (eqt (symbol-package sym1) ph) - (eqt access1 :internal) - (equal (list sym1) (package-shadowing-symbols ph)) - (unintern sym1 ph) - (multiple-value-bind* (sym2 access2) - (find-symbol "FOO" ph) - (and (not (eqt sym1 sym2)) - (eqt access2 :inherited) - (null (symbol-package sym1)) - (eqt (symbol-package sym2) pg))))))) + (ph (make-package "H" :use (list pg)))) + (handler-case + (shadow "FOO" ph) + (error (c) (return-from failed (list :shadow-error c)))) + (export (intern "FOO" pg) pg) + ;; At this point, H::FOO shadows G:FOO + (multiple-value-bind* (sym1 access1) + (find-symbol "FOO" ph) + (and + sym1 + (eqt (symbol-package sym1) ph) + (eqt access1 :internal) + (equal (list sym1) (package-shadowing-symbols ph)) + (unintern sym1 ph) + (multiple-value-bind* (sym2 access2) + (find-symbol "FOO" ph) + (and (not (eqt sym1 sym2)) + (eqt access2 :inherited) + (null (symbol-package sym1)) + (eqt (symbol-package sym2) pg))))))) t) ;; Error situation: when the symbol is uninterned, creates @@ -172,31 +172,31 @@ (safely-delete-package "G1") (safely-delete-package "G2") (let* ((pg1 (make-package "G1" :use nil)) - (pg2 (make-package "G2" :use nil)) - (ph (make-package "H" :use (list pg1 pg2)))) + (pg2 (make-package "G2" :use nil)) + (ph (make-package "H" :use (list pg1 pg2)))) (handler-case (shadow "FOO" ph) (error (c) (return-from failed (list :shadow-error c)))) (let ((gsym1 (intern "FOO" pg1)) - (gsym2 (intern "FOO" pg2))) - (export gsym1 pg1) - (export gsym2 pg2) - (multiple-value-bind* (sym1 access1) - (find-symbol "FOO" ph) - (and - (equal (list sym1) (package-shadowing-symbols ph)) - (not (eqt sym1 gsym1)) - (not (eqt sym1 gsym2)) - (eqt (symbol-package sym1) ph) - (eqt access1 :internal) - (equal (symbol-name sym1) "FOO") - (handler-case - (progn - (unintern sym1 ph) - nil) - (error (c) - (format t "Properly threw an error: ~S~%" c) - t))))))) + (gsym2 (intern "FOO" pg2))) + (export gsym1 pg1) + (export gsym2 pg2) + (multiple-value-bind* (sym1 access1) + (find-symbol "FOO" ph) + (and + (equal (list sym1) (package-shadowing-symbols ph)) + (not (eqt sym1 gsym1)) + (not (eqt sym1 gsym2)) + (eqt (symbol-package sym1) ph) + (eqt access1 :internal) + (equal (symbol-name sym1) "FOO") + (handler-case + (progn + (unintern sym1 ph) + nil) + (error (c) + (format t "Properly threw an error: ~S~%" c) + t))))))) t) ;; Now, inherit the same symbol through two intermediate @@ -209,31 +209,31 @@ (safely-delete-package "G2") (safely-delete-package "G3") (let* ((pg3 (make-package "G3" :use nil)) - (pg1 (make-package "G1" :use (list pg3))) - (pg2 (make-package "G2" :use (list pg3))) - (ph (make-package "H" :use (list pg1 pg2)))) + (pg1 (make-package "G1" :use (list pg3))) + (pg2 (make-package "G2" :use (list pg3))) + (ph (make-package "H" :use (list pg1 pg2)))) (handler-case (shadow "FOO" ph) (error (c) (return-from failed (list :shadow-error c)))) (let ((gsym (intern "FOO" pg3))) - (export gsym pg3) - (export gsym pg1) - (export gsym pg2) - (multiple-value-bind* (sym access) - (find-symbol "FOO" ph) - (and - (equal (list sym) (package-shadowing-symbols ph)) - (not (eqt sym gsym)) - (equal (symbol-name sym) "FOO") - (equal (symbol-package sym) ph) - (eqt access :internal) - (handler-case - (and (unintern sym ph) - (multiple-value-bind* (sym2 access2) - (find-symbol "FOO" ph) - (and (eqt gsym sym2) - (eqt access2 :inherited)))) - (error (c) c))))))) + (export gsym pg3) + (export gsym pg1) + (export gsym pg2) + (multiple-value-bind* (sym access) + (find-symbol "FOO" ph) + (and + (equal (list sym) (package-shadowing-symbols ph)) + (not (eqt sym gsym)) + (equal (symbol-name sym) "FOO") + (equal (symbol-package sym) ph) + (eqt access :internal) + (handler-case + (and (unintern sym ph) + (multiple-value-bind* (sym2 access2) + (find-symbol "FOO" ph) + (and (eqt gsym sym2) + (eqt access2 :inherited)))) + (error (c) c))))))) t) ;;; Specialized sequence tests @@ -243,17 +243,17 @@ (let ((name ,name-form)) (safely-delete-package name) (prog1 - (let ((p (make-package name :use nil))) - (intern "FOO" p) - (multiple-value-bind* - (sym access) - (find-symbol "FOO" p) - (and - (eqt access :internal) - (unintern sym name) - (null (symbol-package sym)) - (not (find-symbol "FOO" p))))) - (safely-delete-package name))) + (let ((p (make-package name :use nil))) + (intern "FOO" p) + (multiple-value-bind* + (sym access) + (find-symbol "FOO" p) + (and + (eqt access :internal) + (unintern sym name) + (null (symbol-package sym)) + (not (find-symbol "FOO" p))))) + (safely-delete-package name))) t)) (def-unintern-test unintern.10 @@ -261,35 +261,35 @@ (def-unintern-test unintern.11 (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) + :fill-pointer 5 :element-type 'base-char)) (def-unintern-test unintern.12 (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) + :fill-pointer 5 :element-type 'character)) (def-unintern-test unintern.13 (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) + :adjustable t :element-type 'base-char)) (def-unintern-test unintern.14 (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) + :adjustable t :element-type 'character)) (def-unintern-test unintern.15 (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + :displaced-to name0 + :displaced-index-offset 5))) (def-unintern-test unintern.16 (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + :displaced-to name0 + :displaced-index-offset 5))) (deftest unintern.error.1 diff --git a/ansi-tests/union.lsp b/ansi-tests/union.lsp index e85fa14d..400793cf 100644 --- a/ansi-tests/union.lsp +++ b/ansi-tests/union.lsp @@ -30,135 +30,135 @@ (deftest union.6 (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) + (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y))) (check-union x y result))) t) (deftest union.6-a (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) + (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test #'eq))) (check-union x y result))) t) (deftest union.7 (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) + (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test #'eql))) (check-union x y result))) t) (deftest union.8 (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) + (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test #'equal))) (check-union x y result))) t) (deftest union.9 (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) + (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test-not (complement #'eql)))) (check-union x y result))) t) (deftest union.10 (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) + (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test-not (complement #'equal)))) (check-union x y result))) t) (deftest union.11 (let ((x (copy-list '(a b c d e f))) - (y (copy-list '(z c y a v b)))) + (y (copy-list '(z c y a v b)))) (let ((result (union-with-check x y :test-not (complement #'eq)))) (check-union x y result))) t) (deftest union.12 (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) + (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y))) (check-union x y result))) t) (deftest union.13 (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) + (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y :test #'equal))) (check-union x y result))) t) (deftest union.14 (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) + (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y :test #'eql))) (check-union x y result))) t) (deftest union.15 (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) + (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y :test-not (complement #'equal)))) (check-union x y result))) t) (deftest union.16 (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) + (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check x y :test-not (complement #'eql)))) (check-union x y result))) t) (deftest union.17 (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) + (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+))) (check-union x y result))) t) (deftest union.18 (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) + (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+ :test #'equal))) (check-union x y result))) t) (deftest union.19 (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) + (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+ :test #'eql))) (check-union x y result))) t) (deftest union.20 (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) + (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+ - :test-not (complement #'equal)))) + :test-not (complement #'equal)))) (check-union x y result))) t) (deftest union.21 (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) + (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y #'1+ - :test-not (complement #'equal)))) + :test-not (complement #'equal)))) (check-union x y result))) t) (deftest union.22 (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) + (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y nil))) (check-union x y result))) t) (deftest union.23 (let ((x (copy-list '(1 2 3 4 5 6 7))) - (y (copy-list '(10 19 5 3 17 1001 2)))) + (y (copy-list '(10 19 5 3 17 1001 2)))) (let ((result (union-with-check-and-key x y '1+))) (check-union x y result))) t) @@ -171,41 +171,41 @@ (deftest union.25 (let ((x (shuffle '(1 4 6 10 45 101))) - (y (copy-list '(102 5 2 11 44 6)))) + (y (copy-list '(102 5 2 11 44 6)))) (let ((result (union-with-check x y - :test #'(lambda (a b) - (<= (abs (- a b)) 1))))) + :test #'(lambda (a b) + (<= (abs (- a b)) 1))))) (and (not (eqt result 'failed)) (sort - (sublis - '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) - (copy-list result)) - #'<)))) + (sublis + '((2 . 1) (5 . 4) (11 . 10) (45 . 44) (102 . 101)) + (copy-list result)) + #'<)))) (1 4 6 10 44 101)) ;;; Check that union uses eql, not equal or eq (deftest union.26 (let ((x 1000) - (y 1000)) + (y 1000)) (loop while (not (typep x 'bignum)) do (progn - (setf x (* x x)) - (setf y (* y y)))) + (setf x (* x x)) + (setf y (* y y)))) (notnot-mv (or (eqt x y) ;; if bignums are eq, the test is worthless (eql (length - (union-with-check - (list x) (list x))) - 1)))) + (union-with-check + (list x) (list x))) + 1)))) t) (deftest union.27 (union-with-check (list (copy-seq "aa")) - (list (copy-seq "aa"))) + (list (copy-seq "aa"))) ("aa" "aa")) ;; Check that union does not reverse the arguments to :test, :test-not @@ -217,8 +217,8 @@ (list 1 2 3) (list 4 5 6) :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))) + (when (< y x) (return-from fail 'fail)) + (eql x y))) #'<)) (1 2 3 4 5 6)) @@ -230,8 +230,8 @@ (list 4 5 6) #'identity :test #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (eql x y))) + (when (< y x) (return-from fail 'fail)) + (eql x y))) #'<)) (1 2 3 4 5 6)) @@ -243,8 +243,8 @@ (list 4 5 6) :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))) #'<)) (1 2 3 4 5 6)) @@ -256,8 +256,8 @@ (list 4 5 6) #'identity :test-not #'(lambda (x y) - (when (< y x) (return-from fail 'fail)) - (not (eql x y)))) + (when (< y x) (return-from fail 'fail)) + (not (eql x y)))) #'<)) (1 2 3 4 5 6)) @@ -275,7 +275,7 @@ (values (sort (union (progn (setf x (incf i)) (copy-list '(1 3 5))) - (progn (setf y (incf i)) (copy-list '(2 5 8)))) + (progn (setf y (incf i)) (copy-list '(2 5 8)))) #'<) i x y)) (1 2 3 5 8) @@ -286,9 +286,9 @@ (values (sort (union (progn (setf x (incf i)) (copy-list '(1 3 5))) - (progn (setf y (incf i)) (copy-list '(2 5 8))) - :test (progn (setf z (incf i)) #'eql) - :key (progn (setf w (incf i)) #'identity)) + (progn (setf y (incf i)) (copy-list '(2 5 8))) + :test (progn (setf z (incf i)) #'eql) + :key (progn (setf w (incf i)) #'identity)) #'<) i x y z w)) (1 2 3 5 8) @@ -300,9 +300,9 @@ (values (sort (union (progn (setf x (incf i)) (copy-list '(1 3 5))) - (progn (setf y (incf i)) (copy-list '(2 5 8))) - :key (progn (setf z (incf i)) #'identity) - :test (progn (setf w (incf i)) #'eql)) + (progn (setf y (incf i)) (copy-list '(2 5 8))) + :key (progn (setf z (incf i)) #'identity) + :test (progn (setf w (incf i)) #'eql)) #'<) i x y z w)) (1 2 3 5 8) @@ -312,55 +312,55 @@ (deftest union.allow-other-keys.1 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) :bad t - :allow-other-keys "yes") - #'<) + :allow-other-keys "yes") + #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.2 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t :also-bad t) - #'<) + :allow-other-keys t :also-bad t) + #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.3 (sort (union (list 1 2 3) (list 1 2 3) - :allow-other-keys t :also-bad t - :test #'(lambda (x y) (= x (+ y 100)))) - #'<) + :allow-other-keys t :also-bad t + :test #'(lambda (x y) (= x (+ y 100)))) + #'<) (1 1 2 2 3 3)) (deftest union.allow-other-keys.4 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t) - #'<) + :allow-other-keys t) + #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.5 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys nil) - #'<) + :allow-other-keys nil) + #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.6 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t - :allow-other-keys nil) - #'<) + :allow-other-keys t + :allow-other-keys nil) + #'<) (1 2 5 7 9 10 11 20)) (deftest union.allow-other-keys.7 (sort (union (list 7 9 1 5) (list 10 11 9 20 1 2) - :allow-other-keys t - :allow-other-keys nil - '#:x 1) - #'<) + :allow-other-keys t + :allow-other-keys nil + '#:x 1) + #'<) (1 2 5 7 9 10 11 20)) (deftest union.keywords.9 (sort (union (list 1 2 3) (list 1 2 3) - :test #'(lambda (x y) (= x (+ y 100))) - :test #'eql) - #'<) + :test #'(lambda (x y) (= x (+ y 100))) + :test #'eql) + #'<) (1 1 2 2 3 3)) (def-fold-test union.fold.1 (union '(a b c d e) '(d x y a w c))) diff --git a/ansi-tests/universe.lsp b/ansi-tests/universe.lsp index ad31507f..38a4d10f 100644 --- a/ansi-tests/universe.lsp +++ b/ansi-tests/universe.lsp @@ -41,19 +41,19 @@ (defparameter *condition-objects* (locally (declare (optimize safety)) - (loop for tp in *condition-types* append - (handler-case (list (make-condition tp)) - (error () nil))))) + (loop for tp in *condition-types* append + (handler-case (list (make-condition tp)) + (error () nil))))) (defparameter *standard-package-names* '("COMMON-LISP" "COMMON-LISP-USER" "KEYWORD")) (defparameter *package-objects* (locally (declare (optimize safety)) - (loop for pname in *standard-package-names* append - (handler-case (let ((pkg (find-package pname))) - (and pkg (list pkg))) - (error () nil))))) + (loop for pname in *standard-package-names* append + (handler-case (let ((pkg (find-package pname))) + (and pkg (list pkg))) + (error () nil))))) (defparameter *integers* (remove-duplicates @@ -75,39 +75,39 @@ (defparameter *floats* (append (loop for sym in '(pi - most-positive-short-float - least-positive-short-float - least-positive-normalized-short-float - most-positive-double-float - least-positive-double-float - least-positive-normalized-double-float - most-positive-long-float - least-positive-long-float - least-positive-normalized-long-float - most-positive-single-float - least-positive-single-float - least-positive-normalized-single-float - most-negative-short-float - least-negative-short-float - least-negative-normalized-short-float - most-negative-single-float - least-negative-single-float - least-negative-normalized-single-float - most-negative-double-float - least-negative-double-float - least-negative-normalized-double-float - most-negative-long-float - least-negative-long-float - least-negative-normalized-long-float - short-float-epsilon - short-float-negative-epsilon - single-float-epsilon - single-float-negative-epsilon - double-float-epsilon - double-float-negative-epsilon - long-float-epsilon - long-float-negative-epsilon) - when (boundp sym) collect (symbol-value sym)) + most-positive-short-float + least-positive-short-float + least-positive-normalized-short-float + most-positive-double-float + least-positive-double-float + least-positive-normalized-double-float + most-positive-long-float + least-positive-long-float + least-positive-normalized-long-float + most-positive-single-float + least-positive-single-float + least-positive-normalized-single-float + most-negative-short-float + least-negative-short-float + least-negative-normalized-short-float + most-negative-single-float + least-negative-single-float + least-negative-normalized-single-float + most-negative-double-float + least-negative-double-float + least-negative-normalized-double-float + most-negative-long-float + least-negative-long-float + least-negative-normalized-long-float + short-float-epsilon + short-float-negative-epsilon + single-float-epsilon + single-float-negative-epsilon + double-float-epsilon + double-float-negative-epsilon + long-float-epsilon + long-float-negative-epsilon) + when (boundp sym) collect (symbol-value sym)) (list 0.0 1.0 -1.0 313123.13 283143.231 -314781.9 1.31283d2 834.13812D-45 @@ -148,9 +148,9 @@ (defparameter *numbers* (append *integers* - *floats* - *ratios* - *complexes*)) + *floats* + *ratios* + *complexes*)) (defparameter *reals* (append *integers* *floats* *ratios*)) @@ -160,22 +160,22 @@ (declare (optimize safety)) (loop for name in namelist append - (handler-case - (list (read-from-string - (concatenate 'string "\#\\" name))) - (error () nil)))) + (handler-case + (list (read-from-string + (concatenate 'string "\#\\" name))) + (error () nil)))) (defparameter *characters* (remove-duplicates `(#\Newline #\Space ,@(try-to-read-chars "Rubout" - "Page" - "Tab" - "Backspace" - "Return" - "Linefeed" - "Null") + "Page" + "Tab" + "Backspace" + "Return" + "Linefeed" + "Null") #\a #\A #\0 #\9 #\. #\( #\) #\[ #\] ))) @@ -183,34 +183,34 @@ (defparameter *strings* (append (and (code-char 0) - (list - (make-string 1 :initial-element (code-char 0)) - (make-string 10 :initial-element (code-char 0)))) + (list + (make-string 1 :initial-element (code-char 0)) + (make-string 10 :initial-element (code-char 0)))) (list "" "A" "a" "0" "abcdef" "~!@#$%^&*()_+`1234567890-=<,>.?/:;\"'{[}]|\\ abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWYXZ" (make-string 100000 :initial-element #\g) (let ((s (make-string 256))) - (loop - for i from 0 to 255 - do (let ((c (code-char i))) - (when c - (setf (elt s i) c)))) - s) + (loop + for i from 0 to 255 + do (let ((c (code-char i))) + (when c + (setf (elt s i) c)))) + s) ;; Specialized strings (make-array 3 - :element-type 'character - :displaced-to (make-array 5 :element-type 'character - :initial-contents "abcde") - :displaced-index-offset 1) + :element-type 'character + :displaced-to (make-array 5 :element-type 'character + :initial-contents "abcde") + :displaced-index-offset 1) (make-array 10 :initial-element #\x - :fill-pointer 5 - :element-type 'character) + :fill-pointer 5 + :element-type 'character) (make-array 10 :initial-element #\x - :element-type 'base-char) + :element-type 'base-char) (make-array 3 :initial-element #\y - :adjustable t - :element-type 'base-char) + :adjustable t + :element-type 'base-char) ))) (defparameter *conses* @@ -239,18 +239,18 @@ `(,(intern "a" :cl-test) ,(intern "" :cl-test) ,@(and (code-char 0) - (list (intern (make-string 1 :initial-element (code-char 0)) :cl-test))) + (list (intern (make-string 1 :initial-element (code-char 0)) :cl-test))) ,@(and (code-char 0) - (let* ((s (make-string 10 :initial-element (code-char 0))) - (s2 (copy-seq s)) - (s3 (copy-seq s))) - (setf (subseq s 3 4) "a") - (setf (subseq s2 4 5) "a") - (setf (subseq s3 4 5) "a") - (setf (subseq s3 7 8) "b") - (list (intern s :cl-test) - (intern s2 :cl-test) - (intern s3 :cl-test)))) + (let* ((s (make-string 10 :initial-element (code-char 0))) + (s2 (copy-seq s)) + (s3 (copy-seq s))) + (setf (subseq s 3 4) "a") + (setf (subseq s2 4 5) "a") + (setf (subseq s3 4 5) "a") + (setf (subseq s3 7 8) "b") + (list (intern s :cl-test) + (intern s2 :cl-test) + (intern s3 :cl-test)))) )) (defparameter *cl-user-symbols* @@ -260,16 +260,16 @@ cl-user::lambda cl-user::*print-readably* cl-user::push)) - + (defparameter *symbols* (append *booleans* *keywords* *uninterned-symbols* - *cl-test-symbols* - *cl-user-symbols*)) + *cl-test-symbols* + *cl-user-symbols*)) (defparameter *array-dimensions* (loop - for i from 0 to 8 collect - (loop for j from 1 to i collect 2))) + for i from 0 to 8 collect + (loop for j from 1 to i collect 2))) (defparameter *default-array-target* (make-array '(300))) @@ -277,36 +277,36 @@ (append (list (make-array '10)) (mapcar #'make-array *array-dimensions*) - + ;; typed arrays (loop for tp in '(fixnum float bit character base-char - (signed-byte 8) (unsigned-byte 8)) - for element in '(18 16.0f0 0 #\x #\y 127 200) - append - (loop - for d in *array-dimensions* - collect (make-array d :element-type tp - :initial-element element))) + (signed-byte 8) (unsigned-byte 8)) + for element in '(18 16.0f0 0 #\x #\y 127 200) + append + (loop + for d in *array-dimensions* + collect (make-array d :element-type tp + :initial-element element))) ;; More typed arrays (loop for i from 1 to 64 - append - (list (make-array 10 :element-type `(unsigned-byte ,i) - :initial-element 1) - (make-array 10 :element-type `(signed-byte ,i) - :initial-element 0))) + append + (list (make-array 10 :element-type `(unsigned-byte ,i) + :initial-element 1) + (make-array 10 :element-type `(signed-byte ,i) + :initial-element 0))) ;; adjustable arrays (loop for d in *array-dimensions* - collect (make-array d :adjustable t)) + collect (make-array d :adjustable t)) ;; Displaced arrays (loop for d in *array-dimensions* for i from 1 collect (make-array d :displaced-to *default-array-target* - :displaced-index-offset i)) + :displaced-index-offset i)) (list #() @@ -314,52 +314,52 @@ #*00000 #*1010101010101101 (make-array 10 :element-type 'bit - :initial-contents '(0 1 1 0 1 1 1 1 0 1) - :fill-pointer 8) + :initial-contents '(0 1 1 0 1 1 1 1 0 1) + :fill-pointer 8) (make-array 5 :element-type 'bit - :displaced-to #*0111000110 - :displaced-index-offset 3) + :displaced-to #*0111000110 + :displaced-index-offset 3) (make-array 10 :element-type 'bit - :initial-contents '(1 1 0 0 1 1 1 0 1 1) - :adjustable t) + :initial-contents '(1 1 0 0 1 1 1 0 1 1) + :adjustable t) ) ;; Integer arrays (list (make-array '(10) :element-type '(integer 0 (256)) - :initial-contents '(8 9 10 11 12 1 2 3 4 5)) + :initial-contents '(8 9 10 11 12 1 2 3 4 5)) (make-array '(10) :element-type '(integer -128 (128)) - :initial-contents '(8 9 -10 11 -12 1 -2 -3 4 5)) + :initial-contents '(8 9 -10 11 -12 1 -2 -3 4 5)) (make-array '(6) :element-type '(integer 0 (#.(ash 1 16))) - :initial-contents '(5 9 100 1312 23432 87)) + :initial-contents '(5 9 100 1312 23432 87)) (make-array '(4) :element-type '(integer 0 (#.(ash 1 28))) - :initial-contents '(100000 231213 8123712 19)) + :initial-contents '(100000 231213 8123712 19)) (make-array '(4) :element-type '(integer 0 (#.(ash 1 32))) - :initial-contents '(#.(1- (ash 1 32)) 0 872312 10000000)) - + :initial-contents '(#.(1- (ash 1 32)) 0 872312 10000000)) + (make-array nil :element-type '(integer 0 (256)) - :initial-element 14) + :initial-element 14) (make-array '(2 2) :element-type '(integer 0 (256)) - :initial-contents '((34 98)(14 119))) + :initial-contents '((34 98)(14 119))) ) ;; Float arrays (list (make-array '(5) :element-type 'short-float - :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) + :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0)) (make-array '(5) :element-type 'single-float - :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) + :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0)) (make-array '(5) :element-type 'double-float - :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) + :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0)) (make-array '(5) :element-type 'long-float - :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) + :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0)) ) ;; The ever-popular NIL array (locally (declare (optimize safety)) - (handler-case - (list (make-array '(0) :element-type nil)) - (error () nil))) + (handler-case + (list (make-array '(0) :element-type nil)) + (error () nil))) ;; more kinds of arrays here later? )) @@ -377,38 +377,38 @@ (locally (declare (optimize safety)) (loop for form in '((make-pathname :name "foo") - (make-pathname :name "FOO" :case :common) - (make-pathname :name "bar") - (make-pathname :name "foo" :type "txt") - (make-pathname :name "bar" :type "txt") - (make-pathname :name "XYZ" :type "TXT" :case :common) - (make-pathname :name nil) - (make-pathname :name :wild) - (make-pathname :name nil :type "txt") - (make-pathname :name :wild :type "txt") - (make-pathname :name :wild :type "TXT" :case :common) - (make-pathname :name :wild :type "abc" :case :common) - (make-pathname :directory :wild) - (make-pathname :type :wild) - (make-pathname :version :wild) - (make-pathname :version :newest)) - append (ignore-errors (eval `(list ,form)))))) + (make-pathname :name "FOO" :case :common) + (make-pathname :name "bar") + (make-pathname :name "foo" :type "txt") + (make-pathname :name "bar" :type "txt") + (make-pathname :name "XYZ" :type "TXT" :case :common) + (make-pathname :name nil) + (make-pathname :name :wild) + (make-pathname :name nil :type "txt") + (make-pathname :name :wild :type "txt") + (make-pathname :name :wild :type "TXT" :case :common) + (make-pathname :name :wild :type "abc" :case :common) + (make-pathname :directory :wild) + (make-pathname :type :wild) + (make-pathname :version :wild) + (make-pathname :version :newest)) + append (ignore-errors (eval `(list ,form)))))) (eval-when (:compile-toplevel :load-toplevel :execute) (locally (declare (optimize safety)) (ignore-errors (setf (logical-pathname-translations "CLTESTROOT") - `(("**;*.*.*" ,(make-pathname :directory '(:absolute :wild-inferiors) - :name :wild :type :wild))))) + `(("**;*.*.*" ,(make-pathname :directory '(:absolute :wild-inferiors) + :name :wild :type :wild))))) (ignore-errors (setf (logical-pathname-translations "CLTEST") - `(("**;*.*.*" ,(make-pathname - :directory (append - (pathname-directory - (truename (make-pathname))) - '(:wild-inferiors)) - :name :wild :type :wild))))) + `(("**;*.*.*" ,(make-pathname + :directory (append + (pathname-directory + (truename (make-pathname))) + '(:wild-inferiors)) + :name :wild :type :wild))))) )) (defparameter *logical-pathnames* @@ -433,7 +433,7 @@ (defparameter *readtables* (list *readtable* - (copy-readtable))) + (copy-readtable))) (defstruct foo-structure x y z) @@ -462,20 +462,20 @@ (defparameter *functions* (list #'cons #'car #'append #'values - (macro-function 'cond) - #'meaningless-user-function-for-universe - #'meaningless-user-generic-function-for-universe - #'(lambda (x) x) - (compile nil '(lambda (x) x)))) + (macro-function 'cond) + #'meaningless-user-function-for-universe + #'meaningless-user-generic-function-for-universe + #'(lambda (x) x) + (compile nil '(lambda (x) x)))) (defparameter *methods* (list #+(or (not :gcl) :ansi-cl ) (find-method #'meaningless-user-generic-function-for-universe nil - (mapcar #'find-class '(integer integer integer))) + (mapcar #'find-class '(integer integer integer))) ;; Add more methods here )) - + (defparameter *random-states* (list (make-random-state))) @@ -506,23 +506,23 @@ (remove-duplicates (append (mapcar #'first - (list *symbols* - *numbers* - *characters* - (list (copy-seq (first *strings*))) - *conses* - *condition-objects* - *package-objects* - *arrays* - *hash-tables* - *pathnames* - *logical-pathnames* - *streams* - *readtables* - *structures* - *functions* - *random-states* - *methods*)) + (list *symbols* + *numbers* + *characters* + (list (copy-seq (first *strings*))) + *conses* + *condition-objects* + *package-objects* + *arrays* + *hash-tables* + *pathnames* + *logical-pathnames* + *streams* + *readtables* + *structures* + *functions* + *random-states* + *methods*)) '(;;; Others to fill in gaps 1.2s0 1.3f0 1.5d0 1.8l0 3/5 10000000000000000000000)))) @@ -531,4 +531,4 @@ (defparameter *built-in-classes* (remove-if-not #'(lambda (x) (typep x 'built-in-class)) - *classes*)) + *classes*)) diff --git a/ansi-tests/unless.lsp b/ansi-tests/unless.lsp index d005c9aa..c0ea3e45 100644 --- a/ansi-tests/unless.lsp +++ b/ansi-tests/unless.lsp @@ -86,12 +86,12 @@ (deftest unless.error.2 (signals-error (funcall (macro-function 'unless) - '(unless t)) - program-error) + '(unless t)) + program-error) t) (deftest unless.error.3 (signals-error (funcall (macro-function 'unless) - '(unless t) nil nil) - program-error) + '(unless t) nil nil) + program-error) t) diff --git a/ansi-tests/unread-char.lsp b/ansi-tests/unread-char.lsp index a98b8281..8cacd0dc 100644 --- a/ansi-tests/unread-char.lsp +++ b/ansi-tests/unread-char.lsp @@ -63,7 +63,7 @@ (with-input-from-string (is "abc") (let ((*terminal-io* (make-two-way-stream - is (make-string-output-stream)))) + is (make-string-output-stream)))) (values (read-char t) (unread-char #\a t) diff --git a/ansi-tests/unuse-package.lsp b/ansi-tests/unuse-package.lsp index bdc2a5fa..30fdf86c 100644 --- a/ansi-tests/unuse-package.lsp +++ b/ansi-tests/unuse-package.lsp @@ -17,19 +17,19 @@ (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G"))) - (i 0) x y) + (ph (make-package "H" :use '("G"))) + (i 0) x y) (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (unuse-package (progn (setf x (incf i)) pg) - (progn (setf y (incf i)) ph)) - (eql i 2) (eql x 1) (eql y 2) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package (progn (setf x (incf i)) pg) + (progn (setf y (incf i)) ph)) + (eql i 2) (eql x 1) (eql y 2) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) t) (deftest unuse-package.2 @@ -37,33 +37,33 @@ (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) + (ph (make-package "H" :use '("G")))) (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (unuse-package "G" ph) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) - t) + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package "G" ph) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) + t) (deftest unuse-package.3 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) + (ph (make-package "H" :use '("G")))) (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (unuse-package :|G| ph) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package :|G| ph) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) t) (deftest unuse-package.4 @@ -71,16 +71,16 @@ (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) + (ph (make-package "H" :use '("G")))) (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (ignore-errors (unuse-package #\G ph)) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (ignore-errors (unuse-package #\G ph)) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) t) (deftest unuse-package.5 @@ -88,33 +88,33 @@ (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) + (ph (make-package "H" :use '("G")))) (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (unuse-package (list pg) ph) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) - t) + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package (list pg) ph) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) + t) (deftest unuse-package.6 (progn (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) + (ph (make-package "H" :use '("G")))) (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (unuse-package (list "G") ph) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package (list "G") ph) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) t) (deftest unuse-package.7 @@ -122,16 +122,16 @@ (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) + (ph (make-package "H" :use '("G")))) (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (unuse-package (list :|G|) ph) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (unuse-package (list :|G|) ph) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) t) (deftest unuse-package.8 @@ -139,16 +139,16 @@ (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use '("G")))) + (ph (make-package "H" :use '("G")))) (prog1 - (and - (equal (package-use-list ph) (list pg)) - (equal (package-used-by-list pg) (list ph)) - (ignore-errors (unuse-package (list #\G) ph)) - (equal (package-use-list ph) nil) - (null (package-used-by-list pg))) - (safely-delete-package "H") - (safely-delete-package "G")))) + (and + (equal (package-use-list ph) (list pg)) + (equal (package-used-by-list pg) (list ph)) + (ignore-errors (unuse-package (list #\G) ph)) + (equal (package-use-list ph) nil) + (null (package-used-by-list pg))) + (safely-delete-package "H") + (safely-delete-package "G")))) t) ;; Now test with multiple packages @@ -158,58 +158,58 @@ (dolist (p '("H1" "H2" "G1" "G2" "G3")) (safely-delete-package p)) (let* ((pg1 (make-package "G1" :use nil)) - (pg2 (make-package "G2" :use nil)) - (pg3 (make-package "G3" :use nil)) - (ph1 (make-package "H1" :use (list pg1 pg2 pg3))) - (ph2 (make-package "H2" :use (list pg1 pg2 pg3)))) + (pg2 (make-package "G2" :use nil)) + (pg3 (make-package "G3" :use nil)) + (ph1 (make-package "H1" :use (list pg1 pg2 pg3))) + (ph2 (make-package "H2" :use (list pg1 pg2 pg3)))) (let ((pubg1 (sort-package-list (package-used-by-list pg1))) - (pubg2 (sort-package-list (package-used-by-list pg2))) - (pubg3 (sort-package-list (package-used-by-list pg3))) - (puh1 (sort-package-list (package-use-list ph1))) - (puh2 (sort-package-list (package-use-list ph2)))) - (prog1 - (and - (= (length (remove-duplicates (list pg1 pg2 pg3 ph1 ph2))) - 5) - (equal (list ph1 ph2) pubg1) - (equal (list ph1 ph2) pubg2) - (equal (list ph1 ph2) pubg3) - (equal (list pg1 pg2 pg3) puh1) - (equal (list pg1 pg2 pg3) puh2) - (unuse-package (list pg1 pg3) ph1) - (equal (package-use-list ph1) (list pg2)) - (equal (package-used-by-list pg1) (list ph2)) - (equal (package-used-by-list pg3) (list ph2)) - (equal (sort-package-list (package-use-list ph2)) - (list pg1 pg2 pg3)) - (equal (sort-package-list (package-used-by-list pg2)) - (list ph1 ph2)) - t) - (dolist (p '("H1" "H2" "G1" "G2" "G3")) - (safely-delete-package p)))))) + (pubg2 (sort-package-list (package-used-by-list pg2))) + (pubg3 (sort-package-list (package-used-by-list pg3))) + (puh1 (sort-package-list (package-use-list ph1))) + (puh2 (sort-package-list (package-use-list ph2)))) + (prog1 + (and + (= (length (remove-duplicates (list pg1 pg2 pg3 ph1 ph2))) + 5) + (equal (list ph1 ph2) pubg1) + (equal (list ph1 ph2) pubg2) + (equal (list ph1 ph2) pubg3) + (equal (list pg1 pg2 pg3) puh1) + (equal (list pg1 pg2 pg3) puh2) + (unuse-package (list pg1 pg3) ph1) + (equal (package-use-list ph1) (list pg2)) + (equal (package-used-by-list pg1) (list ph2)) + (equal (package-used-by-list pg3) (list ph2)) + (equal (sort-package-list (package-use-list ph2)) + (list pg1 pg2 pg3)) + (equal (sort-package-list (package-used-by-list pg2)) + (list ph1 ph2)) + t) + (dolist (p '("H1" "H2" "G1" "G2" "G3")) + (safely-delete-package p)))))) t) ;;; Specialized sequences (defmacro def-unuse-package-test (test-name &key - (user "H") - (used "G")) + (user "H") + (used "G")) `(deftest ,test-name (let ((user-name ,user) - (used-name ,used)) + (used-name ,used)) (safely-delete-package user-name) (safely-delete-package used-name) (let* ((pused (make-package used-name :use nil)) - (puser (make-package user-name :use (list used-name)))) - (prog1 - (and - (equal (package-use-list puser) (list pused)) - (equal (package-used-by-list pused) (list puser)) - (unuse-package (list used-name) user-name) - (equal (package-use-list puser) nil) - (null (package-used-by-list pused))) - (safely-delete-package user-name) - (safely-delete-package used-name)))) + (puser (make-package user-name :use (list used-name)))) + (prog1 + (and + (equal (package-use-list puser) (list pused)) + (equal (package-used-by-list pused) (list puser)) + (unuse-package (list used-name) user-name) + (equal (package-use-list puser) nil) + (null (package-used-by-list pused))) + (safely-delete-package user-name) + (safely-delete-package used-name)))) t)) ;;; Specialized user package designator @@ -219,36 +219,36 @@ (def-unuse-package-test unuse-package.11 :user (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) + :fill-pointer 5 :element-type 'base-char)) (def-unuse-package-test unuse-package.12 :user (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) + :fill-pointer 5 :element-type 'character)) (def-unuse-package-test unuse-package.13 :user (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) + :adjustable t :element-type 'base-char)) (def-unuse-package-test unuse-package.14 :user (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) + :adjustable t :element-type 'character)) (def-unuse-package-test unuse-package.15 :user (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) (def-unuse-package-test unuse-package.16 :user (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + :displaced-to name0 + :displaced-index-offset 5))) ;;; Specialed used package designator @@ -257,36 +257,36 @@ (def-unuse-package-test unuse-package.18 :used (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) + :fill-pointer 5 :element-type 'base-char)) (def-unuse-package-test unuse-package.19 :used (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) + :fill-pointer 5 :element-type 'character)) (def-unuse-package-test unuse-package.20 :used (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) + :adjustable t :element-type 'base-char)) (def-unuse-package-test unuse-package.21 :used (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) + :adjustable t :element-type 'character)) (def-unuse-package-test unuse-package.22 :used (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) (def-unuse-package-test unuse-package.23 :used (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + :displaced-to name0 + :displaced-index-offset 5))) ;;; Error tests diff --git a/ansi-tests/unwind-protect.lsp b/ansi-tests/unwind-protect.lsp index 43df795f..79abdf4f 100644 --- a/ansi-tests/unwind-protect.lsp +++ b/ansi-tests/unwind-protect.lsp @@ -8,7 +8,7 @@ (deftest unwind-protect.1 (let ((x nil)) (unwind-protect - (push 1 x) + (push 1 x) (incf (car x)))) (2)) @@ -16,16 +16,16 @@ (let ((x nil)) (block foo (unwind-protect - (progn (push 1 x) (return-from foo x)) - (incf (car x))))) + (progn (push 1 x) (return-from foo x)) + (incf (car x))))) (2)) (deftest unwind-protect.3 (let ((x nil)) (tagbody (unwind-protect - (progn (push 1 x) (go done)) - (incf (car x))) + (progn (push 1 x) (go done)) + (incf (car x))) done) x) (2)) @@ -34,16 +34,16 @@ (let ((x nil)) (catch 'done (unwind-protect - (progn (push 1 x) (throw 'done x)) - (incf (car x))))) + (progn (push 1 x) (throw 'done x)) + (incf (car x))))) (2)) (deftest unwind-protect.5 (let ((x nil)) (ignore-errors (unwind-protect - (progn (push 1 x) (error "Boo!")) - (incf (car x)))) + (progn (push 1 x) (error "Boo!")) + (incf (car x)))) x) (2)) @@ -51,8 +51,8 @@ (let ((x nil)) (block done (flet ((%f () (return-from done nil))) - (unwind-protect (%f) - (push 'a x)))) + (unwind-protect (%f) + (push 'a x)))) x) (a)) @@ -60,10 +60,10 @@ (let ((x nil)) (block done (flet ((%f () (return-from done nil))) - (unwind-protect - (unwind-protect (%f) - (push 'b x)) - (push 'a x)))) + (unwind-protect + (unwind-protect (%f) + (push 'b x)) + (push 'a x)))) x) (a b)) @@ -71,12 +71,12 @@ (let ((x nil)) (block done (unwind-protect - (flet ((%f () (return-from done nil))) - (unwind-protect - (unwind-protect (%f) - (push 'b x)) - (push 'a x))) - (push 'c x))) + (flet ((%f () (return-from done nil))) + (unwind-protect + (unwind-protect (%f) + (push 'b x)) + (push 'a x))) + (push 'c x))) x) (c a b)) @@ -84,8 +84,8 @@ (let ((x nil)) (handler-case (flet ((%f () (error 'type-error :datum 'foo :expected-type nil))) - (unwind-protect (handler-case (%f)) - (push 'a x))) + (unwind-protect (handler-case (%f)) + (push 'a x))) (type-error () x))) (a)) @@ -94,7 +94,7 @@ (block done (tagbody (unwind-protect - 'foo + 'foo (go 10) 10 (return-from done 'bad)) @@ -108,8 +108,8 @@ (values (block nil (unwind-protect (return 'a) - (setf y 'c) - (setf x 'b))) + (setf y 'c) + (setf x 'b))) x y)) a b c) diff --git a/ansi-tests/update-instance-for-different-class.lsp b/ansi-tests/update-instance-for-different-class.lsp index 4416c4b3..c8d4773d 100644 --- a/ansi-tests/update-instance-for-different-class.lsp +++ b/ansi-tests/update-instance-for-different-class.lsp @@ -19,18 +19,18 @@ (assert (eq *uifdc-01-obj* to-obj)) (if (slot-boundp from-obj 'a) (setf (slot-value to-obj 'b) - (slot-value from-obj 'a)) + (slot-value from-obj 'a)) (slot-makunbound to-obj 'b)) (if (slot-boundp from-obj 'b) (setf (slot-value to-obj 'a) - (slot-value from-obj 'b)) + (slot-value from-obj 'b)) (slot-makunbound to-obj 'a)) to-obj) (deftest update-instance-for-different-class.1 (let* ((obj (make-instance 'uifdc-class-01a)) - (new-class (find-class 'uifdc-class-01b)) - (*uifdc-01-obj* obj)) + (new-class (find-class 'uifdc-class-01b)) + (*uifdc-01-obj* obj)) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) @@ -42,8 +42,8 @@ (deftest update-instance-for-different-class.2 (let* ((obj (make-instance 'uifdc-class-01a :a 1)) - (new-class (find-class 'uifdc-class-01b)) - (*uifdc-01-obj* obj)) + (new-class (find-class 'uifdc-class-01b)) + (*uifdc-01-obj* obj)) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) @@ -57,8 +57,8 @@ (deftest update-instance-for-different-class.3 (let* ((obj (make-instance 'uifdc-class-01a :b 1)) - (new-class (find-class 'uifdc-class-01b)) - (*uifdc-01-obj* obj)) + (new-class (find-class 'uifdc-class-01b)) + (*uifdc-01-obj* obj)) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) @@ -72,8 +72,8 @@ (deftest update-instance-for-different-class.4 (let* ((obj (make-instance 'uifdc-class-01a :a 1 :b 2)) - (new-class (find-class 'uifdc-class-01b)) - (*uifdc-01-obj* obj)) + (new-class (find-class 'uifdc-class-01b)) + (*uifdc-01-obj* obj)) (values (map-slot-boundp* obj '(a b)) (eqt obj (change-class obj new-class)) @@ -90,7 +90,7 @@ ;;; after method (defclass uifdc-class-02 () ((a :initform 'x :initarg :a) - (b :initarg :b))) + (b :initarg :b))) (defmethod update-instance-for-different-class :after ((from-obj uifdc-class-01a) @@ -102,7 +102,7 @@ (deftest update-instance-for-different-class.5 (let* ((obj (make-instance 'uifdc-class-01a)) - (class (find-class 'uifdc-class-02))) + (class (find-class 'uifdc-class-02))) (values (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) @@ -111,7 +111,7 @@ (deftest update-instance-for-different-class.6 (let* ((obj (make-instance 'uifdc-class-01a :a 1)) - (class (find-class 'uifdc-class-02))) + (class (find-class 'uifdc-class-02))) (values (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) @@ -120,7 +120,7 @@ (deftest update-instance-for-different-class.7 (let* ((obj (make-instance 'uifdc-class-01a :b 17)) - (class (find-class 'uifdc-class-02))) + (class (find-class 'uifdc-class-02))) (values (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) @@ -130,7 +130,7 @@ (deftest update-instance-for-different-class.8 (let* ((obj (make-instance 'uifdc-class-01a :b 17 :a 4)) - (class (find-class 'uifdc-class-02))) + (class (find-class 'uifdc-class-02))) (values (eqt obj (change-class obj class)) (map-slot-boundp* obj '(a b)) diff --git a/ansi-tests/upgraded-array-element-type.lsp b/ansi-tests/upgraded-array-element-type.lsp index 72a319d3..ad8f3901 100644 --- a/ansi-tests/upgraded-array-element-type.lsp +++ b/ansi-tests/upgraded-array-element-type.lsp @@ -8,19 +8,19 @@ (deftest upgraded-array-element-type.1 (let ((upgraded-bit (upgraded-array-element-type 'bit))) (and (empirical-subtypep 'bit upgraded-bit) - (empirical-subtypep upgraded-bit 'bit))) + (empirical-subtypep upgraded-bit 'bit))) t) (deftest upgraded-array-element-type.2 (let ((upgraded-base-char (upgraded-array-element-type 'base-char))) (and (empirical-subtypep 'base-char upgraded-base-char) - (empirical-subtypep upgraded-base-char 'base-char))) + (empirical-subtypep upgraded-base-char 'base-char))) t) (deftest upgraded-array-element-type.3 (let ((upgraded-character (upgraded-array-element-type 'character))) (and (empirical-subtypep 'character upgraded-character) - (empirical-subtypep upgraded-character 'character))) + (empirical-subtypep upgraded-character 'character))) t) (defparameter *upgraded-array-types-to-check* @@ -32,12 +32,12 @@ ,@(loop for i from 0 to 32 collect `(eql ,(1- (ash 1 i)))) (eql -1) ,@(loop for i from 0 to 32 - collect `(integer 0 (,(ash 1 i)))) + collect `(integer 0 (,(ash 1 i)))) symbol ,@(loop for i from 0 to 32 - collect `(integer ,(- (ash 1 i)) (,(ash 1 i)))) + collect `(integer ,(- (ash 1 i)) (,(ash 1 i)))) (integer -10000000000000000000000000000000000 - 10000000000000000000000000000000000) + 10000000000000000000000000000000000) float short-float single-float @@ -54,9 +54,9 @@ (deftest upgraded-array-element-type.4 (loop for type in *upgraded-array-types-to-check* - for upgraded-type = (upgraded-array-element-type type) - unless (empirical-subtypep type upgraded-type) - collect (list type upgraded-type)) + for upgraded-type = (upgraded-array-element-type type) + unless (empirical-subtypep type upgraded-type) + collect (list type upgraded-type)) nil) ;; Include an environment (NIL, denoting the default null lexical @@ -64,32 +64,32 @@ (deftest upgraded-array-element-type.5 (loop for type in *upgraded-array-types-to-check* - for upgraded-type = (upgraded-array-element-type type nil) - unless (empirical-subtypep type upgraded-type) - collect (list type upgraded-type)) + for upgraded-type = (upgraded-array-element-type type nil) + unless (empirical-subtypep type upgraded-type) + collect (list type upgraded-type)) nil) (deftest upgraded-array-element-type.6 (macrolet ((%foo (&environment env) - (empirical-subtypep - 'bit - (upgraded-array-element-type 'bit env)))) + (empirical-subtypep + 'bit + (upgraded-array-element-type 'bit env)))) (%foo)) t) (deftest upgraded-array-element-type.7 (let ((upgraded-types (mapcar #'upgraded-array-element-type - *upgraded-array-types-to-check*))) + *upgraded-array-types-to-check*))) (loop for type in *upgraded-array-types-to-check* - for upgraded-type in upgraded-types - append - (loop for type2 in *upgraded-array-types-to-check* - for upgraded-type2 in upgraded-types - when (and (subtypep type type2) - (equal (subtypep* upgraded-type upgraded-type) - '(nil t))) - collect (list type type2)))) + for upgraded-type in upgraded-types + append + (loop for type2 in *upgraded-array-types-to-check* + for upgraded-type2 in upgraded-types + when (and (subtypep type type2) + (equal (subtypep* upgraded-type upgraded-type) + '(nil t))) + collect (list type type2)))) nil) ;;; Tests that if Tx is a subtype of Ty, then UAET(Tx) is a subtype @@ -97,15 +97,15 @@ (deftest upgraded-array-element-type.8 (let ((upgraded-types (mapcar #'upgraded-array-element-type - *upgraded-array-types-to-check*))) + *upgraded-array-types-to-check*))) (loop for type1 in *upgraded-array-types-to-check* - for uaet1 in upgraded-types - append - (loop for type2 in *upgraded-array-types-to-check* - for uaet2 in upgraded-types - when (and (subtypep type1 type2) - (not (empirical-subtypep uaet1 uaet2))) - collect (list type1 type2)))) + for uaet1 in upgraded-types + append + (loop for type2 in *upgraded-array-types-to-check* + for uaet2 in upgraded-types + when (and (subtypep type1 type2) + (not (empirical-subtypep uaet1 uaet2))) + collect (list type1 type2)))) nil) ;;; Tests of upgrading NIL (it should be type equivalent to NIL) @@ -114,7 +114,7 @@ (let ((uaet-nil (upgraded-array-element-type nil))) (check-predicate (typef `(not ,uaet-nil)))) nil) - + ;;; Error tests (deftest upgraded-array-element-type.error.1 diff --git a/ansi-tests/upgraded-complex-part-type.lsp b/ansi-tests/upgraded-complex-part-type.lsp index 6372885b..b39fc328 100644 --- a/ansi-tests/upgraded-complex-part-type.lsp +++ b/ansi-tests/upgraded-complex-part-type.lsp @@ -10,16 +10,16 @@ (defmacro def-ucpt-test (name types) `(deftest ,name (loop for type in (remove-duplicates ,types) - for upgraded-type = (upgraded-complex-part-type type) - for result = (append (check-all-subtypep type upgraded-type) - (check-all-subtypep type 'real) - (check-all-subtypep `(complex ,type) 'complex) - (check-all-subtypep `(complex ,upgraded-type) - 'complex) - (check-all-subtypep `(complex ,type) - `(complex ,upgraded-type))) - when result - collect result) + for upgraded-type = (upgraded-complex-part-type type) + for result = (append (check-all-subtypep type upgraded-type) + (check-all-subtypep type 'real) + (check-all-subtypep `(complex ,type) 'complex) + (check-all-subtypep `(complex ,upgraded-type) + 'complex) + (check-all-subtypep `(complex ,type) + `(complex ,upgraded-type))) + when result + collect result) nil)) (def-ucpt-test upgraded-complex-part-type.1 @@ -40,60 +40,60 @@ (def-ucpt-test upgraded-complex-part-type.6 (loop for i = 1 then (* i 2) - repeat 100 - collect (class-of i))) + repeat 100 + collect (class-of i))) ;;; environment argument (deftest upgraded-complex-part-type.7 (loop for type in '(real integer rational float short-float - single-float double-float long-float fixnum - bignum bit unsigned-byte signed-byte) - for ut1 = (upgraded-complex-part-type type) - for ut2 = (upgraded-complex-part-type type nil) - unless (equal ut1 ut2) - collect (list type ut1 ut2)) + single-float double-float long-float fixnum + bignum bit unsigned-byte signed-byte) + for ut1 = (upgraded-complex-part-type type) + for ut2 = (upgraded-complex-part-type type nil) + unless (equal ut1 ut2) + collect (list type ut1 ut2)) nil) (deftest upgraded-complex-part-type.8 (loop for type in '(real integer rational float short-float - single-float double-float long-float fixnum - bignum bit unsigned-byte signed-byte) - for ut1 = (upgraded-complex-part-type type) - for ut2 = (eval `(macrolet ((%m (&environment env) - (list 'quote - (upgraded-complex-part-type ',type env)))) - (%m))) - unless (equal ut1 ut2) - collect (list type ut1 ut2)) + single-float double-float long-float fixnum + bignum bit unsigned-byte signed-byte) + for ut1 = (upgraded-complex-part-type type) + for ut2 = (eval `(macrolet ((%m (&environment env) + (list 'quote + (upgraded-complex-part-type ',type env)))) + (%m))) + unless (equal ut1 ut2) + collect (list type ut1 ut2)) nil) ;;; Subtype constraint (deftest upgraded-complex-part-type.9 (let* ((types `(nil integer fixnum bignum float - short-float single-float double-float long-float - rational #-sbcl ratio real - ,@(remove-duplicates - (mapcar #'class-of '(0.0s0 0.0f0 0.0d0 0.0l0 0 100000000000000000))) - ,@(mapcar #'(lambda (x) `(eql ,x)) - (remove-duplicates - '(0.0s0 0.0f0 0.0d0 0.0l0 0 - 1.0s0 1.0f0 1.0d0 1.0l0 1 - 100000000000000000))))) - (utypes (mapcar #'upgraded-complex-part-type types))) + short-float single-float double-float long-float + rational #-sbcl ratio real + ,@(remove-duplicates + (mapcar #'class-of '(0.0s0 0.0f0 0.0d0 0.0l0 0 100000000000000000))) + ,@(mapcar #'(lambda (x) `(eql ,x)) + (remove-duplicates + '(0.0s0 0.0f0 0.0d0 0.0l0 0 + 1.0s0 1.0f0 1.0d0 1.0l0 1 + 100000000000000000))))) + (utypes (mapcar #'upgraded-complex-part-type types))) (loop for sublist on types - for usublist on utypes - for tp1 = (car sublist) - for utp1 = (car usublist) - nconc (loop for tp2 in (cdr sublist) - for utp2 in (cdr usublist) - nconc - (and (subtypep tp1 tp2) - (let ((result (check-all-subtypep utp1 utp2))) - (and result - (list (list tp1 tp2 result)))))))) - nil) + for usublist on utypes + for tp1 = (car sublist) + for utp1 = (car usublist) + nconc (loop for tp2 in (cdr sublist) + for utp2 in (cdr usublist) + nconc + (and (subtypep tp1 tp2) + (let ((result (check-all-subtypep utp1 utp2))) + (and result + (list (list tp1 tp2 result)))))))) + nil) ;;; Error tests diff --git a/ansi-tests/use-package.lsp b/ansi-tests/use-package.lsp index 544c529b..23a8f9a2 100644 --- a/ansi-tests/use-package.lsp +++ b/ansi-tests/use-package.lsp @@ -17,9 +17,9 @@ (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg)) - (i 0) x y) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg)) + (i 0) x y) (and (eqt (export sym1 pg) t) (null (package-used-by-list pg)) @@ -27,14 +27,14 @@ (null (package-use-list pg)) (null (package-use-list ph)) (eqt (use-package (progn (setf x (incf i)) pg) - (progn (setf y (incf i)) ph)) - t) ;; "H" will use "G" + (progn (setf y (incf i)) ph)) + t) ;; "H" will use "G" (eql i 2) (eql x 1) (eql y 2) (multiple-value-bind (sym2 access) - (find-symbol "FOO" ph) - (and - (eqt access :inherited) - (eqt sym1 sym2))) + (find-symbol "FOO" ph) + (and + (eqt access :inherited) + (eqt sym1 sym2))) (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (null (package-use-list pg)) @@ -48,8 +48,8 @@ (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg))) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) (and (eqt (export sym1 pg) t) (null (package-used-by-list pg)) @@ -58,10 +58,10 @@ (null (package-use-list ph)) (eqt (use-package "G" "H") t) ;; "H" will use "G" (multiple-value-bind (sym2 access) - (find-symbol "FOO" ph) - (and - (eqt access :inherited) - (eqt sym1 sym2))) + (find-symbol "FOO" ph) + (and + (eqt access :inherited) + (eqt sym1 sym2))) (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (null (package-use-list pg)) @@ -75,8 +75,8 @@ (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg))) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) (and (eqt (export sym1 pg) t) (null (package-used-by-list pg)) @@ -85,10 +85,10 @@ (null (package-use-list ph)) (eqt (use-package '#:|G| '#:|H|) t) ;; "H" will use "G" (multiple-value-bind (sym2 access) - (find-symbol "FOO" ph) - (and - (eqt access :inherited) - (eqt sym1 sym2))) + (find-symbol "FOO" ph) + (and + (eqt access :inherited) + (eqt sym1 sym2))) (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (null (package-use-list pg)) @@ -102,8 +102,8 @@ (safely-delete-package "H") (safely-delete-package "G") (let* ((pg (make-package "G" :use nil)) - (ph (make-package "H" :use nil)) - (sym1 (intern "FOO" pg))) + (ph (make-package "H" :use nil)) + (sym1 (intern "FOO" pg))) (and (eqt (export sym1 pg) t) (null (package-used-by-list pg)) @@ -111,12 +111,12 @@ (null (package-use-list pg)) (null (package-use-list ph)) (eqt (ignore-errors (use-package #\G #\H)) - t) ;; "H" will use "G" + t) ;; "H" will use "G" (multiple-value-bind (sym2 access) - (find-symbol "FOO" ph) - (and - (eqt access :inherited) - (eqt sym1 sym2))) + (find-symbol "FOO" ph) + (and + (eqt access :inherited) + (eqt sym1 sym2))) (equal (package-use-list ph) (list pg)) (equal (package-used-by-list pg) (list ph)) (null (package-use-list pg)) @@ -129,7 +129,7 @@ (deftest use-package.5 (let ((pkgs '("H" "G1" "G2" "G3")) - (vars '("FOO1" "FOO2" "FOO3"))) + (vars '("FOO1" "FOO2" "FOO3"))) (dolist (p pkgs) (safely-delete-package p) (make-package p :use nil)) @@ -137,22 +137,22 @@ (every (complement #'package-use-list) pkgs) (every (complement #'package-used-by-list) pkgs) (every #'(lambda (v p) - (export (intern v p) p)) - vars (cdr pkgs)) + (export (intern v p) p)) + vars (cdr pkgs)) (progn (dolist (p (cdr pkgs)) (intern "MINE" p)) (eqt (use-package (cdr pkgs) (car pkgs)) t)) (every #'(lambda (v p) - (eqt (find-symbol v p) - (find-symbol v (car pkgs)))) - vars (cdr pkgs)) + (eqt (find-symbol v p) + (find-symbol v (car pkgs)))) + vars (cdr pkgs)) (null (find-symbol "MINE" (car pkgs))) (every #'(lambda (p) - (equal (package-used-by-list p) - (list (find-package (car pkgs))))) - (cdr pkgs)) + (equal (package-used-by-list p) + (list (find-package (car pkgs))))) + (cdr pkgs)) (equal (sort-package-list (package-use-list (car pkgs))) - (mapcar #'find-package (cdr pkgs))) + (mapcar #'find-package (cdr pkgs))) (every (complement #'package-use-list) (cdr pkgs)) (null (package-used-by-list (car pkgs))))) t) @@ -164,49 +164,49 @@ (safely-delete-package "H") (safely-delete-package "G") (let ((pg (make-package "G")) - (ph (make-package "H")) - sym1 sym2 sym3 sym4 - a1 a2 a3 a4) + (ph (make-package "H")) + sym1 sym2 sym3 sym4 + a1 a2 a3 a4) (prog1 - (and - (export (intern "X" pg) pg) - (export (intern "Y" ph) ph) - (use-package pg ph) - (use-package ph pg) - (progn - (multiple-value-setq - (sym1 a1) (find-symbol "X" pg)) - (multiple-value-setq - (sym2 a2) (find-symbol "Y" ph)) - (multiple-value-setq - (sym3 a3) (find-symbol "Y" pg)) - (multiple-value-setq - (sym4 a4) (find-symbol "X" ph)) - (and - (eqt a1 :external) - (eqt a2 :external) - (eqt a3 :inherited) - (eqt a4 :inherited) - (eqt sym1 sym4) - (eqt sym2 sym3) - (eqt (symbol-package sym1) pg) - (eqt (symbol-package sym2) ph) - (unuse-package pg ph) - (unuse-package ph pg)))) - (safely-delete-package pg) - (safely-delete-package ph)))) + (and + (export (intern "X" pg) pg) + (export (intern "Y" ph) ph) + (use-package pg ph) + (use-package ph pg) + (progn + (multiple-value-setq + (sym1 a1) (find-symbol "X" pg)) + (multiple-value-setq + (sym2 a2) (find-symbol "Y" ph)) + (multiple-value-setq + (sym3 a3) (find-symbol "Y" pg)) + (multiple-value-setq + (sym4 a4) (find-symbol "X" ph)) + (and + (eqt a1 :external) + (eqt a2 :external) + (eqt a3 :inherited) + (eqt a4 :inherited) + (eqt sym1 sym4) + (eqt sym2 sym3) + (eqt (symbol-package sym1) pg) + (eqt (symbol-package sym2) ph) + (unuse-package pg ph) + (unuse-package ph pg)))) + (safely-delete-package pg) + (safely-delete-package ph)))) t) ;; Check that *PACKAGE* is used as a default (deftest use-package.7 (let ((user-name "H") - (used-name "G")) + (used-name "G")) (safely-delete-package user-name) (safely-delete-package used-name) (let* ((pused (make-package used-name :use nil)) - (puser (make-package user-name :use nil)) - (sym1 (intern "FOO" pused))) + (puser (make-package user-name :use nil)) + (sym1 (intern "FOO" pused))) (and (eqt (export sym1 pused) t) (null (package-used-by-list pused)) @@ -215,10 +215,10 @@ (null (package-use-list puser)) (eqt (let ((*package* puser)) (use-package pused)) t) ;; user will use used (multiple-value-bind (sym2 access) - (find-symbol "FOO" puser) - (and - (eqt access :inherited) - (eqt sym1 sym2))) + (find-symbol "FOO" puser) + (and + (eqt access :inherited) + (eqt sym1 sym2))) (equal (package-use-list puser) (list pused)) (equal (package-used-by-list pused) (list puser)) (null (package-use-list pused)) @@ -232,30 +232,30 @@ (defmacro def-use-package-test (test-name &key (user "H") (used "G")) `(deftest ,test-name (let ((user-name ,user) - (used-name ,used)) + (used-name ,used)) (safely-delete-package user-name) (safely-delete-package used-name) (let* ((pused (make-package used-name :use nil)) - (puser (make-package user-name :use nil)) - (sym1 (intern "FOO" pused))) - (and - (eqt (export sym1 pused) t) - (null (package-used-by-list pused)) - (null (package-used-by-list puser)) - (null (package-use-list pused)) - (null (package-use-list puser)) - (eqt (let ((*package* puser)) (use-package pused)) t) ;; user will use used - (multiple-value-bind (sym2 access) - (find-symbol "FOO" puser) - (and - (eqt access :inherited) - (eqt sym1 sym2))) - (equal (package-use-list puser) (list pused)) - (equal (package-used-by-list pused) (list puser)) - (null (package-use-list pused)) - (null (package-used-by-list puser)) - (eqt (unuse-package pused puser) t) - (null (find-symbol "FOO" puser))))) + (puser (make-package user-name :use nil)) + (sym1 (intern "FOO" pused))) + (and + (eqt (export sym1 pused) t) + (null (package-used-by-list pused)) + (null (package-used-by-list puser)) + (null (package-use-list pused)) + (null (package-use-list puser)) + (eqt (let ((*package* puser)) (use-package pused)) t) ;; user will use used + (multiple-value-bind (sym2 access) + (find-symbol "FOO" puser) + (and + (eqt access :inherited) + (eqt sym1 sym2))) + (equal (package-use-list puser) (list pused)) + (equal (package-used-by-list pused) (list puser)) + (null (package-use-list pused)) + (null (package-used-by-list puser)) + (eqt (unuse-package pused puser) t) + (null (find-symbol "FOO" puser))))) t)) ;;; Specialized user package designator @@ -265,36 +265,36 @@ (def-use-package-test use-package.11 :user (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) + :fill-pointer 5 :element-type 'base-char)) (def-use-package-test use-package.12 :user (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) + :fill-pointer 5 :element-type 'character)) (def-use-package-test use-package.13 :user (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) + :adjustable t :element-type 'base-char)) (def-use-package-test use-package.14 :user (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) + :adjustable t :element-type 'character)) (def-use-package-test use-package.15 :user (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) (def-use-package-test use-package.16 :user (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + :displaced-to name0 + :displaced-index-offset 5))) ;;; Specialed used package designator @@ -303,36 +303,36 @@ (def-use-package-test use-package.18 :used (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'base-char)) + :fill-pointer 5 :element-type 'base-char)) (def-use-package-test use-package.19 :used (make-array 10 :initial-contents "TEST1ABCDE" - :fill-pointer 5 :element-type 'character)) + :fill-pointer 5 :element-type 'character)) (def-use-package-test use-package.20 :used (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'base-char)) + :adjustable t :element-type 'base-char)) (def-use-package-test use-package.21 :used (make-array 5 :initial-contents "TEST1" - :adjustable t :element-type 'character)) + :adjustable t :element-type 'character)) (def-use-package-test use-package.22 :used (let* ((etype 'base-char) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) - (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) + (make-array 5 :element-type etype + :displaced-to name0 + :displaced-index-offset 5))) (def-use-package-test use-package.23 :used (let* ((etype 'character) - (name0 (make-array 10 :element-type etype - :initial-contents "xxxxxTEST1"))) + (name0 (make-array 10 :element-type etype + :initial-contents "xxxxxTEST1"))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 5))) + :displaced-to name0 + :displaced-index-offset 5))) (deftest use-package.error.1 (signals-error (use-package) program-error) diff --git a/ansi-tests/use-value.lsp b/ansi-tests/use-value.lsp index 33328a97..aca83b43 100644 --- a/ansi-tests/use-value.lsp +++ b/ansi-tests/use-value.lsp @@ -13,7 +13,7 @@ (deftest use-value.2 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 @@ -31,7 +31,7 @@ (deftest use-value.4 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (restart-case (with-condition-restarts c1 @@ -43,7 +43,7 @@ (deftest use-value.5 (let ((c1 (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (with-condition-restarts c1 (compute-restarts) diff --git a/ansi-tests/user-homedir-pathname.lsp b/ansi-tests/user-homedir-pathname.lsp index 624e1a3a..1200546b 100644 --- a/ansi-tests/user-homedir-pathname.lsp +++ b/ansi-tests/user-homedir-pathname.lsp @@ -12,7 +12,7 @@ (deftest user-homedir-pathname.2 (let* ((pn-list (multiple-value-list (user-homedir-pathname))) - (pn (first pn-list))) + (pn (first pn-list))) (values (length pn-list) (notnot-mv (pathnamep pn)))) @@ -35,15 +35,15 @@ ;; (deftest user-homedir-pathname.6 ;; (let* ((pn (user-homedir-pathname)) -;; (host (pathname-host pn))) +;; (host (pathname-host pn))) ;; (or (not host) -;; (equalt pn (user-homedir-pathname host)))) +;; (equalt pn (user-homedir-pathname host)))) ;; t) (deftest user-homedir-pathname.7 (let* ((pn (user-homedir-pathname :unspecific))) (or (null pn) - (notnot (pathnamep pn)))) + (notnot (pathnamep pn)))) t) (deftest user-homedir-pathname.error.1 diff --git a/ansi-tests/values-list.lsp b/ansi-tests/values-list.lsp index e3c92169..b2e7af8e 100644 --- a/ansi-tests/values-list.lsp +++ b/ansi-tests/values-list.lsp @@ -38,11 +38,11 @@ (deftest values-list.5 (let ((x (loop for i from 1 to (min 1000 - (1- call-arguments-limit) - (1- multiple-values-limit)) - collect i))) + (1- call-arguments-limit) + (1- multiple-values-limit)) + collect i))) (equalt x - (multiple-value-list (values-list x)))) + (multiple-value-list (values-list x)))) t) - + diff --git a/ansi-tests/values.lsp b/ansi-tests/values.lsp index a2a355cd..a18d3a7d 100644 --- a/ansi-tests/values.lsp +++ b/ansi-tests/values.lsp @@ -57,17 +57,17 @@ (deftest values.C (let ((x (loop for i from 1 to (min 1000 - (1- call-arguments-limit) - (1- multiple-values-limit)) - collect i))) + (1- call-arguments-limit) + (1- multiple-values-limit)) + collect i))) (equalt x - (multiple-value-list (apply #'values x)))) + (multiple-value-list (apply #'values x)))) t) (deftest values.order.1 (let ((i 0) a b c) (values (multiple-value-list - (values (setf a (incf i)) (setf b (incf i)) (setf c (incf i)))) - i a b c)) + (values (setf a (incf i)) (setf b (incf i)) (setf c (incf i)))) + i a b c)) (1 2 3) 3 1 2 3) - + diff --git a/ansi-tests/vector-pop.lsp b/ansi-tests/vector-pop.lsp index 745f3f4f..d7a31635 100644 --- a/ansi-tests/vector-pop.lsp +++ b/ansi-tests/vector-pop.lsp @@ -7,7 +7,7 @@ (deftest vector-pop.1 (let ((v (make-array '(5) :initial-contents '(a b c d e) - :fill-pointer 3))) + :fill-pointer 3))) (values (length v) (check-values (vector-pop v)) @@ -20,17 +20,17 @@ (deftest vector-pop.error.1 (signals-error (let ((v (vector 1 2 3))) - (if (array-has-fill-pointer-p v) - (error 'type-error :datum v :expected-type nil) - (vector-pop v))) - type-error) + (if (array-has-fill-pointer-p v) + (error 'type-error :datum v :expected-type nil) + (vector-pop v))) + type-error) t) (deftest vector-pop.error.2 (let ((v (make-array '(5) :initial-element 'x - :fill-pointer 0))) + :fill-pointer 0))) (handler-case (vector-pop v) - (error () 'error))) + (error () 'error))) error) (deftest vector-pop.error.3 @@ -39,7 +39,7 @@ (deftest vector-pop.error.4 (signals-error (let ((v (make-array '(5) :fill-pointer t - :initial-element 'x))) - (vector-pop v nil)) - program-error) + :initial-element 'x))) + (vector-pop v nil)) + program-error) t) diff --git a/ansi-tests/vector-push-extend.lsp b/ansi-tests/vector-push-extend.lsp index cb66622a..996f407e 100644 --- a/ansi-tests/vector-push-extend.lsp +++ b/ansi-tests/vector-push-extend.lsp @@ -7,12 +7,12 @@ (deftest vector-push-extend.1 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(a b c d e))) - (i 0) x y) + :initial-contents '(a b c d e))) + (i 0) x y) (values (fill-pointer a) (vector-push-extend (progn (setf x (incf i)) 'x) - (progn (setf y (incf i)) a)) + (progn (setf y (incf i)) a)) (fill-pointer a) a i x y)) @@ -20,8 +20,8 @@ (deftest vector-push-extend.2 (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(a b c d e)))) + :adjustable t + :initial-contents '(a b c d e)))) (values (fill-pointer a) (vector-push-extend 'x a) @@ -32,8 +32,8 @@ (deftest vector-push-extend.3 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents "abcde" - :element-type 'base-char))) + :initial-contents "abcde" + :element-type 'base-char))) (values (fill-pointer a) (vector-push-extend #\x a) @@ -43,15 +43,15 @@ (deftest vector-push-extend.4 (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents "abcde" - :element-type 'base-char)) - (i 0) x y z) + :adjustable t + :initial-contents "abcde" + :element-type 'base-char)) + (i 0) x y z) (values (fill-pointer a) (vector-push-extend (progn (setf x (incf i)) #\x) - (progn (setf y (incf i)) a) - (progn (setf z (incf i)) 1)) + (progn (setf y (incf i)) a) + (progn (setf z (incf i)) 1)) (fill-pointer a) (<= (array-total-size a) 5) a @@ -60,8 +60,8 @@ (deftest vector-push-extend.5 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents "abcde" - :element-type 'character))) + :initial-contents "abcde" + :element-type 'character))) (values (fill-pointer a) (vector-push-extend #\x a) @@ -71,9 +71,9 @@ (deftest vector-push-extend.6 (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents "abcde" - :element-type 'character))) + :adjustable t + :initial-contents "abcde" + :element-type 'character))) (values (fill-pointer a) (vector-push-extend #\x a 10) @@ -84,8 +84,8 @@ (deftest vector-push-extend.7 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(0 1 1 0 0) - :element-type 'bit))) + :initial-contents '(0 1 1 0 0) + :element-type 'bit))) (values (fill-pointer a) (vector-push-extend 0 a) @@ -95,9 +95,9 @@ (deftest vector-push-extend.8 (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(0 0 0 0 0) - :element-type 'bit))) + :adjustable t + :initial-contents '(0 0 0 0 0) + :element-type 'bit))) (values (fill-pointer a) (vector-push-extend 1 a 100) @@ -108,8 +108,8 @@ (deftest vector-push-extend.9 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1 2 3 4 5) - :element-type 'fixnum))) + :initial-contents '(1 2 3 4 5) + :element-type 'fixnum))) (values (fill-pointer a) (vector-push-extend 0 a) @@ -119,9 +119,9 @@ (deftest vector-push-extend.10 (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(1 2 3 4 5) - :element-type 'fixnum))) + :adjustable t + :initial-contents '(1 2 3 4 5) + :element-type 'fixnum))) (values (fill-pointer a) (vector-push-extend 0 a 1) @@ -132,8 +132,8 @@ (deftest vector-push-extend.11 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1 2 3 4 5) - :element-type '(integer 0 (256))))) + :initial-contents '(1 2 3 4 5) + :element-type '(integer 0 (256))))) (values (fill-pointer a) (vector-push-extend 0 a) @@ -143,9 +143,9 @@ (deftest vector-push-extend.12 (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(1 2 3 4 5) - :element-type '(integer 0 (256))))) + :adjustable t + :initial-contents '(1 2 3 4 5) + :element-type '(integer 0 (256))))) (values (fill-pointer a) (vector-push-extend 0 a 1) @@ -156,8 +156,8 @@ (deftest vector-push-extend.13 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) - :element-type 'short-float))) + :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) + :element-type 'short-float))) (values (fill-pointer a) (vector-push-extend 0.0s0 a) @@ -167,9 +167,9 @@ (deftest vector-push-extend.14 (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) - :element-type 'short-float))) + :adjustable t + :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) + :element-type 'short-float))) (values (fill-pointer a) (vector-push-extend 0.0s0 a 1) @@ -180,8 +180,8 @@ (deftest vector-push-extend.15 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) - :element-type 'single-float))) + :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) + :element-type 'single-float))) (values (fill-pointer a) (vector-push-extend 0.0f0 a) @@ -191,9 +191,9 @@ (deftest vector-push-extend.16 (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) - :element-type 'single-float))) + :adjustable t + :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) + :element-type 'single-float))) (values (fill-pointer a) (vector-push-extend 0.0f0 a 1) @@ -205,8 +205,8 @@ (deftest vector-push-extend.17 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) - :element-type 'double-float))) + :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) + :element-type 'double-float))) (values (fill-pointer a) (vector-push-extend 0.0d0 a) @@ -216,9 +216,9 @@ (deftest vector-push-extend.18 (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) - :element-type 'double-float))) + :adjustable t + :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) + :element-type 'double-float))) (values (fill-pointer a) (vector-push-extend 0.0d0 a 1) @@ -229,8 +229,8 @@ (deftest vector-push-extend.19 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) - :element-type 'long-float))) + :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) + :element-type 'long-float))) (values (fill-pointer a) (vector-push-extend 0.0l0 a) @@ -240,9 +240,9 @@ (deftest vector-push-extend.20 (let ((a (make-array '(5) :fill-pointer 5 - :adjustable t - :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) - :element-type 'long-float))) + :adjustable t + :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) + :element-type 'long-float))) (values (fill-pointer a) (vector-push-extend 0.0l0 a 1) @@ -256,9 +256,9 @@ (deftest vector-push-extend.21 (let* ((a1 (make-array 10 :initial-element nil)) - (a2 (make-array 6 :displaced-to a1 - :displaced-index-offset 2 - :fill-pointer 0))) + (a2 (make-array 6 :displaced-to a1 + :displaced-index-offset 2 + :fill-pointer 0))) (values (fill-pointer a2) (map 'list #'identity a2) @@ -275,10 +275,10 @@ (deftest vector-push-extend.22 (let* ((a1 (make-array 6 :initial-element nil)) - (a2 (make-array 0 :displaced-to a1 - :displaced-index-offset 2 - :adjustable t - :fill-pointer 0))) + (a2 (make-array 0 :displaced-to a1 + :displaced-index-offset 2 + :adjustable t + :fill-pointer 0))) (values (fill-pointer a2) (map 'list #'identity a2) @@ -300,10 +300,10 @@ (deftest vector-push-extend.23 (let* ((a1 (make-array 10 :initial-element nil)) - (a2 (make-array 6 :displaced-to a1 - :displaced-index-offset 2 - :adjustable t - :fill-pointer 1))) + (a2 (make-array 6 :displaced-to a1 + :displaced-index-offset 2 + :adjustable t + :fill-pointer 1))) (values (fill-pointer a2) (map 'list #'identity a2) @@ -327,10 +327,10 @@ (deftest vector-push-extend.24 (let* ((a1 (make-array 4 :initial-element nil)) - (a2 (make-array 2 :displaced-to a1 - :displaced-index-offset 2 - :adjustable t - :fill-pointer 2))) + (a2 (make-array 2 :displaced-to a1 + :displaced-index-offset 2 + :adjustable t + :fill-pointer 2))) (values (map 'list #'identity a1) (map 'list #'identity a2) @@ -355,153 +355,153 @@ (deftest vector-push-extend.25 (loop for adj in '(nil t) - nconc - (loop for bits from 1 to 64 - for etype = `(unsigned-byte ,bits) - for a1 = (make-array 10 :initial-element 0 - :element-type etype) - for a2 =(make-array 6 - :element-type etype - :displaced-to a1 - :displaced-index-offset 2 - :adjustable adj - :fill-pointer 0) - for result = (list (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend 1 a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1)) - unless (equal result '(0 () 0 1 (1) (0 0 1 0 0 0 0 0 0 0))) - collect (list etype adj result))) + nconc + (loop for bits from 1 to 64 + for etype = `(unsigned-byte ,bits) + for a1 = (make-array 10 :initial-element 0 + :element-type etype) + for a2 =(make-array 6 + :element-type etype + :displaced-to a1 + :displaced-index-offset 2 + :adjustable adj + :fill-pointer 0) + for result = (list (fill-pointer a2) + (map 'list #'identity a2) + (vector-push-extend 1 a2) + (fill-pointer a2) + (map 'list #'identity a2) + (map 'list #'identity a1)) + unless (equal result '(0 () 0 1 (1) (0 0 1 0 0 0 0 0 0 0))) + collect (list etype adj result))) nil) (deftest vector-push-extend.26 (loop for bits from 1 to 64 - for etype = `(unsigned-byte ,bits) - for a1 = (make-array 8 :initial-element 0 - :element-type etype) - for a2 = (make-array 6 - :element-type etype - :displaced-to a1 - :displaced-index-offset 2 - :adjustable t - :fill-pointer 6) - for result = (list (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend 1 a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1) - (notnot (adjustable-array-p a2)) - (multiple-value-list (array-displacement a1))) - unless (equal result '(6 (0 0 0 0 0 0) 6 7 (0 0 0 0 0 0 1) - (0 0 0 0 0 0 0 0) t (nil 0))) - collect (list etype result)) + for etype = `(unsigned-byte ,bits) + for a1 = (make-array 8 :initial-element 0 + :element-type etype) + for a2 = (make-array 6 + :element-type etype + :displaced-to a1 + :displaced-index-offset 2 + :adjustable t + :fill-pointer 6) + for result = (list (fill-pointer a2) + (map 'list #'identity a2) + (vector-push-extend 1 a2) + (fill-pointer a2) + (map 'list #'identity a2) + (map 'list #'identity a1) + (notnot (adjustable-array-p a2)) + (multiple-value-list (array-displacement a1))) + unless (equal result '(6 (0 0 0 0 0 0) 6 7 (0 0 0 0 0 0 1) + (0 0 0 0 0 0 0 0) t (nil 0))) + collect (list etype result)) nil) ;;; strings (deftest vector-push-extend.27 (loop for adj in '(nil t) - nconc - (loop for etype in '(character base-char standard-char) - for a1 = (make-array 10 :initial-element #\a - :element-type etype) - for a2 =(make-array 6 - :element-type etype - :displaced-to a1 - :displaced-index-offset 2 - :adjustable adj - :fill-pointer 0) - for result = (list (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend #\b a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1)) - unless (equal result '(0 () 0 1 (#\b) (#\a #\a #\b #\a #\a #\a #\a #\a #\a #\a))) - collect (list etype adj result))) + nconc + (loop for etype in '(character base-char standard-char) + for a1 = (make-array 10 :initial-element #\a + :element-type etype) + for a2 =(make-array 6 + :element-type etype + :displaced-to a1 + :displaced-index-offset 2 + :adjustable adj + :fill-pointer 0) + for result = (list (fill-pointer a2) + (map 'list #'identity a2) + (vector-push-extend #\b a2) + (fill-pointer a2) + (map 'list #'identity a2) + (map 'list #'identity a1)) + unless (equal result '(0 () 0 1 (#\b) (#\a #\a #\b #\a #\a #\a #\a #\a #\a #\a))) + collect (list etype adj result))) nil) (deftest vector-push-extend.28 (loop for etype in '(character base-char standard-char) - for a1 = (make-array 8 :initial-element #\a - :element-type etype) - for a2 = (make-array 6 - :element-type etype - :displaced-to a1 - :displaced-index-offset 2 - :adjustable t - :fill-pointer 6) - for result = (list (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend #\b a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1) - (notnot (adjustable-array-p a2)) - (multiple-value-list (array-displacement a1))) - unless (equal result '(6 #.(coerce "aaaaaa" 'list) - 6 7 - #.(coerce "aaaaaab" 'list) - #.(coerce "aaaaaaaa" 'list) - t (nil 0))) - collect (list etype result)) + for a1 = (make-array 8 :initial-element #\a + :element-type etype) + for a2 = (make-array 6 + :element-type etype + :displaced-to a1 + :displaced-index-offset 2 + :adjustable t + :fill-pointer 6) + for result = (list (fill-pointer a2) + (map 'list #'identity a2) + (vector-push-extend #\b a2) + (fill-pointer a2) + (map 'list #'identity a2) + (map 'list #'identity a1) + (notnot (adjustable-array-p a2)) + (multiple-value-list (array-displacement a1))) + unless (equal result '(6 #.(coerce "aaaaaa" 'list) + 6 7 + #.(coerce "aaaaaab" 'list) + #.(coerce "aaaaaaaa" 'list) + t (nil 0))) + collect (list etype result)) nil) ;;; float tests (deftest vector-push-extend.29 (loop for adj in '(nil t) - nconc - (loop for etype in '(short-float single-float double-float long-float) - for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - for a1 = (make-array 10 :initial-element zero - :element-type etype) - for a2 =(make-array 6 - :element-type etype - :displaced-to a1 - :displaced-index-offset 2 - :adjustable adj - :fill-pointer 0) - for result = (list (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend one a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1)) - unless (equal result `(0 () 0 1 (,one) (,zero ,zero ,one ,zero ,zero ,zero ,zero ,zero ,zero ,zero))) - collect (list etype adj result))) + nconc + (loop for etype in '(short-float single-float double-float long-float) + for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) + for one in '(1.0s0 1.0f0 1.0d0 1.0l0) + for a1 = (make-array 10 :initial-element zero + :element-type etype) + for a2 =(make-array 6 + :element-type etype + :displaced-to a1 + :displaced-index-offset 2 + :adjustable adj + :fill-pointer 0) + for result = (list (fill-pointer a2) + (map 'list #'identity a2) + (vector-push-extend one a2) + (fill-pointer a2) + (map 'list #'identity a2) + (map 'list #'identity a1)) + unless (equal result `(0 () 0 1 (,one) (,zero ,zero ,one ,zero ,zero ,zero ,zero ,zero ,zero ,zero))) + collect (list etype adj result))) nil) (deftest vector-push-extend.30 (loop for etype in '(short-float single-float double-float long-float) - for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) - for one in '(1.0s0 1.0f0 1.0d0 1.0l0) - for a1 = (make-array 8 :initial-element zero - :element-type etype) - for a2 = (make-array 6 - :element-type etype - :displaced-to a1 - :displaced-index-offset 2 - :adjustable t - :fill-pointer 6) - for result = (list (fill-pointer a2) - (map 'list #'identity a2) - (vector-push-extend one a2) - (fill-pointer a2) - (map 'list #'identity a2) - (map 'list #'identity a1) - (notnot (adjustable-array-p a2)) - (multiple-value-list (array-displacement a1))) - unless (equal result `(6 (,zero ,zero ,zero ,zero ,zero ,zero) - 6 7 - (,zero ,zero ,zero ,zero ,zero ,zero ,one) - (,zero ,zero ,zero ,zero ,zero ,zero ,zero ,zero) - t (nil 0))) - collect (list etype result)) + for zero in '(0.0s0 0.0f0 0.0d0 0.0l0) + for one in '(1.0s0 1.0f0 1.0d0 1.0l0) + for a1 = (make-array 8 :initial-element zero + :element-type etype) + for a2 = (make-array 6 + :element-type etype + :displaced-to a1 + :displaced-index-offset 2 + :adjustable t + :fill-pointer 6) + for result = (list (fill-pointer a2) + (map 'list #'identity a2) + (vector-push-extend one a2) + (fill-pointer a2) + (map 'list #'identity a2) + (map 'list #'identity a1) + (notnot (adjustable-array-p a2)) + (multiple-value-list (array-displacement a1))) + unless (equal result `(6 (,zero ,zero ,zero ,zero ,zero ,zero) + 6 7 + (,zero ,zero ,zero ,zero ,zero ,zero ,one) + (,zero ,zero ,zero ,zero ,zero ,zero ,zero ,zero) + t (nil 0))) + collect (list etype result)) nil) @@ -511,9 +511,9 @@ (declare (optimize (safety 3))) (handler-case (eval `(let ((a (copy-seq ,seq))) - (declare (optimize (safety 3))) - (or (notnot (array-has-fill-pointer-p a)) - (vector-push-extend ',val a 1)))) + (declare (optimize (safety 3))) + (or (notnot (array-has-fill-pointer-p a)) + (vector-push-extend ',val a 1)))) (error () t))) (deftest vector-push-extend.error.1 @@ -542,44 +542,44 @@ (deftest vector-push-extend.error.7 (vector-push-extend-error-test (make-array '5 :element-type 'base-char - :initial-element #\a) - #\x) + :initial-element #\a) + #\x) t) (deftest vector-push-extend.error.8 (vector-push-extend-error-test (make-array '5 :element-type '(integer 0 (256)) - :initial-element 0) - 17) + :initial-element 0) + 17) t) (deftest vector-push-extend.error.9 (vector-push-extend-error-test (make-array '5 :element-type 'float - :initial-element 1.0) - 2.0) + :initial-element 1.0) + 2.0) t) (deftest vector-push-extend.error.10 (vector-push-extend-error-test (make-array '5 :element-type 'short-float - :initial-element 1.0s0) - 2.0s0) + :initial-element 1.0s0) + 2.0s0) t) (deftest vector-push-extend.error.11 (vector-push-extend-error-test (make-array '5 :element-type 'long-float - :initial-element 1.0l0) - 2.0l0) + :initial-element 1.0l0) + 2.0l0) t) (deftest vector-push-extend.error.12 (vector-push-extend-error-test (make-array '5 :element-type 'single-float - :initial-element 1.0f0) - 2.0f0) + :initial-element 1.0f0) + 2.0f0) t) (deftest vector-push-extend.error.13 (vector-push-extend-error-test (make-array '5 :element-type 'double-float - :initial-element 1.0d0) - 2.0d0) + :initial-element 1.0d0) + 2.0d0) t) (deftest vector-push-extend.error.14 @@ -600,9 +600,9 @@ `(locally (declare (optimize (safety 3))) (let ((a (make-array '5 :fill-pointer t :adjustable nil - :initial-element nil))) - (or (notnot (adjustable-array-p a)) ; It's actually adjustable, or... - (vector-push-extend a 'x) ; ... this fails - )))) + :initial-element nil))) + (or (notnot (adjustable-array-p a)) ; It's actually adjustable, or... + (vector-push-extend a 'x) ; ... this fails + )))) (error () t)) t) diff --git a/ansi-tests/vector-push.lsp b/ansi-tests/vector-push.lsp index b7e5ce03..83f1fb6a 100644 --- a/ansi-tests/vector-push.lsp +++ b/ansi-tests/vector-push.lsp @@ -7,12 +7,12 @@ (deftest vector-push.1 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(a b c d e))) - (i 0) x y) + :initial-contents '(a b c d e))) + (i 0) x y) (values (fill-pointer a) (vector-push (progn (setf x (incf i)) 'x) - (progn (setf y (incf i)) a)) + (progn (setf y (incf i)) a)) (fill-pointer a) a i x y)) 2 2 3 #(a b x) 2 1 2) @@ -20,7 +20,7 @@ (deftest vector-push.2 (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(a b c d e)))) + :initial-contents '(a b c d e)))) (values (fill-pointer a) (vector-push 'x a) @@ -30,8 +30,8 @@ (deftest vector-push.3 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents "abcde" - :element-type 'base-char))) + :initial-contents "abcde" + :element-type 'base-char))) (values (fill-pointer a) (vector-push #\x a) @@ -41,8 +41,8 @@ (deftest vector-push.4 (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents "abcde" - :element-type 'base-char))) + :initial-contents "abcde" + :element-type 'base-char))) (values (fill-pointer a) (vector-push #\x a) @@ -52,8 +52,8 @@ (deftest vector-push.5 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents "abcde" - :element-type 'character))) + :initial-contents "abcde" + :element-type 'character))) (values (fill-pointer a) (vector-push #\x a) @@ -63,8 +63,8 @@ (deftest vector-push.6 (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents "abcde" - :element-type 'character))) + :initial-contents "abcde" + :element-type 'character))) (values (fill-pointer a) (vector-push #\x a) @@ -74,8 +74,8 @@ (deftest vector-push.7 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(0 1 1 0 0) - :element-type 'bit))) + :initial-contents '(0 1 1 0 0) + :element-type 'bit))) (values (fill-pointer a) (vector-push 0 a) @@ -85,8 +85,8 @@ (deftest vector-push.8 (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(0 0 0 0 0) - :element-type 'bit))) + :initial-contents '(0 0 0 0 0) + :element-type 'bit))) (values (fill-pointer a) (vector-push 1 a) @@ -96,8 +96,8 @@ (deftest vector-push.9 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1 2 3 4 5) - :element-type 'fixnum))) + :initial-contents '(1 2 3 4 5) + :element-type 'fixnum))) (values (fill-pointer a) (vector-push 0 a) @@ -107,8 +107,8 @@ (deftest vector-push.10 (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(1 2 3 4 5) - :element-type 'fixnum))) + :initial-contents '(1 2 3 4 5) + :element-type 'fixnum))) (values (fill-pointer a) (vector-push 0 a) @@ -118,8 +118,8 @@ (deftest vector-push.11 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1 2 3 4 5) - :element-type '(integer 0 (256))))) + :initial-contents '(1 2 3 4 5) + :element-type '(integer 0 (256))))) (values (fill-pointer a) (vector-push 0 a) @@ -129,8 +129,8 @@ (deftest vector-push.12 (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(1 2 3 4 5) - :element-type '(integer 0 (256))))) + :initial-contents '(1 2 3 4 5) + :element-type '(integer 0 (256))))) (values (fill-pointer a) (vector-push 0 a) @@ -140,8 +140,8 @@ (deftest vector-push.13 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) - :element-type 'short-float))) + :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) + :element-type 'short-float))) (values (fill-pointer a) (vector-push 0.0s0 a) @@ -151,8 +151,8 @@ (deftest vector-push.14 (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) - :element-type 'short-float))) + :initial-contents '(1.0s0 2.0s0 3.0s0 4.0s0 5.0s0) + :element-type 'short-float))) (values (fill-pointer a) (vector-push 0.0s0 a) @@ -162,8 +162,8 @@ (deftest vector-push.15 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) - :element-type 'single-float))) + :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) + :element-type 'single-float))) (values (fill-pointer a) (vector-push 0.0f0 a) @@ -173,8 +173,8 @@ (deftest vector-push.16 (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) - :element-type 'single-float))) + :initial-contents '(1.0f0 2.0f0 3.0f0 4.0f0 5.0f0) + :element-type 'single-float))) (values (fill-pointer a) (vector-push 0.0f0 a) @@ -185,8 +185,8 @@ (deftest vector-push.17 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) - :element-type 'double-float))) + :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) + :element-type 'double-float))) (values (fill-pointer a) (vector-push 0.0d0 a) @@ -196,8 +196,8 @@ (deftest vector-push.18 (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) - :element-type 'double-float))) + :initial-contents '(1.0d0 2.0d0 3.0d0 4.0d0 5.0d0) + :element-type 'double-float))) (values (fill-pointer a) (vector-push 0.0d0 a) @@ -207,8 +207,8 @@ (deftest vector-push.19 (let ((a (make-array '(5) :fill-pointer 2 - :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) - :element-type 'long-float))) + :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) + :element-type 'long-float))) (values (fill-pointer a) (vector-push 0.0l0 a) @@ -218,8 +218,8 @@ (deftest vector-push.20 (let ((a (make-array '(5) :fill-pointer 5 - :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) - :element-type 'long-float))) + :initial-contents '(1.0l0 2.0l0 3.0l0 4.0l0 5.0l0) + :element-type 'long-float))) (values (fill-pointer a) (vector-push 0.0l0 a) @@ -235,9 +235,9 @@ (declare (optimize (safety 3))) (handler-case (eval `(let ((a (copy-seq ,seq))) - (declare (optimize (safety 3))) - (or (notnot (array-has-fill-pointer-p a)) - (vector-push ',val a)))) + (declare (optimize (safety 3))) + (or (notnot (array-has-fill-pointer-p a)) + (vector-push ',val a)))) (error () t))) (deftest vector-push.error.1 @@ -266,44 +266,44 @@ (deftest vector-push.error.7 (vector-push-error-test (make-array '5 :element-type 'base-char - :initial-element #\a) - #\x) + :initial-element #\a) + #\x) t) (deftest vector-push.error.8 (vector-push-error-test (make-array '5 :element-type '(integer 0 (256)) - :initial-element 0) - 17) + :initial-element 0) + 17) t) (deftest vector-push.error.9 (vector-push-error-test (make-array '5 :element-type 'float - :initial-element 1.0) - 2.0) + :initial-element 1.0) + 2.0) t) (deftest vector-push.error.10 (vector-push-error-test (make-array '5 :element-type 'short-float - :initial-element 1.0s0) - 2.0s0) + :initial-element 1.0s0) + 2.0s0) t) (deftest vector-push.error.11 (vector-push-error-test (make-array '5 :element-type 'long-float - :initial-element 1.0l0) - 2.0l0) + :initial-element 1.0l0) + 2.0l0) t) (deftest vector-push.error.12 (vector-push-error-test (make-array '5 :element-type 'single-float - :initial-element 1.0f0) - 2.0f0) + :initial-element 1.0f0) + 2.0f0) t) (deftest vector-push.error.13 (vector-push-error-test (make-array '5 :element-type 'double-float - :initial-element 1.0d0) - 2.0d0) + :initial-element 1.0d0) + 2.0d0) t) (deftest vector-push.error.14 diff --git a/ansi-tests/vector.lsp b/ansi-tests/vector.lsp index 2dc1bd49..23d1536b 100644 --- a/ansi-tests/vector.lsp +++ b/ansi-tests/vector.lsp @@ -180,15 +180,15 @@ (deftest vector.type.41 (notnot-mv (typep (make-array '10 :element-type 'short-float) 'vector)) t) - + (deftest vector.type.42 (notnot-mv (typep (make-array '10 :element-type 'single-float) 'vector)) t) - + (deftest vector.type.43 (notnot-mv (typep (make-array '10 :element-type 'double-float) 'vector)) t) - + (deftest vector.type.44 (notnot-mv (typep (make-array '10 :element-type 'long-float) 'vector)) t) @@ -203,23 +203,23 @@ (deftest vector-as-class.2 (notnot-mv (typep #() (find-class 'vector))) t) - + (deftest vector-as-class.3 (notnot-mv (typep #(a b c) (find-class 'vector))) t) - + (deftest vector-as-class.4 (notnot-mv (typep "" (find-class 'vector))) t) - + (deftest vector-as-class.5 (notnot-mv (typep "abcd" (find-class 'vector))) t) - + (deftest vector-as-class.6 (notnot-mv (typep #* (find-class 'vector))) t) - + (deftest vector-as-class.7 (notnot-mv (typep #*01101010100 (find-class 'vector))) t) @@ -280,8 +280,8 @@ (deftest vector.3 (let* ((len (min 1000 (1- call-arguments-limit))) - (args (make-int-list len)) - (v (apply #'vector args))) + (args (make-int-list len)) + (v (apply #'vector args))) (and (typep v '(vector t)) (typep v '(vector t *)) @@ -290,27 +290,27 @@ (typep v `(simple-vector ,len)) (eql (length v) len) (loop for i from 0 - for e across v - always (eql i e)) + for e across v + always (eql i e)) t)) t) (deftest vector.4 (notnot-mv (typep (vector) '(vector t 0))) t) - + (deftest vector.5 (notnot-mv (typep (vector) 'simple-vector)) t) - + (deftest vector.6 (notnot-mv (typep (vector) '(simple-vector 0))) t) - + (deftest vector.7 (notnot-mv (typep (vector 1 2 3) 'simple-vector)) t) - + (deftest vector.8 (notnot-mv (typep (vector 1 2 3) '(simple-vector 3))) t) diff --git a/ansi-tests/warn.lsp b/ansi-tests/warn.lsp index a1fd6842..5d8cfb23 100644 --- a/ansi-tests/warn.lsp +++ b/ansi-tests/warn.lsp @@ -9,9 +9,9 @@ (let ((warned nil)) (handler-bind ((warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) (values (multiple-value-list (warn "This is a warning")) warned))) @@ -21,9 +21,9 @@ (let ((warned nil)) (handler-bind ((warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning)))) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning)))) (values (multiple-value-list (warn "This is a warning")) warned))) @@ -35,16 +35,16 @@ (let ((warned nil)) (handler-bind ((warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) (warn "Foo!")))) "") (deftest warn.4 (let ((str (with-output-to-string - (*error-output*) - (warn "Foo!")))) + (*error-output*) + (warn "Foo!")))) (not (string= str ""))) t) @@ -52,9 +52,9 @@ (let ((warned nil)) (handler-bind ((simple-warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) (values (multiple-value-list (warn "This is a warning")) warned))) @@ -64,9 +64,9 @@ (let ((warned nil)) (handler-bind ((simple-condition #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) (values (multiple-value-list (warn "This is a warning")) warned))) @@ -76,9 +76,9 @@ (let ((warned nil)) (handler-bind ((condition #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) (values (multiple-value-list (warn "This is a warning")) warned))) @@ -88,9 +88,9 @@ (let ((warned nil)) (handler-bind ((warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) (values (multiple-value-list (warn 'simple-warning :format-control "Foo!")) warned))) @@ -100,9 +100,9 @@ (let ((warned nil)) (handler-bind ((warning #'(lambda (c) - (assert (typep c 'warning)) - (setf warned t) - (muffle-warning c)))) + (assert (typep c 'warning)) + (setf warned t) + (muffle-warning c)))) (values (multiple-value-list (warn 'warning)) warned))) @@ -112,9 +112,9 @@ (let ((warned nil)) (handler-bind ((warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) (values (multiple-value-list (warn (make-condition 'simple-warning :format-control "Foo!"))) warned))) @@ -124,9 +124,9 @@ (let ((warned nil)) (handler-bind ((warning #'(lambda (c) - (assert (typep c 'warning)) - (setf warned t) - (muffle-warning c)))) + (assert (typep c 'warning)) + (setf warned t) + (muffle-warning c)))) (values (multiple-value-list (warn (make-condition 'warning))) warned))) @@ -164,12 +164,12 @@ (let ((warned nil)) (handler-bind ((warning #'(lambda (c) - (assert (typep c 'simple-warning)) - (setf warned t) - (muffle-warning c)))) + (assert (typep c 'simple-warning)) + (setf warned t) + (muffle-warning c)))) (values (multiple-value-list (warn (make-condition 'simple-warning - :format-control (formatter "Foo!")))) + :format-control (formatter "Foo!")))) warned))) - (nil) t) \ No newline at end of file + (nil) t) diff --git a/ansi-tests/when.lsp b/ansi-tests/when.lsp index 7bd2042e..1f1092ed 100644 --- a/ansi-tests/when.lsp +++ b/ansi-tests/when.lsp @@ -76,12 +76,12 @@ (deftest when.error.2 (signals-error (funcall (macro-function 'when) - '(when t)) - program-error) + '(when t)) + program-error) t) (deftest when.error.3 (signals-error (funcall (macro-function 'when) - '(when t) nil nil) - program-error) + '(when t) nil nil) + program-error) t) diff --git a/ansi-tests/wild-pathname-p.lsp b/ansi-tests/wild-pathname-p.lsp index d161c434..3f9a3021 100644 --- a/ansi-tests/wild-pathname-p.lsp +++ b/ansi-tests/wild-pathname-p.lsp @@ -13,8 +13,8 @@ (deftest wild-pathname-p.2 (loop for key in '(:host :device :directory :name :type :version nil) - when (wild-pathname-p (make-pathname) key) - collect key) + when (wild-pathname-p (make-pathname) key) + collect key) nil) (deftest wild-pathname-p.3 @@ -35,8 +35,8 @@ (deftest wild-pathname-p.6 (let ((p (make-pathname :directory :wild))) (loop for key in '(:host :device :name :type :version) - when (wild-pathname-p p key) - collect key)) + when (wild-pathname-p p key) + collect key)) nil) @@ -58,8 +58,8 @@ (deftest wild-pathname-p.10 (let ((p (make-pathname :directory '(:absolute :wild)))) (loop for key in '(:host :device :name :type :version) - when (wild-pathname-p p key) - collect key)) + when (wild-pathname-p p key) + collect key)) nil) @@ -81,8 +81,8 @@ (deftest wild-pathname-p.14 (let ((p (make-pathname :directory '(:relative :wild)))) (loop for key in '(:host :device :name :type :version) - when (wild-pathname-p p key) - collect key)) + when (wild-pathname-p p key) + collect key)) nil) ;;; @@ -105,12 +105,12 @@ (deftest wild-pathname-p.18 (let ((p (make-pathname :name :wild))) (loop for key in '(:host :device :directory :type :version) - when (wild-pathname-p p key) - collect key)) + when (wild-pathname-p p key) + collect key)) nil) -;;; - +;;; + (deftest wild-pathname-p.19 (let ((p (make-pathname :type :wild))) (notnot-mv (wild-pathname-p p))) @@ -129,8 +129,8 @@ (deftest wild-pathname-p.22 (let ((p (make-pathname :type :wild))) (loop for key in '(:host :device :directory :name :version) - when (wild-pathname-p p key) - collect key)) + when (wild-pathname-p p key) + collect key)) nil) ;;; @@ -153,43 +153,43 @@ (deftest wild-pathname-p.26 (let ((p (make-pathname :version :wild))) (loop for key in '(:host :device :directory :name :type) - when (wild-pathname-p p key) - collect key)) + when (wild-pathname-p p key) + collect key)) nil) ;;; (deftest wild-pathname-p.27 (loop for p in (append *pathnames* *logical-pathnames*) - unless (if (wild-pathname-p p) (wild-pathname-p p nil) - (not (wild-pathname-p p nil))) - collect p) + unless (if (wild-pathname-p p) (wild-pathname-p p nil) + (not (wild-pathname-p p nil))) + collect p) nil) (deftest wild-pathname-p.28 (loop for p in (append *pathnames* *logical-pathnames*) - when (and (loop for key in '(:host :device :directory - :name :type :version) - thereis (wild-pathname-p p key)) - (not (wild-pathname-p p))) - collect p) + when (and (loop for key in '(:host :device :directory + :name :type :version) + thereis (wild-pathname-p p key)) + (not (wild-pathname-p p))) + collect p) nil) ;;; On streams associated with files (deftest wild-pathname-p.29 (with-open-file (s "foo.lsp" - :direction :output - :if-exists :append - :if-does-not-exist :create) - (wild-pathname-p s)) + :direction :output + :if-exists :append + :if-does-not-exist :create) + (wild-pathname-p s)) nil) (deftest wild-pathname-p.30 (let ((s (open "foo.lsp" - :direction :output - :if-exists :append - :if-does-not-exist :create))) + :direction :output + :if-exists :append + :if-does-not-exist :create))) (close s) (wild-pathname-p s)) nil) @@ -217,18 +217,18 @@ (deftest wild-pathname-p.error.2 (signals-error (wild-pathname-p *default-pathname-defaults* nil nil) - program-error) + program-error) t) (deftest wild-pathname-p.error.3 (check-type-error #'wild-pathname-p - (typef '(or pathname string file-stream - synonym-stream))) + (typef '(or pathname string file-stream + synonym-stream))) nil) (deftest wild-pathname-p.error.4 (check-type-error #'(lambda (x) (declare (optimize (safety 0))) - (wild-pathname-p x)) - (typef '(or pathname string file-stream - synonym-stream))) + (wild-pathname-p x)) + (typef '(or pathname string file-stream + synonym-stream))) nil) diff --git a/ansi-tests/with-accessors.lsp b/ansi-tests/with-accessors.lsp index d79b6f0d..3e8667b1 100644 --- a/ansi-tests/with-accessors.lsp +++ b/ansi-tests/with-accessors.lsp @@ -32,7 +32,7 @@ (return-from done :bad)) 10 (return-from done :good))) - :good) + :good) (defclass with-accessors-class-01 () ((a :initarg :a :accessor wa-a) @@ -53,7 +53,7 @@ ((a wa-a) (b wa-b) (c wa-c)) obj (values (setf a 'x) (setf b 'y) (setf c 'z) - (map-slot-value obj '(a b c))))) + (map-slot-value obj '(a b c))))) x y z (x y z)) (deftest with-accessors.8 @@ -62,7 +62,7 @@ ((a wa-a) (b wa-b) (c wa-c)) obj (values (setq a 'x) (setq b 'y) (setq c 'z) - (map-slot-value obj '(a b c))))) + (map-slot-value obj '(a b c))))) x y z (x y z)) (deftest with-accessors.9 @@ -71,7 +71,7 @@ ((a wa-a) (b wa-b) (c wa-c)) obj (values (incf a 4) (incf b 412) (incf c 75) - (map-slot-value obj '(a b c))))) + (map-slot-value obj '(a b c))))) 9 431 387 (9 431 387)) (deftest with-accessors.10 @@ -100,8 +100,8 @@ (deftest with-accessors.12 (let ((obj (make-with-accessors-struct-02 :a 'x :b 'y :c 'z))) (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c)) - obj - (values a b c))) + obj + (values a b c))) x y z) (deftest with-accessors.13 @@ -110,7 +110,7 @@ ((a wa-2-a) (b wa-2-b) (c wa-2-c)) obj (values (setf a 'x) (setf b 'y) (setf c 'z) - (wa-2-a obj) (wa-2-b obj) (wa-2-c obj)))) + (wa-2-a obj) (wa-2-b obj) (wa-2-c obj)))) x y z x y z) ;;; Free declaration scope test @@ -120,8 +120,8 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (with-accessors nil (return-from done x) - (declare (special x)))))) + (with-accessors nil (return-from done x) + (declare (special x)))))) :good) ;;; Test that explicit calls to macroexpand in subforms @@ -132,7 +132,7 @@ ((%m (z) z)) (let ((obj (make-with-accessors-struct-02 :a 'x :b 'y :c 'z))) (with-accessors ((a wa-2-a) (b wa-2-b) (c wa-2-c)) - (expand-in-current-env (%m obj)) - (values a b c)))) + (expand-in-current-env (%m obj)) + (values a b c)))) x y z) diff --git a/ansi-tests/with-compilation-unit.lsp b/ansi-tests/with-compilation-unit.lsp index b748b1c5..fdc19bd1 100644 --- a/ansi-tests/with-compilation-unit.lsp +++ b/ansi-tests/with-compilation-unit.lsp @@ -26,7 +26,7 @@ (deftest with-compilation-unit.5 (with-compilation-unit (:override nil) :foo) :foo) - + (deftest with-compilation-unit.6 (with-compilation-unit (:override t) (values 10 17)) 10 17) @@ -36,10 +36,10 @@ (values (block done (with-compilation-unit - (:override nil) - (setq x 1) - (return-from done 2) - (setq x 2))) + (:override nil) + (setq x 1) + (return-from done 2) + (setq x 2))) x)) 2 1) diff --git a/ansi-tests/with-condition-restarts.lsp b/ansi-tests/with-condition-restarts.lsp index b6f5cc70..655fa54c 100644 --- a/ansi-tests/with-condition-restarts.lsp +++ b/ansi-tests/with-condition-restarts.lsp @@ -53,7 +53,7 @@ (deftest with-condition-restarts.6 (let ((c (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (handler-bind ((error #'(lambda (c) (invoke-restart (find-restart 'foo c2))))) (restart-case @@ -67,7 +67,7 @@ (deftest with-condition-restarts.7 (let ((c (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (handler-bind ((error #'(lambda (c) (invoke-restart 'foo)))) (restart-case @@ -84,12 +84,12 @@ (deftest with-condition-restarts.8 (let ((c (make-condition 'error)) - (c2 (make-condition 'error))) + (c2 (make-condition 'error))) (restart-case (progn (with-condition-restarts - c - (list (find-restart 'foo))) + c + (list (find-restart 'foo))) (invoke-restart (find-restart 'foo c2))) (foo () 'good) (foo () 'bad))) diff --git a/ansi-tests/with-hash-table-iterator.lsp b/ansi-tests/with-hash-table-iterator.lsp index 0b208025..3787d902 100644 --- a/ansi-tests/with-hash-table-iterator.lsp +++ b/ansi-tests/with-hash-table-iterator.lsp @@ -28,7 +28,7 @@ (with-hash-table-iterator (%x table) (multiple-value-bind (success-p key val) - (%x) + (%x) (values (notnot success-p) key val)))) t a b) @@ -43,29 +43,29 @@ (deftest with-hash-table-iterator.7 (let ((keys '("a" "b" "c" "d" "e"))) (loop for test in '(eq eql equal equalp) - for test-fn of-type function = (symbol-function test) - collect - (let ((table (make-hash-table :test test))) - (loop for k in keys - for i from 0 - do (setf (gethash k table) i)) - (let ((count 0) (found-keys)) - (with-hash-table-iterator - (%x table) - (block done - (loop - (multiple-value-bind (success key val) - (%x) - (unless success (return-from done nil)) - (incf count) - (push key found-keys) - (assert (= val (position key keys :test test-fn)))))) - (and (= count (length keys)) - (every test-fn - (sort (remove-duplicates found-keys :test test) - #'string<) - keys) - t)))))) + for test-fn of-type function = (symbol-function test) + collect + (let ((table (make-hash-table :test test))) + (loop for k in keys + for i from 0 + do (setf (gethash k table) i)) + (let ((count 0) (found-keys)) + (with-hash-table-iterator + (%x table) + (block done + (loop + (multiple-value-bind (success key val) + (%x) + (unless success (return-from done nil)) + (incf count) + (push key found-keys) + (assert (= val (position key keys :test test-fn)))))) + (and (= count (length keys)) + (every test-fn + (sort (remove-duplicates found-keys :test test) + #'string<) + keys) + t)))))) (t t t t)) (deftest with-hash-table-iterator.8 @@ -86,64 +86,64 @@ (%x (make-hash-table)) (macrolet ((expand-%x - (&environment env) - (let ((expanded-form (macroexpand '(%x) env))) - (if (equal expanded-form '(%x)) nil t)))) + (&environment env) + (let ((expanded-form (macroexpand '(%x) env))) + (if (equal expanded-form '(%x)) nil t)))) (expand-%x))) t) (deftest with-hash-table-iterator.10 (let ((table (make-hash-table))) (loop for key from 1 to 100 - for val from 101 to 200 - do (setf (gethash key table) val)) + for val from 101 to 200 + do (setf (gethash key table) val)) (let ((pairs nil)) (with-hash-table-iterator (%x table) (loop - (multiple-value-bind (success key val) - (%x) - (unless success (return nil)) - (remhash key table) - (push (cons key val) pairs)))) + (multiple-value-bind (success key val) + (%x) + (unless success (return nil)) + (remhash key table) + (push (cons key val) pairs)))) (assert (eql (length pairs) 100)) (setq pairs (sort pairs #'(lambda (p1 p2) (< (car p1) (car p2))))) (values (hash-table-count table) (loop - for (key . val) in pairs - for expected-key from 1 - for expected-val from 101 - always (and (eql key expected-key) - (eql val expected-val)))))) + for (key . val) in pairs + for expected-key from 1 + for expected-val from 101 + always (and (eql key expected-key) + (eql val expected-val)))))) 0 t) (deftest with-hash-table-iterator.11 (let ((table (make-hash-table))) (loop for key from 1 to 100 - for val from 101 to 200 - do (setf (gethash key table) val)) + for val from 101 to 200 + do (setf (gethash key table) val)) (let ((pairs nil)) (with-hash-table-iterator (%x table) (loop - (multiple-value-bind (success key val) - (%x) - (unless success (return nil)) - (setf (gethash key table) (+ 1000 val)) - (push (cons key val) pairs)))) + (multiple-value-bind (success key val) + (%x) + (unless success (return nil)) + (setf (gethash key table) (+ 1000 val)) + (push (cons key val) pairs)))) (assert (eql (length pairs) 100)) (setq pairs (sort pairs #'(lambda (p1 p2) (< (car p1) (car p2))))) (values (hash-table-count table) (loop - for (key . val) in pairs - for expected-key from 1 - for expected-val from 101 - always (and (eql key expected-key) - (eql val expected-val) - (eql (gethash key table) (+ 1000 val)) - ))))) + for (key . val) in pairs + for expected-key from 1 + for expected-val from 101 + always (and (eql key expected-key) + (eql val expected-val) + (eql (gethash key table) (+ 1000 val)) + ))))) 100 t) ;;; Free declaration scope @@ -153,6 +153,6 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (with-hash-table-iterator (m (return-from done x)) - (declare (special x)))))) + (with-hash-table-iterator (m (return-from done x)) + (declare (special x)))))) :good) diff --git a/ansi-tests/with-input-from-string.lsp b/ansi-tests/with-input-from-string.lsp index a66f3fc3..9ffb65d4 100644 --- a/ansi-tests/with-input-from-string.lsp +++ b/ansi-tests/with-input-from-string.lsp @@ -21,8 +21,8 @@ (deftest with-input-from-string.3a (with-input-from-string (s "abc") - (declare (optimize speed)) - (declare (optimize space))) + (declare (optimize speed)) + (declare (optimize space))) nil) (deftest with-input-from-string.4 @@ -183,8 +183,8 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (with-input-from-string (s (return-from done x)) - (declare (special x)))))) + (with-input-from-string (s (return-from done x)) + (declare (special x)))))) :good) (deftest with-input-from-string.20 @@ -192,8 +192,8 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (with-input-from-string (s "abc" :start (return-from done x)) - (declare (special x)))))) + (with-input-from-string (s "abc" :start (return-from done x)) + (declare (special x)))))) :good) (deftest with-input-from-string.21 @@ -201,8 +201,8 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (with-input-from-string (s "abc" :end (return-from done x)) - (declare (special x)))))) + (with-input-from-string (s "abc" :end (return-from done x)) + (declare (special x)))))) :good) ;;; index is not updated if the form exits abnormally @@ -222,22 +222,22 @@ (macrolet ((%m (z) z)) (with-input-from-string (s (expand-in-current-env (%m "123"))) - (read-char s))) + (read-char s))) #\1) (deftest with-input-from-string.24 (macrolet ((%m (z) z)) (with-input-from-string (s "123" :start (expand-in-current-env (%m 1))) - (read-char s))) + (read-char s))) #\2) (deftest with-input-from-string.25 (macrolet ((%m (z) z)) (with-input-from-string (s "123" :start 0 - :end (expand-in-current-env (%m 0))) - (read-char s nil nil))) + :end (expand-in-current-env (%m 0))) + (read-char s nil nil))) nil) diff --git a/ansi-tests/with-open-file.lsp b/ansi-tests/with-open-file.lsp index a138d82a..94140de3 100644 --- a/ansi-tests/with-open-file.lsp +++ b/ansi-tests/with-open-file.lsp @@ -63,8 +63,8 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (with-open-file (s (return-from done x)) - (declare (special x)))))) + (with-open-file (s (return-from done x)) + (declare (special x)))))) :good) (deftest with-open-file.8 @@ -72,8 +72,8 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (with-open-file (s "with-open-file.lsp" (return-from done x) :input) - (declare (special x)))))) + (with-open-file (s "with-open-file.lsp" (return-from done x) :input) + (declare (special x)))))) :good) (deftest with-open-file.9 @@ -81,8 +81,8 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (with-open-file (s "with-open-file.lsp" :direction (return-from done x)) - (declare (special x)))))) + (with-open-file (s "with-open-file.lsp" :direction (return-from done x)) + (declare (special x)))))) :good) ;;; Test that explicit calls to macroexpand in subforms @@ -93,6 +93,6 @@ ((%m (z) z)) (let ((pn #p"tmp.dat")) (delete-all-versions pn) - (with-open-file (s (expand-in-current-env (%m pn)) - :direction :output)))) + (with-open-file (s (expand-in-current-env (%m pn)) + :direction :output)))) nil) diff --git a/ansi-tests/with-open-stream.lsp b/ansi-tests/with-open-stream.lsp index 1dcf73aa..ba685b81 100644 --- a/ansi-tests/with-open-stream.lsp +++ b/ansi-tests/with-open-stream.lsp @@ -11,24 +11,24 @@ (deftest with-open-stream.2 (with-open-stream (os (make-string-output-stream)) - (declare (ignore os))) + (declare (ignore os))) nil) (deftest with-open-stream.3 (with-open-stream (os (make-string-output-stream)) - (declare (ignore os)) - (declare (type string-stream os))) + (declare (ignore os)) + (declare (type string-stream os))) nil) (deftest with-open-stream.4 (with-open-stream (os (make-string-output-stream)) - (declare (ignore os)) - (values))) + (declare (ignore os)) + (values))) (deftest with-open-stream.5 (with-open-stream (os (make-string-output-stream)) - (declare (ignore os)) - (values 'a 'b)) + (declare (ignore os)) + (values 'a 'b)) a b) (deftest with-open-stream.6 @@ -72,6 +72,6 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (with-open-stream (s (return-from done x)) - (declare (special x)))))) + (with-open-stream (s (return-from done x)) + (declare (special x)))))) :good) diff --git a/ansi-tests/with-output-to-string.lsp b/ansi-tests/with-output-to-string.lsp index c7c59ef5..ae209166 100644 --- a/ansi-tests/with-output-to-string.lsp +++ b/ansi-tests/with-output-to-string.lsp @@ -16,7 +16,7 @@ (deftest with-output-to-string.3 (with-output-to-string (s (make-array 10 :fill-pointer 0 - :element-type 'character))) + :element-type 'character))) nil) (deftest with-output-to-string.4 @@ -31,23 +31,23 @@ (deftest with-output-to-string.5 (with-output-to-string (s (make-array 10 :fill-pointer 0 - :element-type 'character)) - (values))) + :element-type 'character)) + (values))) (deftest with-output-to-string.6 (with-output-to-string (s (make-array 10 :fill-pointer 0 - :element-type 'character)) - (values 'a 'b 'c 'd)) + :element-type 'character)) + (values 'a 'b 'c 'd)) a b c d) (deftest with-output-to-string.7 (with-output-to-string (s nil :element-type 'character) - (write-char #\& s)) + (write-char #\& s)) "&") (deftest with-output-to-string.8 (let ((str (with-output-to-string (s nil :element-type 'base-char) - (write-char #\8 s)))) + (write-char #\8 s)))) (assert (typep str 'simple-base-string)) str) "8") @@ -59,11 +59,11 @@ (deftest with-output-to-string.10 (let* ((s1 (make-array 20 :element-type 'character - :initial-element #\.)) - (s2 (make-array 10 :element-type 'character - :displaced-to s1 - :displaced-index-offset 5 - :fill-pointer 0))) + :initial-element #\.)) + (s2 (make-array 10 :element-type 'character + :displaced-to s1 + :displaced-index-offset 5 + :fill-pointer 0))) (values (with-output-to-string @@ -81,7 +81,7 @@ (deftest with-output-to-string.12 (with-output-to-string (s) (declare (optimize safety)) - (declare (optimize (speed 0)))) + (declare (optimize (speed 0)))) "") (deftest with-output-to-string.13 @@ -94,13 +94,13 @@ (deftest with-output-to-string.14 (let* ((str1 (make-array '(256) :element-type 'base-char :fill-pointer 0)) - (str2 (with-output-to-string - (s nil :element-type 'base-char) - (loop for i below 256 - for c = (code-char i) - when (typep c 'base-char) - do (progn (write-char c s) - (vector-push c str1)))))) + (str2 (with-output-to-string + (s nil :element-type 'base-char) + (loop for i below 256 + for c = (code-char i) + when (typep c 'base-char) + do (progn (write-char c s) + (vector-push c str1)))))) (if (string= str1 str2) :good (list str1 str2))) :good) @@ -112,8 +112,8 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (with-output-to-string (s (return-from done x)) - (declare (special x)))))) + (with-output-to-string (s (return-from done x)) + (declare (special x)))))) :good) (deftest with-output-to-string.16 @@ -121,9 +121,9 @@ (let ((x :bad)) (declare (special x)) (let ((x :good) - (str (make-array '(10) :element-type 'character - :fill-pointer 0))) - (with-output-to-string (s str :element-type (return-from done x)) - (declare (special x)))))) + (str (make-array '(10) :element-type 'character + :fill-pointer 0))) + (with-output-to-string (s str :element-type (return-from done x)) + (declare (special x)))))) :good) diff --git a/ansi-tests/with-package-iterator.lsp b/ansi-tests/with-package-iterator.lsp index 5096eb50..81054928 100644 --- a/ansi-tests/with-package-iterator.lsp +++ b/ansi-tests/with-package-iterator.lsp @@ -67,7 +67,7 @@ t) (deftest with-package-iterator.11 - (signals-error + (signals-error (with-package-iterator (x "COMMON-LISP-USER")) program-error) t) @@ -81,8 +81,8 @@ (format t "Package ~S~%" p) (not (with-package-iterator-internal (list p)))) (error (c) - (format "Error ~S on package ~A~%" c p) - t))) + (format "Error ~S on package ~A~%" c p) + t))) 0) (deftest with-package-iterator.13 @@ -93,8 +93,8 @@ (format t "Package ~S~%" p) (not (with-package-iterator-external (list p)))) (error (c) - (format "Error ~S on package ~A~%" c p) - t))) + (format "Error ~S on package ~A~%" c p) + t))) 0) (deftest with-package-iterator.14 @@ -105,8 +105,8 @@ (format t "Package ~S~%" p) (not (with-package-iterator-inherited (list p)))) (error (c) - (format t "Error ~S on package ~S~%" c p) - t))) + (format t "Error ~S on package ~S~%" c p) + t))) 0) (def-macro-test with-package-iterator.error.1 @@ -120,59 +120,59 @@ (let ((name ,name-form)) (safely-delete-package name) (let* ((p (make-package name :use nil)) - (result nil) - (s (intern "X" p))) - (with-package-iterator - (x name :internal) - (loop - (multiple-value-bind - (good? sym) - (x) - (unless good? - (safely-delete-package name) - (return (equalt (list s) result))) - (push sym result)))))) + (result nil) + (s (intern "X" p))) + (with-package-iterator + (x name :internal) + (loop + (multiple-value-bind + (good? sym) + (x) + (unless good? + (safely-delete-package name) + (return (equalt (list s) result))) + (push sym result)))))) t)) (def-with-package-iterator-test with-package-iterator.15 (make-array 5 :initial-contents "TEST1" - :element-type 'base-char)) + :element-type 'base-char)) (def-with-package-iterator-test with-package-iterator.16 (make-array 8 :initial-contents "TEST1XXX" - :fill-pointer 5 - :element-type 'base-char)) + :fill-pointer 5 + :element-type 'base-char)) (def-with-package-iterator-test with-package-iterator.17 (make-array 8 :initial-contents "TEST1XXX" - :fill-pointer 5 - :element-type 'character)) + :fill-pointer 5 + :element-type 'character)) (def-with-package-iterator-test with-package-iterator.18 (make-array 5 :initial-contents "TEST1" - :adjustable t - :element-type 'base-char)) + :adjustable t + :element-type 'base-char)) (def-with-package-iterator-test with-package-iterator.19 (make-array 5 :initial-contents "TEST1" - :adjustable t - :element-type 'character)) + :adjustable t + :element-type 'character)) (def-with-package-iterator-test with-package-iterator.20 (let* ((etype 'base-char) - (name0 (make-array 10 :initial-contents "XTEST1YzYY" - :element-type etype))) + (name0 (make-array 10 :initial-contents "XTEST1YzYY" + :element-type etype))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 1))) + :displaced-to name0 + :displaced-index-offset 1))) (def-with-package-iterator-test with-package-iterator.21 (let* ((etype 'character) - (name0 (make-array 10 :initial-contents "XTEST1YzYY" - :element-type etype))) + (name0 (make-array 10 :initial-contents "XTEST1YzYY" + :element-type etype))) (make-array 5 :element-type etype - :displaced-to name0 - :displaced-index-offset 1))) + :displaced-to name0 + :displaced-index-offset 1))) ;;; Free declaration scope @@ -181,6 +181,6 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (with-package-iterator (s (return-from done x) :internal) - (declare (special x)))))) + (with-package-iterator (s (return-from done x) :internal) + (declare (special x)))))) :good) diff --git a/ansi-tests/with-slots.lsp b/ansi-tests/with-slots.lsp index 88aa44ce..455de611 100644 --- a/ansi-tests/with-slots.lsp +++ b/ansi-tests/with-slots.lsp @@ -32,9 +32,9 @@ (block done (tagbody (with-slots () nil - (go 10) - 10 - (return-from done :bad)) + (go 10) + 10 + (return-from done :bad)) 10 (return-from done :good))) :good) @@ -50,8 +50,8 @@ ;;; Tests on standard objects (defclass with-slots-class-01 () ((a :initarg :a) - (b :initarg :b) - (c :initarg :c))) + (b :initarg :b) + (c :initarg :c))) (deftest with-slots.7 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) @@ -63,7 +63,7 @@ (with-slots (a b c) obj (values (setf a 'p) (setf b 'q) (setf c 'r) - (map-slot-value obj '(a b c))))) + (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.9 @@ -71,7 +71,7 @@ (with-slots (a b c) obj (values (setq a 'p) (setq b 'q) (setq c 'r) - (map-slot-value obj '(a b c))))) + (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.10 @@ -84,7 +84,7 @@ (with-slots ((a2 a) (b2 b) (c2 c)) obj (values (setf a2 'p) (setf b2 'q) (setf c2 'r) - (map-slot-value obj '(a b c))))) + (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.12 @@ -92,7 +92,7 @@ (with-slots ((a2 a) (b2 b) (c2 c)) obj (values (setq a2 'p) (setq b2 'q) (setq c2 'r) - (map-slot-value obj '(a b c))))) + (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.13 @@ -100,52 +100,52 @@ (with-slots (a b c) obj (values (setf a 'p) (setf b 'q) (setf c 'r) - (map-slot-value obj '(a b c))))) + (map-slot-value obj '(a b c))))) p q r (p q r)) (deftest with-slots.14 (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3))) (with-slots (a b c) obj - (let ((obj (make-instance 'with-slots-class-01 - :a 'bad :b 'bad :c 'bad))) - (values a b c)))) + (let ((obj (make-instance 'with-slots-class-01 + :a 'bad :b 'bad :c 'bad))) + (values a b c)))) 1 2 3) (deftest with-slots.15 (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3))) (with-slots (a b c) obj - (with-slots - ((a2 a) (b2 b) (c2 c)) - (make-instance 'with-slots-class-01 - :a 'bad :b 'bad :c 'bad) - (values a b c)))) + (with-slots + ((a2 a) (b2 b) (c2 c)) + (make-instance 'with-slots-class-01 + :a 'bad :b 'bad :c 'bad) + (values a b c)))) 1 2 3) (deftest with-slots.16 (let ((obj (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 'bad))) (with-slots (a b c) obj - (with-slots - (a b c) - (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3) - (values a b c)))) + (with-slots + (a b c) + (make-instance 'with-slots-class-01 :a 1 :b 2 :c 3) + (values a b c)))) 1 2 3) (deftest with-slots.17 (let ((obj (make-instance 'with-slots-class-01 :a 1 :b 2 :c 'bad))) (with-slots (a b) obj - (with-slots - (c) - (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 3) - (values a b c)))) + (with-slots + (c) + (make-instance 'with-slots-class-01 :a 'bad :b 'bad :c 3) + (values a b c)))) 1 2 3) ;;; If slot is unbound, act as if slot-value had been called (defmethod slot-unbound ((class t) - (instance with-slots-class-01) - slot-name) + (instance with-slots-class-01) + slot-name) 'missing) (deftest with-slots.18 @@ -156,16 +156,16 @@ (deftest with-slots.19 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots (a b c) obj - (declare (optimize (speed 3) (safety 3))) - (values a b c))) + (declare (optimize (speed 3) (safety 3))) + (values a b c))) x y z) (deftest with-slots.20 (let ((obj (make-instance 'with-slots-class-01 :a 'x :b 'y :c 'z))) (with-slots (a b c) obj - (declare (optimize (speed 3) (safety 3))) - (declare (special *x*)) - (values a b c))) + (declare (optimize (speed 3) (safety 3))) + (declare (special *x*)) + (values a b c))) x y z) ;;; Free declaration scope test @@ -175,6 +175,6 @@ (let ((x :bad)) (declare (special x)) (let ((x :good)) - (with-slots nil (return-from done x) - (declare (special x)))))) - :good) \ No newline at end of file + (with-slots nil (return-from done x) + (declare (special x)))))) + :good) diff --git a/ansi-tests/write-char.lsp b/ansi-tests/write-char.lsp index 8974e85c..e7804a2d 100644 --- a/ansi-tests/write-char.lsp +++ b/ansi-tests/write-char.lsp @@ -7,13 +7,13 @@ (deftest write-char.1 (loop for i from 0 to 255 - for c = (code-char i) - when c - unless (string= (with-output-to-string - (*standard-output*) - (write-char c)) - (string c)) - collect c) + for c = (code-char i) + when c + unless (string= (with-output-to-string + (*standard-output*) + (write-char c)) + (string c)) + collect c) nil) (deftest write-char.2 diff --git a/ansi-tests/write-line.lsp b/ansi-tests/write-line.lsp index 10abecfa..17f61d79 100644 --- a/ansi-tests/write-line.lsp +++ b/ansi-tests/write-line.lsp @@ -22,8 +22,8 @@ (with-output-to-string (*standard-output*) (setq result - (multiple-value-list - (write-line (make-array '(0) :element-type nil))))) + (multiple-value-list + (write-line (make-array '(0) :element-type nil))))) result)) #.(string #\Newline) ("")) @@ -54,7 +54,7 @@ (with-output-to-string (s) (setq result (multiple-value-list - (write-line "abcde" s :start 1 :end 3)))) + (write-line "abcde" s :start 1 :end 3)))) result)) #.(concatenate 'string "bc" (string #\Newline)) ("abcde")) @@ -65,7 +65,7 @@ (with-output-to-string (s) (setq result (multiple-value-list - (write-line "abcde" s :start 1 :end nil)))) + (write-line "abcde" s :start 1 :end nil)))) result)) #.(concatenate 'string "bcde" (string #\Newline)) ("abcde")) @@ -86,7 +86,7 @@ (with-output-to-string (s) (setq result (multiple-value-list - (write-line "abcde" s :end 3 :allow-other-keys nil)))) + (write-line "abcde" s :end 3 :allow-other-keys nil)))) result)) #.(concatenate 'string "abc" (string #\Newline)) ("abcde")) @@ -97,8 +97,8 @@ (with-output-to-string (s) (setq result - (multiple-value-list - (write-line "abcde" s :end 3 :allow-other-keys t :foo 'bar)))) + (multiple-value-list + (write-line "abcde" s :end 3 :allow-other-keys t :foo 'bar)))) result)) #.(concatenate 'string "abc" (string #\Newline)) ("abcde")) @@ -109,7 +109,7 @@ (with-output-to-string (s) (setq result (multiple-value-list - (write-line "abcde" s :end 3 :end 2)))) + (write-line "abcde" s :end 3 :end 2)))) result)) #.(concatenate 'string "abc" (string #\Newline)) ("abcde")) @@ -136,10 +136,10 @@ (do-special-strings (s "abcde" nil) (assert (equal - (with-output-to-string - (*standard-output*) - (multiple-value-list (write-line "abcde"))) - #.(concatenate 'string "abcde" (string #\Newline))))) + (with-output-to-string + (*standard-output*) + (multiple-value-list (write-line "abcde"))) + #.(concatenate 'string "abcde" (string #\Newline))))) nil) ;;; Error tests @@ -158,8 +158,8 @@ (deftest write-line.error.4 (signals-error (write-line "" *standard-output* - :allow-other-keys nil - :foo nil) - program-error) + :allow-other-keys nil + :foo nil) + program-error) t) diff --git a/ansi-tests/write-sequence.lsp b/ansi-tests/write-sequence.lsp index c16ef8e5..ff3ab6f8 100644 --- a/ansi-tests/write-sequence.lsp +++ b/ansi-tests/write-sequence.lsp @@ -9,8 +9,8 @@ `(deftest ,name (let ((s ,input)) (with-output-to-string - (os) - (assert (eq (write-sequence s os ,@args) s)))) + (os) + (assert (eq (write-sequence s os ,@args) s)))) ,@expected)) ;;; on strings @@ -39,13 +39,13 @@ (defmacro def-write-sequence-special-test (name string args expected) `(deftest ,name (let ((str ,string) - (expected ,expected)) + (expected ,expected)) (do-special-strings - (s str nil) - (let ((out (with-output-to-string - (os) - (assert (eq (write-sequence s os ,@args) s))))) - (assert (equal out expected))))) + (s str nil) + (let ((out (with-output-to-string + (os) + (assert (eq (write-sequence s os ,@args) s))))) + (assert (equal out expected))))) nil)) (def-write-sequence-special-test write-sequence.string.14 "12345" () "12345") @@ -116,18 +116,18 @@ (defmacro def-write-sequence-bv-test (name input args expected) `(deftest ,name (let ((s ,input) - (expected ,expected)) + (expected ,expected)) (with-open-file - (os "tmp.dat" :direction :output - :element-type '(unsigned-byte 8) - :if-exists :supersede) - (assert (eq (write-sequence s os ,@args) s))) + (os "tmp.dat" :direction :output + :element-type '(unsigned-byte 8) + :if-exists :supersede) + (assert (eq (write-sequence s os ,@args) s))) (with-open-file - (is "tmp.dat" :direction :input - :element-type '(unsigned-byte 8)) - (loop for i from 0 below (length expected) - for e = (elt expected i) - always (eql (read-byte is) e)))) + (is "tmp.dat" :direction :input + :element-type '(unsigned-byte 8)) + (loop for i from 0 below (length expected) + for e = (elt expected i) + always (eql (read-byte is) e)))) t)) (def-write-sequence-bv-test write-sequence.bv.1 #*00111010 @@ -172,54 +172,54 @@ (deftest write-sequence.error.7 (signals-error (write-sequence "ABC" *standard-output* :start 0.0) - type-error) + type-error) t) (deftest write-sequence.error.8 (signals-error (write-sequence "ABC" *standard-output* :end -1) - type-error) + type-error) t) (deftest write-sequence.error.9 (signals-error (write-sequence "ABC" *standard-output* :end 'x) - type-error) + type-error) t) (deftest write-sequence.error.10 (signals-error (write-sequence "ABC" *standard-output* :end 2.0) - type-error) + type-error) t) (deftest write-sequence.error.11 (signals-error (write-sequence "abcde" *standard-output* - :foo nil) program-error) + :foo nil) program-error) t) - + (deftest write-sequence.error.12 (signals-error (write-sequence "abcde" *standard-output* - :allow-other-keys nil :foo t) - program-error) + :allow-other-keys nil :foo t) + program-error) t) (deftest write-sequence.error.13 (signals-error (write-sequence "abcde" *standard-output* :start) - program-error) + program-error) t) (deftest write-sequence.error.14 (check-type-error #'(lambda (x) (write-sequence x *standard-output*)) - #'sequencep) + #'sequencep) nil) (deftest write-sequence.error.15 (check-type-error #'(lambda (x) (write-sequence "abcde" *standard-output* - :start x)) - (typef 'unsigned-byte)) + :start x)) + (typef 'unsigned-byte)) nil) (deftest write-sequence.error.16 (check-type-error #'(lambda (x) (write-sequence "abcde" *standard-output* - :end x)) - (typef '(or null unsigned-byte))) + :end x)) + (typef '(or null unsigned-byte))) nil) diff --git a/ansi-tests/write-string.lsp b/ansi-tests/write-string.lsp index 9d3bf82c..e2b1c09a 100644 --- a/ansi-tests/write-string.lsp +++ b/ansi-tests/write-string.lsp @@ -21,8 +21,8 @@ (with-output-to-string (*standard-output*) (setq result - (multiple-value-list - (write-string (make-array '(0) :element-type nil))))) + (multiple-value-list + (write-string (make-array '(0) :element-type nil))))) result)) "" ("")) @@ -50,7 +50,7 @@ (with-output-to-string (s) (setq result (multiple-value-list - (write-string "abcde" s :start 1 :end 3)))) + (write-string "abcde" s :start 1 :end 3)))) result)) "bc" ("abcde")) @@ -60,7 +60,7 @@ (with-output-to-string (s) (setq result (multiple-value-list - (write-string "abcde" s :start 1 :end nil)))) + (write-string "abcde" s :start 1 :end nil)))) result)) "bcde" ("abcde")) @@ -79,7 +79,7 @@ (with-output-to-string (s) (setq result (multiple-value-list - (write-string "abcde" s :end 3 :allow-other-keys nil)))) + (write-string "abcde" s :end 3 :allow-other-keys nil)))) result)) "abc" ("abcde")) @@ -89,8 +89,8 @@ (with-output-to-string (s) (setq result - (multiple-value-list - (write-string "abcde" s :end 3 :allow-other-keys t :foo 'bar)))) + (multiple-value-list + (write-string "abcde" s :end 3 :allow-other-keys t :foo 'bar)))) result)) "abc" ("abcde")) @@ -100,7 +100,7 @@ (with-output-to-string (s) (setq result (multiple-value-list - (write-string "abcde" s :end 3 :end 2)))) + (write-string "abcde" s :end 3 :end 2)))) result)) "abc" ("abcde")) @@ -127,10 +127,10 @@ (do-special-strings (s "abcde" nil) (assert (equal - (with-output-to-string - (*standard-output*) - (setq result (multiple-value-list (write-string "abcde")))) - "abcde")) + (with-output-to-string + (*standard-output*) + (setq result (multiple-value-list (write-string "abcde")))) + "abcde")) (assert (equal result '("abcde"))))) nil) @@ -150,7 +150,7 @@ (deftest write-string.error.4 (signals-error (write-string "" *standard-output* - :allow-other-keys nil - :foo nil) - program-error) + :allow-other-keys nil + :foo nil) + program-error) t) diff --git a/ansi-tests/write.lsp b/ansi-tests/write.lsp index 79923570..de516651 100644 --- a/ansi-tests/write.lsp +++ b/ansi-tests/write.lsp @@ -28,9 +28,9 @@ (with-output-to-string (os) (with-input-from-string - (is "") - (with-open-stream (*terminal-io* (make-two-way-stream is os)) - (write 3 :stream t)))))) + (is "") + (with-open-stream (*terminal-io* (make-two-way-stream is os)) + (write 3 :stream t)))))) "3") (deftest write.4 diff --git a/ansi-tests/zerop.lsp b/ansi-tests/zerop.lsp index bc12c1d6..53068c60 100644 --- a/ansi-tests/zerop.lsp +++ b/ansi-tests/zerop.lsp @@ -23,8 +23,8 @@ (deftest zerop.1 (loop for x in *numbers* - when (if (zerop x) (/= x 0) (= x 0)) - collect x) + when (if (zerop x) (/= x 0) (= x 0)) + collect x) nil) (deftest zerop.2 @@ -57,34 +57,34 @@ (deftest zerop.8 (remove-if-not #'zerop - (list least-negative-short-float - least-negative-normalized-short-float - least-negative-single-float - least-negative-normalized-single-float - least-negative-double-float - least-negative-normalized-double-float - least-negative-long-float - least-negative-normalized-long-float - most-negative-short-float - most-negative-single-float - most-negative-double-float - most-negative-long-float)) + (list least-negative-short-float + least-negative-normalized-short-float + least-negative-single-float + least-negative-normalized-single-float + least-negative-double-float + least-negative-normalized-double-float + least-negative-long-float + least-negative-normalized-long-float + most-negative-short-float + most-negative-single-float + most-negative-double-float + most-negative-long-float)) nil) (deftest zerop.9 (remove-if-not #'zerop - (list least-positive-short-float - least-positive-normalized-short-float - least-positive-single-float - least-positive-normalized-single-float - least-positive-double-float - least-positive-normalized-double-float - least-positive-long-float - least-positive-normalized-long-float - most-positive-short-float - most-positive-single-float - most-positive-double-float - most-positive-long-float)) + (list least-positive-short-float + least-positive-normalized-short-float + least-positive-single-float + least-positive-normalized-single-float + least-positive-double-float + least-positive-normalized-double-float + least-positive-long-float + least-positive-normalized-long-float + most-positive-short-float + most-positive-single-float + most-positive-double-float + most-positive-long-float)) nil) (deftest zerop.10 -- GitLab