diff --git a/ansi-tests/delete-file.lsp b/ansi-tests/delete-file.lsp new file mode 100644 index 0000000000000000000000000000000000000000..6692c02859fad109b3cc787d7d6e3f0b5a5c02be --- /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 867de674770d3cc826d614964b2ae178fbc8045c..68867be28b1a67ea587efc8f05df8f691d3595bd 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 520a4f2dd6478afb01ae76151413abfb06132b54..fd7edcbd6e2f474422f248370e05c27ecc91cb4a 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 485c6d76123f5d4b5daa57b82809cacbcee222b6..89f4f975a9f1aa6849bcb8830000f0fecc11af02 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 0000000000000000000000000000000000000000..d425a617f135a50922f2a7764791ffe62c47474f --- /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 b7ccb93c60546514e2b4fd125c43ca7aca879f9e..b54c6c28e70ff37125c46015aef7f70d506ab28c 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 c2830044e0f6fe6767265e2eaf4be2621502342e..8a9b7657931ebf9a09851bf2ca2ed8e5f0a25ad5 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 998df2e0f8e4a9943241263b61cb8701eb8aa4dd..659ea24154b4a26b739e583183256379844ead38 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 83b4cebad156f405b06a3f37aa9b474ae04f03fd..c9cad205e918d15d258f5dc7357ac3fc45ed96ea 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 74f71022f1d087a11c0678f1d631ec664bbf1d37..ca0e700ecb8f9bc9b87af02644104d85d981fa63 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 cdbf8fca00e6a88fca12946aca7f76706cd77235..fdb05054c51cb892268fcfdd70318a9d0e9b5600 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 63eb0dabf786a445f6a0d718bb63e69f6e455158..f882ba5ab9bd0a732c0b9e0877ac12366e5d748e 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 5218ce3ae3da494301f7fe4cb96467c6dc2fbcb0..578591ff1ec436cd458e38eb8c4abde6c1cb832e 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 e35e61b816543de7f9329d0e3294ce98358ad816..c9ee5be3c922db92fc2f67e130b00faeaeda6ff5 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*