compile-file.lsp 7.87 KB
Newer Older
1 2 3 4 5 6 7
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat Apr  9 08:25:25 2005
;;;; Contains: Tests of COMPILE-FILE

(in-package :cl-test)

8
(defun compile-file-test (file funname &rest args &key
sds's avatar
sds committed
9 10 11 12 13 14 15
                               expect-warnings
                               expect-style-warnings output-file
                               (print nil print-p)
                               (verbose nil verbose-p)
                               (*compile-print* nil)
                               (*compile-verbose* nil)
                               external-format)
16
  (declare (ignorable external-format))
pfdietz's avatar
pfdietz committed
17
  (let* ((target-pathname (or output-file
sds's avatar
sds committed
18 19 20
                              (compile-file-pathname file)))
         (actual-warnings-p nil)
         (actual-style-warnings-p nil))
21 22
    (when (probe-file target-pathname)
      (delete-file target-pathname))
pfdietz's avatar
pfdietz committed
23 24
    (fmakunbound funname)
    (let* ((str (make-array '(0) :element-type 'character :adjustable t :fill-pointer 0))
sds's avatar
sds committed
25 26 27 28 29 30 31 32 33 34 35 36 37 38
           (vals (multiple-value-list
                  (handler-bind
                   ((style-warning #'(lambda (c)
                                       (declare (ignore c))
                                       (setf actual-style-warnings-p t)
                                       nil))
                    ((or error warning)
                     #'(lambda (c)
                         (unless (typep c 'style-warning)
                           (setf actual-warnings-p t))
                         nil)))
                   (with-output-to-string
                     (*standard-output* str)
                     (apply #'compile-file file :allow-other-keys t args))))))
39 40
      (assert (= (length vals) 3))
      (destructuring-bind
sds's avatar
sds committed
41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64
          (output-truename warnings-p failure-p)
          vals
        (print (namestring (truename target-pathname)))
        (print (namestring output-truename))
        (values
         (let ((v1 (or print verbose
                       (and (not print-p) *compile-print*)
                       (and (not verbose-p) *compile-verbose*)
                       (string= str "")))
               (v2 (or (and verbose-p (not verbose))
                       (and (not verbose-p) (not *compile-verbose*))
                       (position #\; str)))
               (v3 (if actual-warnings-p failure-p t))
               (v4 (if expect-warnings failure-p t))
               (v5 (if expect-style-warnings warnings-p t))
               (v6 (or (null output-truename) (pathnamep output-truename)))
               (v7 (equalpt-or-report (namestring (truename target-pathname))
                                      (namestring output-truename)))
               (v8 (not (fboundp funname))))
           (if (and v1 v2 v3 v4 v5 v6 (eql v7 t) v8) t
             (list v1 v2 v3 v4 v5 v6 v7 v8)))
         (progn
           (load output-truename)
           (funcall funname)))))))
pfdietz's avatar
pfdietz committed
65 66

(deftest compile-file.1
67
  (compile-file-test "compile-file-test-file.lsp"
68
                     'compile-file-test-fun.1) t nil)
pfdietz's avatar
pfdietz committed
69 70

(deftest compile-file.2
71
  (compile-file-test "compile-file-test-file-2.lsp"
72
                     'compile-file-test-fun.2
sds's avatar
sds committed
73
                     :expect-style-warnings t)
74
  t nil)
75 76

(deftest compile-file.2a
77
  (compile-file-test "compile-file-test-file-2a.lsp"
78
                     'compile-file-test-fun.2a
sds's avatar
sds committed
79
                     :expect-warnings t)
80
  t nil)
pfdietz's avatar
pfdietz committed
81 82 83

(deftest compile-file.3
  (let ((*package* (find-package "CL-TEST")))
84
    (compile-file-test "compile-file-test-file-3.lsp"
85
                       'compile-file-test-fun.3)) t nil)
pfdietz's avatar
pfdietz committed
86 87 88

(deftest compile-file.4
  (let ((*package* (find-package "CL-USER")))
89
    (compile-file-test "compile-file-test-file-3.lsp"
90
                       'cl-user::compile-file-test-fun.3)) t nil)
pfdietz's avatar
pfdietz committed
91 92

(deftest compile-file.5
93
  (compile-file-test #p"compile-file-test-file.lsp"
94
                     'compile-file-test-fun.1) t nil)
pfdietz's avatar
pfdietz committed
95 96

(deftest compile-file.6
97
  (compile-file-test "compile-file-test-file.lsp"
98
                     'compile-file-test-fun.1
sds's avatar
sds committed
99
                     :output-file "foo.fasl")
100
  t nil)
101 102

(deftest compile-file.6a
103
  (compile-file-test "compile-file-test-file.lsp"
104
                     'compile-file-test-fun.1
sds's avatar
sds committed
105
                     :output-file "foo.ufsl")
106
  t nil)
pfdietz's avatar
pfdietz committed
107 108

(deftest compile-file.7
109
  (compile-file-test "compile-file-test-file.lsp"
110
                     'compile-file-test-fun.1
sds's avatar
sds committed
111
                     :external-format :default)
112
  t nil)
pfdietz's avatar
pfdietz committed
113 114

(deftest compile-file.8
115
  (compile-file-test "compile-file-test-file.lsp"
116
                     'compile-file-test-fun.1
sds's avatar
sds committed
117
                     :output-file #p"foo.fasl")
118
  t nil)
pfdietz's avatar
pfdietz committed
119 120

(deftest compile-file.9
121
  (compile-file-test "compile-file-test-file.lsp"
122
                     'compile-file-test-fun.1
sds's avatar
sds committed
123
                     :print t)
124
  t nil)
pfdietz's avatar
pfdietz committed
125 126

(deftest compile-file.10
127
  (compile-file-test "compile-file-test-file.lsp"
128
                     'compile-file-test-fun.1
sds's avatar
sds committed
129
                     :verbose t)
130
  t nil)
pfdietz's avatar
pfdietz committed
131 132

(deftest compile-file.11
133
  (compile-file-test "compile-file-test-file.lsp"
134
                     'compile-file-test-fun.1
sds's avatar
sds committed
135
                     :print nil)
136
  t nil)
pfdietz's avatar
pfdietz committed
137 138

(deftest compile-file.12
139
    (compile-file-test "compile-file-test-file.lsp"
140
                       'compile-file-test-fun.1
sds's avatar
sds committed
141
                     :verbose nil)
142
  t nil)
pfdietz's avatar
pfdietz committed
143 144 145

;;; A file stream is a pathname designator
(deftest compile-file.13
146
  (with-open-file (s "compile-file-test-file.lsp" :direction :input)
sds's avatar
sds committed
147
                  (compile-file-test s 'compile-file-test-fun.1))
148
  t nil)
pfdietz's avatar
pfdietz committed
149 150 151

(deftest compile-file.14
  (let ((s (open "foo.fasl" :direction :output :if-exists :supersede
sds's avatar
sds committed
152
                 :if-does-not-exist :create)))
pfdietz's avatar
pfdietz committed
153
    (close s)
154
    (compile-file-test "compile-file-test-file.lsp"
sds's avatar
sds committed
155 156
                       'compile-file-test-fun.1
                       :output-file s))
157 158 159 160 161
  t nil)

(deftest compile-file.15
  (let ((*readtable* (copy-readtable nil)))
    (set-macro-character #\! (get-macro-character #\'))
162
    (compile-file-test "compile-file-test-file-4.lsp"
163
                       'compile-file-test-fun.4)) t foo)
pfdietz's avatar
pfdietz committed
164

165 166 167
;;; Tests for *compile-file-truename*, *compile-file-pathname*

(deftest compile-file.16
168
  (let* ((file #p"compile-file-test-file-5.lsp")
sds's avatar
sds committed
169 170 171
         (target-pathname (compile-file-pathname file))
         (*compile-print* nil)
         (*compile-verbose* nil))
172 173 174 175 176
    (when (probe-file target-pathname)
      (delete-file target-pathname))
    (compile-file file)
    (load target-pathname)
    (values
177 178
     (equalpt-or-report (truename file) (funcall 'compile-file-test-fun.5))
     (equalpt-or-report (pathname (merge-pathnames file))
sds's avatar
sds committed
179
                        (funcall 'compile-file-test-fun.5a))))
180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195
  t t)

;;; Add tests of logical pathnames

(deftest compile-file.17
  (let ((file (logical-pathname "CLTEST:COMPILE-FILE-TEST-LP.LSP")))
    (with-open-file
     (s file :direction :output :if-exists :supersede :if-does-not-exist :create)
     (format s "(in-package :cl-test)~%(defun compile-file-test-lp.fun () nil)~%"))
    (compile-file-test file 'compile-file-test-lp.fun))
  t nil)

(deftest compile-file.18
  (let ((file (logical-pathname "CLTEST:COMPILE-FILE-TEST-LP.OUT")))
    (with-open-file
     (s file :direction :output :if-exists :supersede :if-does-not-exist :create))
196
    (compile-file-test "compile-file-test-file.lsp"
sds's avatar
sds committed
197 198
                       'compile-file-test-fun.1
                       :output-file file))
199 200
  t nil)

201
(deftest compile-file.19
202
  (compile-file-test "compile-file-test-file.lsp"
203
                     'compile-file-test-fun.1
sds's avatar
sds committed
204
                     :*compile-verbose* t)
205
  t nil)
206

207
(deftest compile-file.20
208
  (compile-file-test "compile-file-test-file.lsp"
209
                     'compile-file-test-fun.1
sds's avatar
sds committed
210 211
                     :*compile-print* t)
  t nil)
212 213 214 215 216 217 218 219

(deftest compile-file-pathname.1
  *compile-file-pathname*
  nil)

(deftest compile-file-truename.1
  *compile-file-truename*
  nil)
pfdietz's avatar
pfdietz committed
220 221 222 223

;;; Error cases

(deftest compile-file.error.1
224
  (signals-error (compile-file "nonexistent-file-to-compile.lsp")
225
                 file-error) t)
pfdietz's avatar
pfdietz committed
226 227 228 229 230 231 232

(deftest compile-file.error.2
  (signals-error (compile-file) program-error)
  t)



233