X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fmap-tests.impure.lisp;h=ec999b5501a69b72256a2aa5aa60165b8f0a68d6;hb=6d36f2d6954cb79e3c88fef33fe0c3ad63deaea8;hp=76ee56663ac269ec134c79c497d7241a5ef1aaa0;hpb=e4eb979046e594444cf5972801ea5f4a5eb1a7c7;p=sbcl.git diff --git a/tests/map-tests.impure.lisp b/tests/map-tests.impure.lisp index 76ee566..ec999b5 100644 --- a/tests/map-tests.impure.lisp +++ b/tests/map-tests.impure.lisp @@ -1,29 +1,41 @@ -(cl:in-package :cl-user) +;;;; side-effectful tests of MAP-related stuff + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. (load "assertoid.lisp") +(use-package "ASSERTOID") ;;; tests of MAP ;;; FIXME: Move these into their own file. (assertoid (map 'vector #'+ '(1 2 3) '(30 20)) - :expected-equalp #(31 22)) + :expected-equalp #(31 22)) (assertoid (map 'list #'+ #(1 2) '(100) #(0) #(100 100)) - :expected-equal '(201)) + :expected-equal '(201)) (defmacro with-mapnil-test-fun (fun-name &body body) `(let ((reversed-result nil)) (flet ((,fun-name (&rest rest) - (push rest reversed-result))) + (push rest reversed-result))) ,@body (nreverse reversed-result)))) (assertoid (with-mapnil-test-fun fun - (map nil #'fun #(1))) - :expected-equal '((1))) + (map nil #'fun #(1))) + :expected-equal '((1))) (assertoid (with-mapnil-test-fun fun - (map nil #'fun #() '(1 2 3))) - :expected-equal '()) + (map nil #'fun #() '(1 2 3))) + :expected-equal '()) (assertoid (with-mapnil-test-fun fun - (map nil #'fun #(a b c) '(alpha beta) '(aleph beth))) - :expected-equal '((a alpha aleph) (b beta beth))) + (map nil #'fun #(a b c) '(alpha beta) '(aleph beth))) + :expected-equal '((a alpha aleph) (b beta beth))) ;;; Exercise MAP repeatedly on the same dataset by providing various ;;; combinations of sequence type arguments, declarations, and so @@ -36,68 +48,64 @@ (defvar *vector-20* #(10 20)) (defvar *vector-30* #(10 20 30)) (defmacro maptest (&key - result-seq - fun-name - arg-seqs - arg-types - (result-element-types '(t))) + result-seq + fun-name + arg-seqs + arg-types + (result-element-types '(t))) (let ((reversed-assertoids nil)) (dotimes (arg-type-index (expt 2 (length arg-types))) (labels (;; Arrange for EXPR to be executed. - (arrange (expr) - (push expr reversed-assertoids)) - ;; We toggle the various type declarations on and - ;; off depending on the bit pattern in ARG-TYPE-INDEX, - ;; so that we get lots of different things to test. - (eff-arg-type (i) - (if (and (< i (length arg-types)) - (plusp (logand (expt 2 i) - arg-type-index))) - (nth i arg-types) - t)) - (args-with-type-decls () - (let ((reversed-result nil)) - (dotimes (i (length arg-seqs) (nreverse reversed-result)) - (push `(the ,(eff-arg-type i) - ,(nth i arg-seqs)) - reversed-result))))) - (dolist (fun `(',fun-name #',fun-name)) - (dolist (result-type (cons 'list - (mapcan (lambda (et) - `((vector ,et) - (simple-array ,et 1))) - result-element-types))) - (arrange - `(assertoid (map ',result-type ,fun ,@(args-with-type-decls)) - :expected-equalp (coerce ,result-seq - ',result-type))))) - (arrange - `(assertoid (mapcar (lambda (args) (apply #',fun-name args)) - (with-mapnil-test-fun mtf - (map nil - ;; (It would be nice to test MAP - ;; NIL with function names, too, - ;; but I can't see any concise way - ;; to do it..) - #'mtf - ,@(args-with-type-decls)))) - :expected-equal (coerce ,result-seq 'list))))) + (arrange (expr) + (push expr reversed-assertoids)) + ;; We toggle the various type declarations on and + ;; off depending on the bit pattern in ARG-TYPE-INDEX, + ;; so that we get lots of different things to test. + (eff-arg-type (i) + (if (and (< i (length arg-types)) + (plusp (logand (expt 2 i) + arg-type-index))) + (nth i arg-types) + t)) + (args-with-type-decls () + (let ((reversed-result nil)) + (dotimes (i (length arg-seqs) (nreverse reversed-result)) + (push `(the ,(eff-arg-type i) + ,(nth i arg-seqs)) + reversed-result))))) + (dolist (fun `(',fun-name #',fun-name)) + (dolist (result-type (cons 'list + (mapcan (lambda (et) + `((vector ,et) + (simple-array ,et 1))) + result-element-types))) + (arrange + `(assertoid (map ',result-type ,fun ,@(args-with-type-decls)) + :expected-equalp (coerce ,result-seq + ',result-type))))) + (arrange + `(assertoid (mapcar (lambda (args) (apply #',fun-name args)) + (with-mapnil-test-fun mtf + (map nil + ;; (It would be nice to test MAP + ;; NIL with function names, too, + ;; but I can't see any concise way + ;; to do it..) + #'mtf + ,@(args-with-type-decls)))) + :expected-equal (coerce ,result-seq 'list))))) `(progn ,@(nreverse reversed-assertoids)))) (maptest :result-seq '(2 3) - :fun-name 1+ - :arg-seqs (*list-2*) - :arg-types (list)) + :fun-name 1+ + :arg-seqs (*list-2*) + :arg-types (list)) (maptest :result-seq '(nil nil nil) - :fun-name oddp - :arg-seqs (*vector-30*) - :arg-types (vector)) + :fun-name oddp + :arg-seqs (*vector-30*) + :arg-types (vector)) (maptest :result-seq '(12 24) - :fun-name + - :arg-seqs (*list-2* *list-2* *vector-30*) - :arg-types (list list vector)) + :fun-name + + :arg-seqs (*list-2* *list-2* *vector-30*) + :arg-types (list list vector)) -(print "returning successfully") -(terpri) -;;(sb-impl::flush-standard-output-streams) -;;(finish-output) -(quit :unix-status 104) +;;; success