test-utilities.script 9.21 KB
Newer Older
1
;;; -*- Lisp -*-
2

3 4 5
(assert
 (every #'directory-pathname-p
  (list
6 7 8
   (make-pathname* :name nil :type "" :directory '(:absolute "tmp"))
   (make-pathname* :name "" :directory '(:absolute "tmp"))
   (make-pathname* :type "" :directory '(:absolute "tmp"))
9 10
;; CLHS 19.2.2.2.3 says we can't portably specify :unspecific here,
;; and some implementations will enforce it.
11 12 13
   (make-pathname* :type *unspecific-pathname-type* :directory '(:absolute "tmp"))
   (make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp"))
   (make-pathname* :name *unspecific-pathname-type* :directory '(:absolute "tmp")))))
14 15 16
(assert
 (every (complement #'directory-pathname-p)
  (list
17 18
   (make-pathname* :name "foo" :type nil :directory '(:absolute "tmp"))
   (make-pathname* :name nil :type "bar" :directory '(:absolute "tmp")))))
19
;; These are funky and non portable, omit from tests:
20 21
;; (make-pathname* :name "." :type nil :directory '(:absolute "tmp"))
;; (make-pathname* :name "." :type "" :directory '(:absolute "tmp"))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
22
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "" :ensure-directory t))
23
               '(:relative nil nil nil)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
24
(assert (equal (multiple-value-list (split-unix-namestring-directory-components ""  :ensure-directory nil))
25
               '(:relative nil nil nil)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
26
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/" :ensure-directory t))
27
               '(:absolute nil nil nil)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
28
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/" :ensure-directory nil))
29
               '(:absolute nil nil nil)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
30
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/aa/ba" :ensure-directory t))
31
               '(:absolute ("aa" "ba") nil nil)))
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
32
(assert (equal (multiple-value-list (split-unix-namestring-directory-components "/aa/ba" :ensure-directory nil))
33
               '(:absolute ("aa") "ba" nil)))
34
(assert
35
 (version-satisfies (asdf-version) (asdf-version)))
36
(assert
37 38
 (version-satisfies (asdf-version) "3.0"))
(assert
39
 (version-satisfies (asdf-version) "2.0"))
40 41
(assert
 (version<= "2.0" (asdf-version)))
42
(assert
43
 (not (version-satisfies (asdf-version) "666")))
44 45
(assert-pathnames-equal
 (split-native-pathnames-string "foo:bar")
46
 '(#p"foo" #p"bar"))
47 48
(assert-pathnames-equal
 (split-native-pathnames-string "foo:bar" :ensure-directory t)
49
 '(#p"foo/" #p"bar/"))
50 51
(assert-pathnames-equal
 (split-native-pathnames-string "/foo:/bar" :want-absolute t)
52
 '(#p"/foo" #p"/bar"))
53 54
(assert-pathnames-equal
 (split-native-pathnames-string "/foo:/bar" :want-absolute t :ensure-directory t)
55
 '(#p"/foo/" #p"/bar/"))
56 57 58 59 60 61 62 63 64 65
(assert-equal
 (mapcar 'location-function-p
         '((:function f)
           (:function (lambda (path absolute-source)
                        (declare (ignore absolute-source))
                        path))
           (function previous-isnt-keyword)
           (:function f too many arguments)
           (:function (:lambda isnt lambda))
           (:function (lambda (too many args) blah))))
66
 '(t t nil nil nil nil))
67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82

(initialize-source-registry '())

#|
(unless (find-system :swank nil)
  (leave-test "Cannot find SWANK" 0))

(load-system :swank)
;;(setq swank-loader::*fasl-directory* (resolve-output "slime/"))
;;(ensure-directories-exist swank-loader::*fasl-directory*)
;;(DBG :foo swank-loader::*fasl-directory*)
(swank-loader:init)
|#

(defparameter *ok-symbols*
  '(;; slots names
83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112
    asdf/action:accept
    asdf/action:action
    asdf/action:done-p
    asdf/action:stamp
    asdf/bundle:prologue-code
    asdf/bundle:build-args
    asdf/bundle:epilogue-code
    asdf/bundle:name-suffix
    asdf/component:absolute-pathname
    asdf/component:around-compile
    asdf/component:author
    asdf/component:children
    asdf/component:children-by-name
    asdf/component:components
    asdf/component:components-by-name
    asdf/component:default-component-class
    asdf/component:defsystem-depends-on
    asdf/component:description
    asdf/component:%encoding
    asdf/component:if-feature
    asdf/component:inline-methods
    asdf/component:in-order-to
    asdf/component:licence
    asdf/component:long-description
    asdf/component:maintainer
    asdf/component:name
    asdf/component:operation-times
    asdf/component:parent
    asdf/component:properties
    asdf/component:relative-pathname
113
    asdf/component:sideway-dependencies
114 115
    asdf/component:version
    asdf/lisp-action:flags
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
116
    asdf/operation:feature
Francois-Rene Rideau's avatar
Francois-Rene Rideau committed
117
    asdf/operation:original-initargs
118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134
    asdf/plan:index
    asdf/plan:forced
    asdf/plan:forced-not
    asdf/plan:planned-action-count
    asdf/plan:planned-output-action-count
    asdf/plan:planned-p
    asdf/plan:total-action-count
    asdf/plan:visited-actions
    asdf/plan:visiting-action-set
    asdf/plan:visiting-action-list
    asdf/system:bug-tracker
    asdf/system:build-pathname
    asdf/system:entry-point
    asdf/system:homepage
    asdf/system:long-name
    asdf/system:mailto
    asdf/system:source-control
135
    ;; restarts
136 137 138 139 140
    asdf/action:accept
    asdf/find-component:retry
    asdf/find-system:coerce-entry-to-directory
    asdf/find-system:remove-entry-from-registry
    asdf/lisp-action:try-recompiling
141
    ;; types
142
    asdf/bundle:user-system
143
    #+sbcl uiop/lisp-build:sb-grovel-unknown-constant-condition
144
    ;; on some implementations only
145 146 147
    asdf/bundle:bundle-system
    asdf/bundle:register-pre-built-system 
    asdf/bundle:static-library
148 149 150 151
    uiop/os:parse-file-location-info
    uiop/os:parse-windows-shortcut
    uiop/os:read-little-endian
    uiop/os:read-null-terminated-string
152
    ;; backward compatibility upgrade only
153
    asdf/backward-internals:make-sub-operation
154 155
    asdf/backward-interface:on-failure
    asdf/backward-interface:on-warnings
156 157
    asdf/find-system:contrib-sysdef-search
    asdf/find-system:sysdef-find-asdf
158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182
    ))

(defun defined-symbol-p (symbol)
  (or (boundp symbol)
      (fboundp symbol)
      (macro-function symbol)
      (find-class symbol nil)))

(defun fishy-exported-symbols (package &optional (ok-symbols *ok-symbols*))
  (loop :for symbol :being :the external-symbols :of package
        :unless (or
                 (defined-symbol-p symbol)
                 ;;(symbol-call :swank :classify-symbol symbol)
                 (member symbol ok-symbols))
          :collect symbol))

(defun fishy-asdf-exported-symbols ()
  (remove-duplicates
   (loop :for package :in (list-all-packages)
         :when (and (string-prefix-p "ASDF/" (package-name package))
                    (not (equal (package-name package) "ASDF/COMMON-LISP")))
           :nconc (fishy-exported-symbols package))
   :from-end t))

(assert-equal nil (fishy-asdf-exported-symbols))
183 184

(delete-package* :asdf-test-package-1)
185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206

(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/c/"))
(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/d/"))
(ensure-directories-exist (subpathname *build-directory* "deleteme/a/b/e/"))
(register-directory *asdf-directory*)
(register-directory *uiop-directory*)
(copy-file (system-source-file :uiop) (subpathname *build-directory* "deleteme/a/1.x"))
(copy-file (system-source-file :uiop) (subpathname *build-directory* "deleteme/a/b/2"))
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/")))
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/")))
(assert (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/")))
(assert (probe-file* (subpathname *build-directory* "deleteme/a/1.x")))
(assert (probe-file* (subpathname *build-directory* "deleteme/a/b/2")))
(delete-empty-directory (subpathname *build-directory* "deleteme/a/b/e/"))
(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/e/"))))
(delete-directory-tree (subpathname *build-directory* "deleteme/")
                       :validate (lambda (x) (and (<= 5 (length (pathname-directory x)))
                                                  (subpathp x *build-directory*))))
(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/c/"))))
(assert (not (directory-exists-p (subpathname *build-directory* "deleteme/a/b/d/"))))
(assert (not (probe-file* (subpathname *build-directory* "deleteme/a/1.x"))))
(assert (not (probe-file* (subpathname *build-directory* "deleteme/a/b/2"))))
207 208 209 210 211

#+(and sbcl sb-unicode) (assert +non-base-chars-exist-p+)
#+(or clozure (and sbcl (not sb-unicode))) (assert (not +non-base-chars-exist-p+))

(assert (base-string-p (make-string 10 :element-type 'base-char)))
212 213
(assert-equal "abcd" (strcat "a" nil "bc" "d"))
(assert-equal "abcd" (reduce/strcat '("a" nil "bc" "d")))
214 215 216 217 218 219

#-non-base-chars-exist-p
(progn
  (assert (base-string-p (make-string 10 :element-type 'character))))

(defun basify (s) (coerce s 'base-string))
220
(defun unbasify (s) (coerce s '(array character (*)))) ; on ECL, literals are base strings (!)
221 222 223 224

#+non-base-chars-exist-p
(progn
  (assert (not (base-string-p (make-string 10 :element-type 'character))))
225
  (assert (not (base-string-p (unbasify "abc"))))
226
  (assert (base-string-p (basify "abc")))
227 228
  (assert (not (base-string-p (strcat "a" nil #\b (unbasify "cd")))))
  (assert (base-string-p (reduce/strcat (mapcar 'basify '("a" "b" nil "cd")))))
229
  (assert (base-string-p (strcat (basify "ab") (basify "cd"))))
230
  (assert (not (base-string-p (strcat (basify "ab") #\c (unbasify "d")))))
231
  (assert (base-string-p (strcat (basify "ab") #\c #\d))))