125 lines
3.8 KiB
Plaintext
125 lines
3.8 KiB
Plaintext
;; Function To Be Tested: vectorp
|
|
;;
|
|
;; Source: CLtL p. 75
|
|
;;
|
|
;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates
|
|
;;
|
|
;; Created By: Peter Reidy
|
|
;;
|
|
;; Creation Date: 22 September 86
|
|
;;
|
|
;; Last Update: 15 December 86
|
|
;;
|
|
;; Filed As: {eris}<lispcore>cml>test>6-2-2-vectorp.test
|
|
;;
|
|
;; Syntax: vectorp object
|
|
;;
|
|
;; Function Description: Returns non-nil iff object is a vector (a one-dimensional array), and NIL otherwise.
|
|
;;
|
|
;; Argument(s): object any cml object
|
|
;;
|
|
;; Returns: non-nil or NIL
|
|
;;
|
|
(do-test-group vectorp-group
|
|
:before
|
|
(test-defun vectorptest (object &optional (expected-value nil))
|
|
"See if (vectorp object) <=> (typep object 'vector); see if the predicate is true or false of the object, depending on the expected value; see if a vector is a one-dimensional array."
|
|
(let ((val (vectorp object)))
|
|
(and
|
|
;; Test equivalence of vectorp to typep...'vector.
|
|
(eq val (typep object 'vector))
|
|
;; non-nil for true cases, NIL for others.
|
|
(cond
|
|
(expected-value
|
|
val)
|
|
(t (null val))
|
|
) ; cond
|
|
;; Vectors are one-dimensional arrays.
|
|
(cond
|
|
(expected-value
|
|
;; The caller had better not pass anything but an array when expected-value is non-nil.
|
|
(eq 1 (array-rank object))
|
|
)
|
|
;; Non-arrays are moot.
|
|
(t t)
|
|
) ; cond
|
|
) ; and
|
|
) ; let
|
|
) ; test-defun
|
|
;;
|
|
(do-test vectorp-with-vectors-test
|
|
(every #'(lambda (object) (vectorptest object t))
|
|
(list
|
|
'#()
|
|
'#(1 2 3 (list 1 2 3 #(1 2 3)) #(4 5 6))
|
|
'#(1 0 0 1 1)
|
|
(vector)
|
|
(vector 1 2 3 4 5 6 7)
|
|
(make-array (list 7))
|
|
(make-array (+ 10 (random 100)) :displaced-to
|
|
(make-array (+ 100 (random 100)) :displaced-to
|
|
(make-array 300 :element-type '(or readtable string-char) :initial-element (copy-readtable)
|
|
)
|
|
)
|
|
:adjustable t :displaced-index-offset (random 10) :fill-pointer (random 5)
|
|
) ; make-array
|
|
) ; list
|
|
) ; every
|
|
) ; do-test vectorp-with-vectors-test
|
|
;; All strings are vectors
|
|
(do-test vectorp-with-strings-test
|
|
(every #'(lambda (object) (vectorptest object t))
|
|
(list
|
|
"string"
|
|
(symbol-name 'string)
|
|
(symbol-name (gensym))
|
|
(symbol-name (gentemp))
|
|
(symbol-name (make-symbol "string"))
|
|
(make-string (random 1000))
|
|
(make-string (random 1000) :initial-element #\$)
|
|
(make-array 1 :element-type 'string-char)
|
|
(make-array 1 :adjustable t :element-type 'string-char)
|
|
(make-array 20 :initial-element #\} :element-type 'string-char)
|
|
(make-array 20 :element-type 'string-char :initial-contents '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 #\a #\b #\c #\d #\e #\A #\B #\C #\D #\E))
|
|
) ; list
|
|
) ; every
|
|
) ; do-test vectorp-with-strings-test
|
|
;; All bit-vectors are vectors
|
|
(do-test vectorp-with-bit-vectors-test
|
|
(every #'(lambda (object) (vectorptest object t))
|
|
(list
|
|
#*1000010101101111111
|
|
(make-array 500 :element-type 'bit)
|
|
(bit-andc2 (make-array 12 :element-type 'bit) #*000100101110)
|
|
) ; list
|
|
) ; every
|
|
) ; do-test vectorp-with-bit-vectors-test
|
|
;;
|
|
;; Multi-dimensional arrays don't qualify.
|
|
(do-test vectorp-with-multi-dimensional-arrays-test
|
|
(every 'vectorptest (list
|
|
(make-array '(6 1))
|
|
(make-array (list (random (- array-dimension-limit 1)) 1) :element-type 'bit)
|
|
(make-array (list 1 (random (1- array-dimension-limit 1))) :element-type 'bit)
|
|
(make-array '(2 2) :adjustable t)
|
|
) ; list
|
|
) ; every
|
|
) ; do-test vectorp-with-multi-dimensional-arrays-test
|
|
;;
|
|
;; Symbols aren't strings, so a fortiori they aren't vectors.
|
|
(do-test vectorp-with-symbols-test
|
|
(every 'vectorptest
|
|
(list
|
|
'string
|
|
(gensym)
|
|
(gentemp)
|
|
(make-symbol "string")
|
|
(make-symbol (make-array 20 :element-type 'string-char :fill-pointer (random 20) :initial-element #\a))
|
|
(make-symbol (symbol-name (gentemp)))
|
|
) ; list
|
|
) ; every
|
|
) ; do-test vectorp-with-symbols-test
|
|
) ; do-test-group
|
|
STOP
|
|
|