From 9c47a7a85ea309985d0b980f25d489ff03abd451 Mon Sep 17 00:00:00 2001 From: pfdietz Date: Wed, 14 Jan 2004 01:42:21 +0000 Subject: [PATCH] More files tests, and added more logical pathname tests. We make an assumption that the CLTEST logical host can be defined to be the directory containing this test suite. More progv tests inspired by random test failures. --- ansi-tests/delete-file.lsp | 81 ++++++++++++++++++++++ ansi-tests/directory.lsp | 18 ++++- ansi-tests/ensure-directories-exist.lsp | 3 +- ansi-tests/file-author.lsp | 3 + ansi-tests/file-error.lsp | 89 +++++++++++++++++++++++++ ansi-tests/file-write-date.lsp | 5 +- ansi-tests/load-files.lsp | 3 +- ansi-tests/pathnames-aux.lsp | 9 +++ ansi-tests/probe-file.lsp | 19 ++++-- ansi-tests/progv.lsp | 10 +++ ansi-tests/random-int-form.lsp | 43 +++++++----- ansi-tests/rename-file.lsp | 39 +++++++++-- ansi-tests/truename.lsp | 15 +++++ ansi-tests/universe.lsp | 16 +++-- 14 files changed, 314 insertions(+), 39 deletions(-) create mode 100644 ansi-tests/delete-file.lsp create mode 100644 ansi-tests/file-error.lsp diff --git a/ansi-tests/delete-file.lsp b/ansi-tests/delete-file.lsp new file mode 100644 index 0000000..6692c02 --- /dev/null +++ b/ansi-tests/delete-file.lsp @@ -0,0 +1,81 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 13 18:42:29 2004 +;;;; Contains: Tests for DELETE-FILE + +(in-package :cl-test) + +(deftest delete-file.1 + (let ((pn "scratchfile.txt")) + (unless (probe-file pn) + (with-open-file (s pn :direction :output) + (format s "Contents~%"))) + (values + (notnot (probe-file pn)) + (multiple-value-list (delete-file pn)) + (probe-file pn))) + t (t) nil) + +(deftest delete-file.2 + (let ((pn #p"scratchfile.txt")) + (unless (probe-file pn) + (with-open-file (s pn :direction :output) + (format s "Contents~%"))) + (values + (notnot (probe-file pn)) + (multiple-value-list (delete-file pn)) + (probe-file pn))) + t (t) nil) + +(deftest delete-file.3 + (let ((pn "CLTEST:scratchfile.txt")) + (unless (probe-file pn) + (with-open-file (s pn :direction :output) + (format s "Contents~%"))) + (values + (notnot (probe-file pn)) + (multiple-value-list (delete-file pn)) + (probe-file pn))) + t (t) nil) + +(deftest delete-file.4 + (let ((pn "CLTEST:scratchfile.txt")) + (unless (probe-file pn) + (with-open-file (s pn :direction :output) + (format s "Contents~%"))) + (let ((s (open pn :direction :input))) + (close s) + (values + (notnot (probe-file pn)) + (multiple-value-list (delete-file s)) + (probe-file pn)))) + t (t) nil) + +;;; + +(deftest delete-file.error.1 + (classify-error (delete-file)) + program-error) + +(deftest delete-file.error.2 + (let ((pn "scratch.txt")) + (unless (probe-file pn) + (with-open-file (s pn :direction :output) + (format s "Contents~%"))) + (values + (notnot (probe-file pn)) + (classify-error (delete-file "scratch.txt" nil)) + (notnot (probe-file pn)) + (delete-file pn) + (probe-file pn))) + t program-error t t nil) + +(deftest delete-file.error.3 + (let ((pn "nonexistent.txt")) + (when (probe-file pn) (delete-file pn)) + (let ((result (classify-error (delete-file "nonexistent.txt")))) + (if (member result '(file-error t)) + t + result))) + t) + diff --git a/ansi-tests/directory.lsp b/ansi-tests/directory.lsp index 867de67..68867be 100644 --- a/ansi-tests/directory.lsp +++ b/ansi-tests/directory.lsp @@ -38,7 +38,23 @@ ;; unless (pathname-match-p pn pattern-pathname) ;; collect pn)) )) - nil nil nil) + nil nil ;; nil + ) + +(deftest directory.7 + (let* ((pattern-pathname (make-pathname :name :wild :type :wild + :defaults *default-pathname-defaults*)) + (pathnames (directory pattern-pathname))) + (loop for pn in pathnames + unless (equal pn (probe-file pn)) + collect pn)) + nil) + +(deftest directory.8 + (let* ((pathname-pattern "CLTEST:*.*") + (len (length (directory pathname-pattern)))) + (if (< len 500) len nil)) + nil) (deftest directory.error.1 (classify-error (directory)) diff --git a/ansi-tests/ensure-directories-exist.lsp b/ansi-tests/ensure-directories-exist.lsp index 520a4f2..fd7edcb 100644 --- a/ansi-tests/ensure-directories-exist.lsp +++ b/ansi-tests/ensure-directories-exist.lsp @@ -134,7 +134,8 @@ ))) 2 t t t "") - +;; FIXME +;; Need to add a LPN test (deftest ensure-directories-exist.error.1 (classify-error diff --git a/ansi-tests/file-author.lsp b/ansi-tests/file-author.lsp index 485c6d7..89f4f97 100644 --- a/ansi-tests/file-author.lsp +++ b/ansi-tests/file-author.lsp @@ -52,6 +52,9 @@ author)) nil) +;;; FIXME +;;; Add LPN test + ;;; Error tests (deftest file-author.error.1 diff --git a/ansi-tests/file-error.lsp b/ansi-tests/file-error.lsp new file mode 100644 index 0000000..d425a61 --- /dev/null +++ b/ansi-tests/file-error.lsp @@ -0,0 +1,89 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Tue Jan 13 19:10:02 2004 +;;;; Contains: Tests of the FILE-ERROR condition, and associated accessor function + +(in-package :cl-test) + +(deftest file-error.1 + (let ((pn (make-pathname :name :wild + :type "txt" + :version :newest + :defaults *default-pathname-defaults*))) + (handler-case + (probe-file pn) + (error (c) + (values + (notnot (typep c 'file-error)) + (if (equalp (file-error-pathname c) pn) + t + (list (file-error-pathname c) pn)))))) + t t) + +(deftest file-error-pathname.1 + (let ((c (make-condition 'file-error :pathname "foo.txt"))) + (values + (notnot (typep c 'file-error)) + (eqlt (class-of c) (find-class 'file-error)) + (file-error-pathname c))) + t t "foo.txt") + +(deftest file-error-pathname.2 + (let ((c (make-condition 'file-error :pathname #p"foo.txt"))) + (values + (notnot (typep c 'file-error)) + (eqlt (class-of c) (find-class 'file-error)) + (equalt #p"foo.txt" (file-error-pathname c)))) + t t t) + +(deftest file-error-pathname.3 + (let ((c (make-condition 'file-error :pathname "CLTEST:foo.txt"))) + (values + (notnot (typep c 'file-error)) + (eqlt (class-of c) (find-class 'file-error)) + (equalpt "CLTEST:foo.txt" + (file-error-pathname c)))) + t t t) + +(deftest file-error-pathname.4 + (let ((c (make-condition 'file-error :pathname (logical-pathname "CLTEST:foo.txt")))) + (values + (notnot (typep c 'file-error)) + (eqlt (class-of c) (find-class 'file-error)) + (equalpt (logical-pathname "CLTEST:foo.txt") + (file-error-pathname c)))) + t t t) + +(deftest file-error-pathname.5 + (with-open-file (s "file-error.lsp" :direction :input) + (let ((c (make-condition 'file-error :pathname s))) + (values + (notnot (typep c 'file-error)) + (eqlt (class-of c) (find-class 'file-error)) + (equalpt s (file-error-pathname c))))) + t t t) + +(deftest file-error-pathname.6 + (let ((s (open "file-error.lsp" :direction :input))) + (close s) + (let ((c (make-condition 'file-error :pathname s))) + (values + (notnot (typep c 'file-error)) + (eqlt (class-of c) (find-class 'file-error)) + (equalpt s (file-error-pathname c))))) + t t t) + +(deftest file-error-pathname.error.1 + (classify-error (file-error-pathname)) + program-error) + +(deftest file-error-pathname.error.2 + (classify-error (file-error-pathname (make-condition 'file-error :pathname "foo.txt") nil)) + program-error) + + + + + + + diff --git a/ansi-tests/file-write-date.lsp b/ansi-tests/file-write-date.lsp index b7ccb93..b54c6c2 100644 --- a/ansi-tests/file-write-date.lsp +++ b/ansi-tests/file-write-date.lsp @@ -50,6 +50,9 @@ (length (multiple-value-list (file-write-date "file-write-date.lsp"))) 1) +;;; FIXME +;;; Add LPN test + ;;; (deftest file-write-date.error.1 @@ -71,5 +74,3 @@ (file-write-date (make-pathname :name "file-write-date" :type :wild :defaults *default-pathname-defaults*))) file-error) - - diff --git a/ansi-tests/load-files.lsp b/ansi-tests/load-files.lsp index c283004..8a9b765 100644 --- a/ansi-tests/load-files.lsp +++ b/ansi-tests/load-files.lsp @@ -12,4 +12,5 @@ (load "file-author.lsp") (load "file-write-date.lsp") (load "rename-file.lsp") - +(load "delete-file.lsp") +(load "file-error.lsp") diff --git a/ansi-tests/pathnames-aux.lsp b/ansi-tests/pathnames-aux.lsp index 998df2e..659ea24 100644 --- a/ansi-tests/pathnames-aux.lsp +++ b/ansi-tests/pathnames-aux.lsp @@ -14,3 +14,12 @@ (symbol-value (synonym-stream-symbol x)))))) +(defun explode-pathname (pn) + (list + :host (pathname-host pn) + :device (pathname-device pn) + :directory (pathname-directory pn) + :name (pathname-name pn) + :type (pathname-type pn) + :version (pathname-version pn))) + diff --git a/ansi-tests/probe-file.lsp b/ansi-tests/probe-file.lsp index 83b4ceb..c9cad20 100644 --- a/ansi-tests/probe-file.lsp +++ b/ansi-tests/probe-file.lsp @@ -12,16 +12,21 @@ (deftest probe-file.2 (let ((s (open #p"probe-file.lsp" :direction :input))) (prog1 - (equalp (truename #p"probe-file.lsp") - (probe-file s)) + (equalpt (truename #p"probe-file.lsp") + (probe-file s)) (close s))) t) (deftest probe-file.3 (let ((s (open #p"probe-file.lsp" :direction :input))) (close s) - (equalp (truename #p"probe-file.lsp") - (probe-file s))) + (equalpt (truename #p"probe-file.lsp") + (probe-file s))) + t) + +(deftest probe-file.4 + (equalpt (truename #p"probe-file.lsp") + (probe-file "CLTEST:probe-file.lsp")) t) (deftest probe-file.error.1 @@ -36,6 +41,6 @@ (classify-error (probe-file (make-pathname :name :wild))) file-error) - - - +(deftest probe-file.error.4 + (classify-error (probe-file "CLTEST:*.FOO")) + file-error) diff --git a/ansi-tests/progv.lsp b/ansi-tests/progv.lsp index 74f7102..ca0e700 100644 --- a/ansi-tests/progv.lsp +++ b/ansi-tests/progv.lsp @@ -83,3 +83,13 @@ 10 (return 'good))) good) + +;;; Variables that are not bound don't have any type constraints + +(deftest progv.12 + (progv '(x y) '(1) + (locally (declare (special x y) (type nil y)) + (values + x + (boundp 'y)))) + 1 nil) diff --git a/ansi-tests/random-int-form.lsp b/ansi-tests/random-int-form.lsp index cdbf8fc..fdb0505 100644 --- a/ansi-tests/random-int-form.lsp +++ b/ansi-tests/random-int-form.lsp @@ -107,7 +107,8 @@ (loop for i from 1 to n do (when (= (mod i 100) 0) - #+sbcl (sb-ext::gc :full t) + ;; #+sbcl (print "Do gc...") + ;; #+sbcl (sb-ext::gc :full t) (prin1 i) (princ " ") (finish-output *standard-output*)) nconc (let ((result (test-random-integer-form size nvars))) (when result @@ -391,7 +392,7 @@ (1 `(/ ,(make-random-integer-form (1- size)) -1)) ;; tagbody - (5 (make-random-tagbody size)) + (5 (make-random-tagbody-and-progn size)) ;; conditionals (20 @@ -467,19 +468,20 @@ (*random-int-form-catch-tags* (cons tag *random-int-form-catch-tags*))) `(catch ,tag ,(make-random-integer-form (1- size))))) - (4 ;; setq + (4 ;; setq and similar (if *vars* (let* ((vdesc (random-from-seq *vars*)) (var (var-desc-name vdesc)) - (type (var-desc-type vdesc))) + (type (var-desc-type vdesc)) + (op (random-from-seq #(setq setf)))) (cond ((equal type '(integer * *)) - `(setq ,var ,(make-random-integer-form (1- size)))) + `(,op ,var ,(make-random-integer-form (1- size)))) ((and (consp type) (eq (car type) 'integer) (integerp (second type)) (integerp (third type))) - `(setq ,var ,(random-from-interval (1+ (third type)) (second type)))) + `(,op ,var ,(random-from-interval (1+ (third type)) (second type)))) ;; Abort -- can't assign (t (make-random-integer-form size)))) (make-random-integer-form size))) @@ -589,25 +591,32 @@ (let* ((num-forms (random 6)) (tags nil)) (loop for i below num-forms - do (loop for tag = (rcase (1 (random 8)) - (1 (random-from-seq #(tag1 tag2 tag3 tag4 tag5 tag6 tag7 tag8)))) + do (loop for tag = (rcase + #-acl (1 (random 8)) + (1 (random-from-seq #(tag1 tag2 tag3 tag4 + tag5 tag6 tag7 tag8)))) while (member tag tags) finally (push tag tags))) (assert (= (length (remove-duplicates tags)) (length tags))) (let* ((*go-tags* (set-difference *go-tags* tags)) - (sizes (random-partition (1- size) (1+ num-forms))) + (sizes (if (> num-forms 0) (random-partition (1- size) num-forms) nil)) (forms (loop for tag-list on tags for i below num-forms for size in sizes collect (let ((*go-tags* (append tag-list *go-tags*))) - (make-random-integer-form size)))) - (final-form (make-random-integer-form (car (last sizes))))) - `(progn (tagbody ,@(loop for tag in tags - for form in forms - when (atom form) do (setq form `(progn ,form)) - append `(,form ,tag))) - ,final-form)))) + (make-random-integer-form size))))) + `(tagbody ,@(loop for tag in tags + for form in forms + when (atom form) do (setq form `(progn ,form)) + append `(,form ,tag)))))) + +(defun make-random-tagbody-and-progn (size) + (let* ((final-size (random (max 1 (floor size 5)))) + (tagbody-size (- size final-size))) + (let ((final-form (make-random-integer-form final-size)) + (tagbody-form (make-random-tagbody tagbody-size))) + `(progn ,tagbody-form ,final-form)))) (defun make-random-pred-form (size) "Make a random form whose value is to be used as a generalized boolean." @@ -1065,7 +1074,7 @@ (try (eval form))) (prune-fn form try-fn))) - ((setq) + ((setq setf) (try 0) ;; Assumes only one assignment (assert (= (length form) 3)) diff --git a/ansi-tests/rename-file.lsp b/ansi-tests/rename-file.lsp index 63eb0da..f882ba5 100644 --- a/ansi-tests/rename-file.lsp +++ b/ansi-tests/rename-file.lsp @@ -20,10 +20,15 @@ (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) + (list (notnot (pathnamep defaulted-new-name)) + (notnot (pathnamep old-truename)) + (notnot (pathnamep new-truename)) + (typep old-truename 'logical-pathname) + (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename)))))) - t nil t t nil t) + t nil t (t t t nil nil) t nil t) (deftest rename-file.2 (let ((pn1 "file-to-be-renamed.txt") @@ -40,10 +45,15 @@ (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) + (list (notnot (pathnamep defaulted-new-name)) + (notnot (pathnamep old-truename)) + (notnot (pathnamep new-truename)) + (typep old-truename 'logical-pathname) + (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename)))))) - t nil t t nil t) + t nil t (t t t nil nil) t nil t) (deftest rename-file.3 (let* ((pn1 (make-pathname :name "file-to-be-renamed" @@ -67,10 +77,15 @@ (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn3)) + (list (notnot (pathnamep defaulted-new-name)) + (notnot (pathnamep old-truename)) + (notnot (pathnamep new-truename)) + (typep old-truename 'logical-pathname) + (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename)))))) - t t nil t t nil t) + t t nil t (t t t nil nil) t nil t) (deftest rename-file.4 (let ((pn1 "file-to-be-renamed.txt") @@ -89,10 +104,15 @@ (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) + (list (notnot (pathnamep defaulted-new-name)) + (notnot (pathnamep old-truename)) + (notnot (pathnamep new-truename)) + (typep old-truename 'logical-pathname) + (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) (notnot (probe-file new-truename))))))) - t nil t t nil t) + t nil t (t t t nil nil) t nil t) (deftest rename-file.5 (let ((pn1 "CLTEST:file-to-be-renamed.txt") @@ -109,10 +129,17 @@ (=t (length results) 3) (probe-file pn1) (notnot (probe-file pn2)) + (list (notnot (pathnamep defaulted-new-name)) + (notnot (pathnamep old-truename)) + (notnot (pathnamep new-truename)) + (typep old-truename 'logical-pathname) + (typep new-truename 'logical-pathname)) (notnot (probe-file defaulted-new-name)) (probe-file old-truename) - (notnot (probe-file new-truename)))))) - t nil t t nil t) + (notnot (probe-file new-truename)) + (notnot (typep defaulted-new-name 'logical-pathname)) + )))) + t nil t (t t t nil nil) t nil t t) ;;; diff --git a/ansi-tests/truename.lsp b/ansi-tests/truename.lsp index 5218ce3..578591f 100644 --- a/ansi-tests/truename.lsp +++ b/ansi-tests/truename.lsp @@ -54,6 +54,21 @@ )))) t nil t t) +(deftest truename.5 + (let* ((lpn "CLTEST:foo.txt") + (pn (translate-logical-pathname lpn))) + (unless (probe-file lpn) + (with-open-file (s lpn :direction :output) (format s "Stuff~%"))) + (let ((tn (truename lpn))) + (values + (notnot (pathnamep pn)) + (if (equalt (pathname-name pn) (pathname-name tn)) + t (list (pathname-name pn) (pathname-name tn))) + (if (equalt (pathname-type pn) (pathname-type tn)) + t (list (pathname-type pn) (pathname-type tn))) + ))) + t t t) + ;;; (deftest truename.error.1 diff --git a/ansi-tests/universe.lsp b/ansi-tests/universe.lsp index e35e61b..c9ee5be 100644 --- a/ansi-tests/universe.lsp +++ b/ansi-tests/universe.lsp @@ -337,10 +337,18 @@ )) (eval-when (load eval compile) - (setf (logical-pathname-translations "CLTESTROOT") - `(("**;*.*.*" ,(make-pathname :directory '(:absolute))))) - (setf (logical-pathname-translations "CLTEST") - `(("**;*.*.*" ,(make-pathname)))) + (ignore-errors + (setf (logical-pathname-translations "CLTESTROOT") + `(("**;*.*.*" ,(make-pathname :directory '(:absolute :wild-inferiors) + :name :wild :type :wild))))) + (ignore-errors + (setf (logical-pathname-translations "CLTEST") + `(("**;*.*.*" ,(make-pathname + :directory (append + (pathname-directory + (truename (make-pathname))) + '(:wild-inferiors)) + :name :wild :type :wild))))) ) (defparameter *logical-pathnames* -- GitLab