tests/seq.impure.lisp

   1 ;;;; tests related to sequences
   2
   3 ;;;; This file is impure because we want to be able to use DEFUN.
   4
   5 ;;;; This software is part of the SBCL system. See the README file for
   6 ;;;; more information.
   7 ;;;;
   8 ;;;; While most of SBCL is derived from the CMU CL system, the test
   9 ;;;; files (like this one) were written from scratch after the fork
  10 ;;;; from CMU CL.
  11 ;;;;
  12 ;;;; This software is in the public domain and is provided with
  13 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  14 ;;;; more information.
  15
  16 (in-package :cl-user)
  17
  18 ;;; helper functions for exercising SEQUENCE code on data of many
  19 ;;; specialized types, and in many different optimization scenarios
  20 (defun for-every-seq-1 (base-seq snippet)
  21   (dolist (seq-type '(list
  22                       (simple-array t 1)
  23                       (vector t)
  24                       (simple-array character 1)
  25                       (vector character)
  26                       (simple-array (signed-byte 4) 1)
  27                       (vector (signed-byte 4))))
  28     (flet ((entirely (eltype)
  29              (every (lambda (el) (typep el eltype)) base-seq)))
  30       (dolist (declaredness '(nil t))
  31         (dolist (optimization '(((speed 3) (space 0))
  32                                 ((speed 2) (space 2))
  33                                 ((speed 1) (space 2))
  34                                 ((speed 0) (space 1))))
  35           (let* ((seq (if (eq seq-type 'list)
  36                           (coerce base-seq 'list)
  37                           (destructuring-bind (type-first &rest type-rest)
  38                               seq-type
  39                             (ecase type-first
  40                               (simple-array
  41                                (destructuring-bind (eltype one) type-rest
  42                                  (assert (= one 1))
  43                                  (if (entirely eltype)
  44                                      (coerce base-seq seq-type)
  45                                      (return))))
  46                               (vector
  47                                (destructuring-bind (eltype) type-rest
  48                                  (if (entirely eltype)
  49                                      (let ((initial-element
  50                                             (cond ((subtypep eltype 'character)
  51                                                    #\!)
  52                                                   ((subtypep eltype 'number)
  53                                                    0)
  54                                                   (t #'error))))
  55                                        (replace (make-array
  56                                                  (+ (length base-seq)
  57                                                     (random 3))
  58                                                  :element-type eltype
  59                                                  :fill-pointer
  60                                                  (length base-seq)
  61                                                  :initial-element
  62                                                  initial-element)
  63                                                 base-seq))
  64                                      (return))))))))
  65                  (lambda-expr `(lambda (seq)
  66                                  ,@(when declaredness
  67                                      `((declare (type ,seq-type seq))))
  68                                  (declare (optimize ,@optimization))
  69                                  ,snippet)))
  70             (format t "~&~S~%" lambda-expr)
  71             (multiple-value-bind (fun warnings-p failure-p)
  72                 (compile nil lambda-expr)
  73               (when (or warnings-p failure-p)
  74                 (error "~@<failed compilation:~2I ~_LAMBDA-EXPR=~S ~_WARNINGS-P=~S ~_FAILURE-P=~S~:@>"
  75                        lambda-expr warnings-p failure-p))
  76               (format t "~&~S ~S ~S ~S ~S~%"
  77                       base-seq snippet seq-type declaredness optimization)
  78               (format t "~&(TYPEP SEQ 'SIMPLE-ARRAY)=~S~%"
  79                       (typep seq 'simple-array))
  80               (unless (funcall fun seq)
  81                 (error "~@<failed test:~2I ~_BASE-SEQ=~S ~_SNIPPET=~S ~_SEQ-TYPE=~S ~_DECLAREDNESS=~S ~_OPTIMIZATION=~S~:@>"
  82                        base-seq
  83                        snippet
  84                        seq-type
  85                        declaredness
  86                        optimization)))))))))
  87 (defun for-every-seq (base-seq snippets)
  88   (dolist (snippet snippets)
  89     (for-every-seq-1 base-seq snippet)))
  90
  91 ;;; a wrapper to hide declared type information from the compiler, so
  92 ;;; we don't get stopped by compiler warnings about e.g. compiling
  93 ;;; (POSITION 1 #() :KEY #'ABS) when #() has been coerced to a string.
  94 (defun indiscriminate (fun)
  95   (lambda (&rest rest) (apply fun rest)))
  96
  97 ;;; asymmetric test arg order example from ANSI FIND definition page
  98 (assert (eql #\space ; original example, depends on ASCII character ordering
  99              (find #\d "here are some letters that can be looked at"
 100                    :test #'char>)))
 101 (assert (eql #\e ; modified example, depends only on standard a-z ordering
 102              (find #\f "herearesomeletters" :test #'char>)))
 103 (assert (eql 4 ; modified more, avoids charset technicalities completely
 104              (find 5 '(6 4) :test '>)))
 105
 106 ;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for
 107 ;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too)
 108 (for-every-seq #()
 109   '((null (find 1 seq))
 110     (null (find 1 seq :from-end t))
 111     (null (position 1 seq :key (indiscriminate #'abs)))
 112     (null (position nil seq :test (constantly t)))
 113     (null (position nil seq :test nil))
 114     (null (position nil seq :test-not nil))
 115     (null (find-if #'1+ seq :key (indiscriminate #'log)))
 116     (null (position-if #'identity seq :from-end t))
 117     (null (find-if-not #'packagep seq))
 118     (null (position-if-not #'packagep seq :key nil))))
 119 (for-every-seq #(1)
 120   '((null (find 2 seq))
 121     ;; Get the argument ordering for asymmetric tests like #'> right.
 122     ;; (bug reported and fixed by Alexey Dejneka sbcl-devel 2001-10-17)
 123     (eql 1 (find 2 seq :test #'>))
 124     (find 2 seq :key #'1+)
 125     (find 1 seq :from-end t)
 126     (null (find 1 seq :from-end t :start 1))
 127     (null (find 0 seq :from-end t))
 128     (eql 0 (position 1 seq :key #'abs))
 129     (null (position nil seq :test 'equal))
 130     (eql 1 (find-if #'1- seq :key #'log))
 131     (eql 0 (position-if #'identity seq :from-end t))
 132     (null (find-if-not #'sin seq))
 133     (eql 0 (position-if-not #'packagep seq :key 'identity))))
 134 (for-every-seq #(1 2 3 2 1)
 135   '((find 3 seq)
 136     (find 3 seq :from-end 'yes)
 137     (eql 1 (position 1.5 seq :test #'<))
 138     (eql 0 (position 0 seq :key '1-))
 139     (eql 4 (position 0 seq :key '1- :from-end t))
 140     (eql 2 (position 4 seq :key '1+))
 141     (eql 2 (position 4 seq :key '1+ :from-end t))
 142     (eql 1 (position 2 seq))
 143     (eql 1 (position 2 seq :start 1))
 144     (null (find 2 seq :start 1 :end 1))
 145     (eql 3 (position 2 seq :start 2))
 146     (eql 3 (position 2 seq :key nil :from-end t))
 147     (eql 2 (position 3 seq :test '=))
 148     (eql 0 (position 3 seq :test-not 'equalp))
 149     (eql 2 (position 3 seq :test 'equal :from-end t))
 150     (null (position 4 seq :test #'eql))
 151     (null (find-if #'packagep seq))
 152     (eql 1 (find-if #'plusp seq))
 153     (eql 3 (position-if #'plusp seq :key #'1- :from-end t))
 154     (eql 1 (position-if #'evenp seq))
 155     (eql 3 (position-if #'evenp seq :from-end t))
 156     (eql 2 (position-if #'plusp seq :from-end nil :key '1- :start 2))
 157     (eql 3 (position-if #'plusp seq :from-end t :key '1- :start 2))
 158     (null (position-if #'plusp seq :from-end t :key '1- :start 2 :end 2))
 159     (null (find-if-not #'plusp seq))
 160     (eql 0 (position-if-not #'evenp seq))))
 161 (for-every-seq "string test"
 162   '((null (find 0 seq))
 163     (null (find #\D seq :key #'char-upcase))
 164     (find #\E seq :key #'char-upcase)
 165     (null (find #\e seq :key #'char-upcase))
 166     (eql 3 (position #\i seq))
 167     (eql 0 (position #\s seq :key #'char-downcase))
 168     (eql 1 (position #\s seq :key #'char-downcase :test #'char/=))
 169     (eql 9 (position #\s seq :from-end t :test #'char=))
 170     (eql 10 (position #\s seq :from-end t :test #'char/=))
 171     (eql 4 (position #\N seq :from-end t :key 'char-upcase :test #'char-equal))
 172     (eql 5 (position-if (lambda (c) (equal #\g c)) seq))
 173     (eql 5 (position-if (lambda (c) (equal #\g c)) seq :from-end t))
 174     (find-if #'characterp seq)
 175     (find-if (lambda (c) (typep c 'base-char)) seq :from-end t)
 176     (null (find-if 'upper-case-p seq))))
 177
 178 ;;; SUBSEQ
 179 (let ((avec (make-array 10
 180                         :fill-pointer 4
 181                         :initial-contents '(0 1 2 3 iv v vi vii iix ix))))
 182   ;; These first five always worked AFAIK.
 183   (assert (equalp (subseq avec 0 3) #(0 1 2)))
 184   (assert (equalp (subseq avec 3 3) #()))
 185   (assert (equalp (subseq avec 1 3) #(1 2)))
 186   (assert (equalp (subseq avec 1) #(1 2 3)))
 187   (assert (equalp (subseq avec 1 4) #(1 2 3)))
 188   ;; SBCL bug found ca. 2002-05-01 by OpenMCL's correct handling of
 189   ;; SUBSEQ, CSR's driving portable cross-compilation far enough to
 190   ;; reach the SUBSEQ calls in assem.lisp, and WHN's sleazy
 191   ;; translation of old CMU CL new-assem.lisp into sufficiently grotty
 192   ;; portable Lisp that it passed suitable illegal values to SUBSEQ to
 193   ;; exercise the bug:-|
 194   ;;
 195   ;; SUBSEQ should check its END value against logical LENGTH, not
 196   ;; physical ARRAY-DIMENSION 0.
 197   ;;
 198   ;; fixed in sbcl-0.7.4.22 by WHN
 199   (assert (null (ignore-errors (subseq avec 1 5)))))
 200
 201 ;;; success
 202 (quit :unix-status 104)