Skip to content
Snippets Groups Projects
Commit 200eb7f6 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

export COMPILE-FILE-PATHNAME* that applies translations. Use it to fix tests.

parent 81429606
No related branches found
No related tags found
No related merge requests found
......@@ -151,6 +151,7 @@
#:clear-output-translations
#:ensure-output-translations
#:apply-output-translations
#:compile-file-pathname*
#:initialize-source-registry
#:clear-source-registry
......@@ -186,7 +187,7 @@
;;;;
(defparameter *asdf-version*
;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
(subseq "VERSION:1.596" (1+ (length "VERSION"))))
(subseq "VERSION:1.600" (1+ (length "VERSION"))))
(defun asdf-version ()
*asdf-version*)
......@@ -2244,7 +2245,7 @@ with a different configuration, so the configuration would be re-read then."
(output-translations)
(initialize-output-translations)))
(defmethod apply-output-translations (path)
(defun apply-output-translations (path)
(ensure-output-translations)
(setf path (truenamize path))
(loop :for (source destination) :in (car *output-translations*)
......@@ -2256,6 +2257,9 @@ with a different configuration, so the configuration would be re-read then."
"Method to rewrite output files to fasl-root"
(mapcar #'apply-output-translations (call-next-method)))
(defun compile-file-pathname* (input-file &rest keys)
(apply-output-translations
(apply #'compile-file-pathname input-file keys)))
;;;; -----------------------------------------------------------------
;;;; Windows shortcut support. Based on:
......
......@@ -33,8 +33,8 @@ if [ $? -eq 0 ] ; then
test_pass=0
test_fail=0
failed_list=""
for i in $scripts ;
do
for i in $scripts ;
do
echo "Testing: $i" >&2
test_count=`expr "$test_count" + 1`
rm -f *.$2 || true
......@@ -134,4 +134,3 @@ else
do_tests "$command" $fasl_ext 2>&1 | tee "results/${lisp}.text" "results/${lisp}-${thedate}.save"
clean_up
fi
......@@ -3,9 +3,6 @@
#+allegro
(setf excl:*warn-on-nested-reader-conditionals* nil)
#+common-lisp-controller
(setf common-lisp-controller:*redirect-fasl-files-to-cache* nil)
;;; code adapted from cl-launch (any errors in transcription are mine!)
;; http://www.cliki.net/cl-launch
(defun leave-lisp (message return)
......@@ -17,7 +14,7 @@
(ext:quit return)
#+(or cmu scl)
(unix:unix-exit code)
#+ecl
#+ecl
(si:quit return)
#+gcl
(lisp:quit code)
......@@ -31,7 +28,7 @@
(error "Don't know how to quit Lisp; wanting to use exit code ~a" return))
(defmacro quit-on-error (&body body)
`(handler-case
`(handler-case
(progn ,@body
(leave-lisp "~&Script succeeded~%" 0))
(error (c)
......
;;; -*- Lisp -*-
(load "script-support")
(load "../asdf")
(quit-on-error
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:operate 'asdf:load-op 'test-force)
(defvar file1-date (file-write-date (compile-file-pathname "file1"))))
(defvar file1-date (file-write-date (asdf:compile-file-pathname* "file1"))))
(quit-on-error
(quit-on-error
;; unforced, date should stay same
(sleep 1)
(asdf:operate 'asdf:load-op 'test-force)
(assert (= (file-write-date (compile-file-pathname "file1")) file1-date))
(assert (= (file-write-date (asdf:compile-file-pathname* "file1")) file1-date))
;; forced, it should be later
(sleep 1)
(asdf:operate 'asdf:load-op 'test-force :force t)
(assert (> (file-write-date (compile-file-pathname "file1")) file1-date))
)
\ No newline at end of file
(assert (> (file-write-date (asdf:compile-file-pathname* "file1")) file1-date)))
;;; -*- Lisp -*-
(load "script-support")
(load "../asdf")
(quit-on-error
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:operate 'asdf:load-op 'static-and-serial)
(defvar file1-date (file-write-date (compile-file-pathname "file1"))))
(defvar file1-date (file-write-date (asdf:compile-file-pathname* "file1"))))
(quit-on-error
(quit-on-error
;; cheat
(setf asdf::*defined-systems* (make-hash-table :test 'equal))
;; date should stay same
(sleep 1)
(asdf:operate 'asdf:load-op 'static-and-serial)
(assert (= (file-write-date (compile-file-pathname "file1")) file1-date))
)
\ No newline at end of file
(assert (= (file-write-date (asdf:compile-file-pathname* "file1")) file1-date)))
;;; -*- Lisp -*-
(load "script-support")
(load "../asdf")
(quit-on-error
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(asdf:operate 'asdf:load-op 'test1)
;; test that it compiled
(defvar file1-date (file-write-date (compile-file-pathname "file1"))))
(defvar file1-date (file-write-date (asdf:compile-file-pathname* "file1")))))
(quit-on-error
(assert (and file1-date (file-write-date (compile-file-pathname "file2")))))
(quit-on-error
(assert (and file1-date (file-write-date (asdf:compile-file-pathname* "file2"))))))
;; and loaded
(assert test-package::*file1*)
(quit-on-error
(quit-on-error
;; now remove one output file and check that the other is _not_
;; recompiled
(sleep 1) ; mtime has 1-second granularity, so pause here for fast machines
(asdf::run-shell-command "rm -f ~A"
(namestring (compile-file-pathname "file2")))
(namestring (asdf:compile-file-pathname* "file2")))
(asdf:operate 'asdf:load-op 'test1)
(assert (= file1-date (file-write-date (compile-file-pathname "file1"))))
(assert (file-write-date (compile-file-pathname "file2")))
(assert (= file1-date (file-write-date (asdf:compile-file-pathname* "file1"))))
(assert (file-write-date (asdf:compile-file-pathname* "file2")))
;; now touch file1 and check that file2 _is_ also recompiled
;; XXX run-shell-command loses if *default-pathname-defaults* is not the
;; unix cwd. this is not a problem for run-tests.sh, but can be in general
(let ((before (file-write-date (compile-file-pathname "file2"))))
(let ((before (file-write-date (asdf:compile-file-pathname* "file2"))))
(asdf::run-shell-command "touch file1.lisp")
(sleep 1)
(asdf:operate 'asdf:load-op 'test1)
(assert (> (file-write-date (compile-file-pathname "file2")) before)))
)
\ No newline at end of file
(assert (> (file-write-date (asdf:compile-file-pathname* "file2")) before))))
;;; -*- Lisp -*-
(load "script-support")
(load "../asdf")
(quit-on-error
(quit-on-error
(setf asdf:*central-registry* '(*default-pathname-defaults*))
;(trace asdf::perform)
;(trace asdf::find-component)
;(trace asdf::traverse)
(asdf:oos 'asdf:load-op 'test2b1)
(assert (and (probe-file (compile-file-pathname "file3"))
(probe-file (compile-file-pathname "file4"))))
(handler-case
(assert (and (probe-file (asdf:compile-file-pathname* "file3"))
(probe-file (asdf:compile-file-pathname* "file4"))))
(handler-case
(asdf:oos 'asdf:load-op 'test2b2)
(asdf:missing-dependency (c)
(format t "load failed as expected: - ~%~A~%" c))
(:no-error (c)
(declare (ignore c))
(error "should have failed, oops")))
(handler-case
(handler-case
(asdf:oos 'asdf:load-op 'test2b3)
(asdf:missing-dependency (c)
(format t "load failed as expected: - ~%~A~%" c))
(:no-error (c)
(:no-error (c)
(declare (ignore c))
(error "should have failed, oops")))
)
\ No newline at end of file
(error "should have failed, oops"))))
......@@ -4,18 +4,18 @@
(load "script-support")
(load "../asdf")
(in-package :asdf)
(cl-user::quit-on-error
(let ((fasl1 (compile-file-pathname (merge-pathnames "file1")))
(fasl2 (compile-file-pathname (merge-pathnames "file2"))))
(cl-user::quit-on-error
(let ((fasl1 (asdf:compile-file-pathname* (merge-pathnames "file1")))
(fasl2 (asdf:compile-file-pathname* (merge-pathnames "file2"))))
(asdf:run-shell-command "rm -f ~A ~A"
(namestring fasl1)
(namestring fasl2))
(setf asdf:*central-registry* '(*default-pathname-defaults*))
(handler-case
(handler-case
(asdf:oos 'asdf:load-op 'test3)
(asdf:missing-dependency (c)
(format t "first test failed as expected: - ~%~A~%" c))
(:no-error (c)
(:no-error (c)
(declare (ignore c))
(error "should have failed, oops")))
(pushnew :f1 *features*)
......@@ -26,5 +26,4 @@
(setf *features* (cons :f2 (cdr *features*)))
(asdf:oos 'asdf:load-op 'test3)
(assert (probe-file fasl2))
(assert (not (probe-file fasl1)))
))
(assert (not (probe-file fasl1)))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment