108 lines
3.8 KiB
Plaintext
108 lines
3.8 KiB
Plaintext
;; Function To Be Tested: simple-string-p
|
|
;;
|
|
;; Source: CLtL p. 75
|
|
;;
|
|
;; Chapter 6: Predicates Section 2-2: Specific Data Type Predicates
|
|
;;
|
|
;; Created By: Peter Reidy
|
|
;;
|
|
;; Creation Date: 21 September 86
|
|
;;
|
|
;; Last Update: 15 December 86
|
|
;;
|
|
;; Filed As: {eris}<lispcore>cml>test>6-2-2-simple-string-p.test
|
|
;;
|
|
;; Syntax: simple-string-p object
|
|
;;
|
|
;; Function Description: Returns non-nil iff object is a string (a one-dimensional simple array [i.e. not displaced or adjustable, and without a fill-pointer] of type string-char), and NIL otherwise.
|
|
;;
|
|
;; Argument(s): object any cml object
|
|
;;
|
|
;; Returns: non-nil or NIL
|
|
;;
|
|
(do-test-group simple-string-p-group
|
|
:before
|
|
(test-defun simple-string-ptest (object &optional (expected-value nil))
|
|
"See if the predicate is equivalent to (typep object 'simple-string); see if it's true or false of object, depending on expected-value; see if the object and its content are of the right types."
|
|
(let ((val (simple-string-p object)))
|
|
(and
|
|
;; Test equivalence of simple-string-p to typep...'simple-string.
|
|
(eq val (typep object 'simple-string))
|
|
(cond
|
|
(expected-value val)
|
|
(t (null val))
|
|
) ; cond
|
|
;; Strings are one-dimensional arrays of type string-char.
|
|
(eq val (typep object '(array string-char (*))))
|
|
;; Strings are vectors of type string-char.
|
|
(eq val (typep object '(vector string-char)))
|
|
;; If the object is an array, see if it's the right kind of array.
|
|
(cond
|
|
(expected-value
|
|
(and
|
|
(= 1 (array-rank object))
|
|
;; The type must at least be consistent with 'string-char.
|
|
(subtypep 'string-char (array-element-type object))
|
|
) ; and
|
|
)
|
|
;; Other objects get this for free.
|
|
(t t)
|
|
) ; cond
|
|
) ; and
|
|
) ; let
|
|
) ; test-defun
|
|
;;
|
|
(do-test simple-string-p-with-simple-strings-test
|
|
(every #'(lambda (object) (simple-string-ptest object t)) (list
|
|
"string"
|
|
;; symbol-name does not return a simple 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 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 simple-string-p-with-simple-strings-test
|
|
;;
|
|
;; Non-simple strings don't qualify.
|
|
|
|
;; Should be notany here
|
|
(do-test simple-string-p-with-non-simple-strings-test
|
|
(notany 'simple-string-ptest (list
|
|
(make-array (- array-rank-limit 1) :element-type 'string-char :displaced-to (make-array (- array-rank-limit 1) :element-type 'string-char))
|
|
(make-array (- array-rank-limit 1) :element-type 'string-char :fill-pointer 10)
|
|
(make-array (- array-rank-limit 1) :element-type 'string-char :adjustable t)
|
|
) ; list
|
|
) ; notany
|
|
) ; do-test simple-string-p-with-non-simple-strings-test
|
|
;;
|
|
;; Symbols aren't strings, so a fortiori they aren't simple-strings.
|
|
(do-test simple-string-p-with-symbols-test
|
|
(every 'simple-string-ptest (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 simple-string-p-with-symbols-test
|
|
;;
|
|
;; Only one-dimensional string-char arrays are simple strings.
|
|
(do-test simple-string-p-with-non-string-arrays-test
|
|
(every 'simple-string-ptest (list
|
|
(make-array 6 :initial-contents '(#\s #\t #\r #\i #\n #\g))
|
|
(make-array '(6 1) :element-type 'string-char)
|
|
) ; list
|
|
) ; every
|
|
) ; do-test simple-string-p-with-non-string-arrays-test
|
|
) ; do-test-group
|
|
STOP
|
|
|