Commit 9e6cc5a6 authored by pfdietz's avatar pfdietz

Added tests for GENTEMP

parent 7366b4da
......@@ -1045,3 +1045,10 @@ the condition to go uncaught if it cannot be classified."
:fill ,fill :adjust ,adjust
:etype ,etype :displace ,displace)))
,@forms))))))))
;;; Return T if arg X is a string designator in this implementation
(defun string-designator-p (x)
(handler-case
(progn (string x) t)
(error nil)))
......@@ -5,4 +5,127 @@
(in-package :cl-test)
(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)))
))
(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)))
))
(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)))
))
(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)))
))
(delete-package package-name)))
t t t t)
(deftest gentemp.5
(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)))
))
(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))))
(delete-package package-name)))
t)
;;; Error tests
(deftest gentemp.error.1
(loop for x in *mini-universe*
unless (or (stringp x)
(eql (eval `(signals-error (gentemp ',x) type-error)) 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-error (gentemp "T" ',x) type-error)) t))
collect x)
nil)
(deftest gentemp.error.3
(signals-error (gentemp "" *package* nil) program-error)
t)
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment