Commit 96cecd29 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

2.26.85: more progress

Package tweaks to make CLISP complain less.
run-program/ and run-shell-command fixes and test updates.
wildening fix to issue found by CLISP.
! is used by EXT on CLISP, so use !p for defparameter.
More pathname madness for allegro.
Better upgrade.
parent 284ff146
* Learn to use cl-grid-test, to make sure ASDF changes don't break stuff,
and that breakage gets fixed quickly.
* Test stassats's thing:
(asdf:enable-asdf-binary-locations-compatibility :centralize-lisp-binaries t :default-toplevel-directory *fasl-dir*)
* Split ASDF in parts
** Have it pass test-lisp
** Have it pass test-upgrade
......
......@@ -15,7 +15,7 @@
:licence "MIT"
:description "Another System Definition Facility"
:long-description "ASDF builds Common Lisp software organized into defined systems."
:version "2.26.84" ;; to be automatically updated by bin/bump-revision
:version "2.26.85" ;; to be automatically updated by bin/bump-revision
:depends-on ()
:components ((:module "build" :components ((:file "asdf"))))
:in-order-to (#+asdf2.27 (compile-op (monolithic-load-concatenated-source-op generate-asdf))))
......
......@@ -115,4 +115,4 @@ synchronously execute the result using a Bourne-compatible shell, with
output to *VERBOSE-OUT*. Returns the shell's exit code."
(let ((command (apply 'format nil control-string args)))
(asdf-message "; $ ~A~%" command)
(run-program/ command :force-shell t :output *verbose-out*)))
(run-program/ command :force-shell t :ignore-error-status t :output *verbose-out*)))
......@@ -132,7 +132,7 @@ values of TAG include :source-registry and :output-translations."
(let ((files (sort (ignore-errors
(remove-if
'hidden-file-p
(directory* (make-pathname :name :wild :type "conf" :defaults directory))))
(directory* (make-pathname :name *wild* :type "conf" :defaults directory))))
#'string< :key #'namestring)))
`(,tag
,@(loop :for file :in files :append
......@@ -180,7 +180,8 @@ values of TAG include :source-registry and :output-translations."
(coerce-pathname (hostname) :type :directory)))))
(when (absolute-pathname-p r)
(error (compatfmt "~@<pathname ~S is not relative~@:>") x))
(if (or (pathnamep x) (symbolp x) (not wilden)) r (wilden r))))
(if (or (pathnamep x) (member x '(:*/ :**/ :*.*.*)) (not wilden))
r (wilden r))))
(defvar *here-directory* nil
"This special variable is bound to the currect directory during calls to
......@@ -231,7 +232,7 @@ directive.")
(error "Using the :system-cache is deprecated. ~%~
Please remove it from your ASDF configuration"))
((eql :default-directory) (default-directory))))
(s (if (and wilden (not (or (pathnamep x) (symbolp x))))
(s (if (and wilden (not (or (pathnamep x))))
(wilden r)
r)))
(unless (absolute-pathname-p s)
......
......@@ -113,7 +113,7 @@ Other expressions are not evaluated if TAG returned NIL."
(!a
d describe
ap apropos
! defparameter
!p defparameter
m1 macroexpand-1)
;;; SLIME integration
......
;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
;;; This is ASDF 2.26.84: Another System Definition Facility.
;;; This is ASDF 2.26.85: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
......
......@@ -32,6 +32,7 @@
#:implementation-identifier #:implementation-type #:hostname
#:input-files #:output-files #:output-file #:perform
#:operation-done-p #:explain #:component-sibling-dependencies
#:run-program/ ; the recommended replacement for run-shell-command
#:component-load-dependencies #:run-shell-command ; deprecated, do not use
#:precompiled-system #:compiled-file
#+ecl #:make-build #+mkcl #:bundle-system
......
......@@ -2,7 +2,7 @@
;;;; Support to build (compile and load) Lisp files
(asdf/package:define-package :asdf/lisp-build
(:recycle :asdf/lisp-build :asdf)
(:recycle :asdf/interface :asdf :asdf/lisp-build)
(:use :common-lisp :asdf/compatibility :asdf/utility :asdf/pathname :asdf/stream :asdf/os :asdf/image)
(:export
;; Variables
......@@ -250,16 +250,17 @@ for processing later (possibly in a different process)."
(values output-truename warnings-p failure-p))))
(defun* compile-file-pathname* (input-file &rest keys &key output-file &allow-other-keys)
(if (absolute-pathname-p output-file)
;; what cfp should be doing, w/ mp* instead of mp
(let* ((type (pathname-type (apply 'fasl-type keys)))
(defaults (make-pathname
:type type :defaults (merge-pathnames* input-file))))
(merge-pathnames* output-file defaults))
(funcall *output-translation-hook*
(apply 'compile-file-pathname input-file
(remove-keys `(#+(and allegro (not (version>= 8 2))) :external-format
,@(unless output-file '(:output-file))) keys)))))
(let* ((keys
(remove-keys `(#+(and allegro (not (version>= 8 2))) :external-format
,@(unless output-file '(:output-file))) keys)))
(if (absolute-pathname-p output-file)
;; what cfp should be doing, w/ mp* instead of mp
(let* ((type (pathname-type (apply 'fasl-type keys)))
(defaults (make-pathname
:type type :defaults (merge-pathnames* input-file))))
(merge-pathnames* output-file defaults))
(funcall *output-translation-hook*
(apply 'compile-file-pathname input-file keys)))))
(defun* load* (x &rest keys &key &allow-other-keys)
(etypecase x
......
......@@ -67,9 +67,10 @@ The :FORCE or :FORCE-NOT argument to OPERATE can be:
;; Before we operate on any system, make sure ASDF is up-to-date,
;; for if an upgrade is attempted at any later time, there may be trouble.
;; If we upgraded, restart the OPERATE from scratch,
;; for the function will have been redefined.
;; for the function will have been redefined,
;; maybe from a new symbol for it may have been uninterned.
(if (upgrade-asdf)
(apply 'operate operation-class system args)
(apply 'symbol-call :asdf 'operate operation-class system args)
(let ((plan (apply 'traverse op system args)))
(perform-plan plan)
(values op plan)))))
......
......@@ -136,7 +136,7 @@ with a different configuration, so the configuration would be re-read then."
;; Some implementations have precompiled ASDF systems,
;; so we must disable translations for implementation paths.
#+(or #|clozure|# ecl mkcl sbcl)
,@(let ((h (lisp-implementation-directory :truename t))) (when h `(((,h ,*wild-inferiors*) ()))))
,@(let ((h (lisp-implementation-directory :truename t))) (when h `(((,h ,*wild-path*) ()))))
#+mkcl (,(translate-logical-pathname "CONTRIB:") ())
;; All-import, here is where we want user stuff to be:
:inherit-configuration
......@@ -198,9 +198,8 @@ with a different configuration, so the configuration would be re-read then."
(t
(let* ((trudst (if dst
(resolve-location dst :directory t :wilden t)
trusrc))
(wilddst (merge-pathnames* *wild-file* trudst)))
(funcall collect (list wilddst t))
trusrc)))
(funcall collect (list trudst t))
(funcall collect (list trusrc trudst)))))))))))
(defmethod process-output-translations ((x symbol) &key
......
This diff is collapsed.
......@@ -122,8 +122,7 @@ Defaults to T.")
(declare (ignorable host device devicep name type version defaults))
(apply 'make-pathname
(append
#+(and allegro (version>= 9 0) unix)
(when (and devicep (null device)) `(:device :unspecific))
#+allegro (when (and devicep (null device)) `(:device :unspecific))
(when directoryp
`(:directory ,(denormalize-pathname-directory-component directory)))
keys)))
......@@ -239,17 +238,19 @@ actually-existing directory."
;;; Wildcard pathnames
(defparameter *wild* (or #+cormanlisp "*" :wild))
(defparameter *wild-directory-component* (or #+gcl<2.7 "*" :wild))
(defparameter *wild-inferiors-component* (or #+gcl<2.7 "**" :wild-inferiors))
(defparameter *wild-file*
(make-pathname :directory nil :name *wild* :type *wild*
:version (or #-(or allegro abcl xcl) *wild*)))
(defparameter *wild-directory*
(make-pathname* :directory `(:relative ,(or #+gcl<2.7 "*" *wild*))
(make-pathname* :directory `(:relative ,*wild-directory-component*)
:name nil :type nil :version nil))
(defparameter *wild-inferiors*
(make-pathname* :directory `(:relative ,(or #+gcl<2.7 "**" :wild-inferiors))
(make-pathname* :directory `(:relative ,*wild-inferiors-component*)
:name nil :type nil :version nil))
(defparameter *wild-path*
(merge-pathnames *wild-file* *wild-inferiors*))
(merge-pathnames* *wild-file* *wild-inferiors*))
(defun* wilden (path)
(merge-pathnames* *wild-path* path))
......
......@@ -288,6 +288,7 @@ with a different configuration, so the configuration would be re-read then."
(defvar *source-registry-parameter* nil)
(defun* initialize-source-registry (&optional (parameter *source-registry-parameter*))
#-clisp ;; CLISP really hates our package munging. Don't try to load it twice.
(setf *asdf-upgrade-already-attempted* nil) ;; in case a new ASDF appears in the registry
(setf *source-registry-parameter* parameter)
(setf *source-registry* (make-hash-table :test 'equal))
......
......@@ -306,10 +306,6 @@
(setf (logical-pathname-translations "ASDFTEST") nil))
(remhash "test-system" asdf::*defined-systems*)))
(defun hash-table->alist (table)
(loop :for key :being :the :hash-keys :of table :using (:hash-value value)
:collect (cons key value)))
(with-test ()
(asdf:initialize-source-registry)
(format t "source registry: ~S~%" (hash-table->alist asdf::*source-registry*))
......
......@@ -2,73 +2,22 @@
(load "script-support.lisp")
(load-asdf)
;;; TODO: write tests for run-program/ instead -- and/or
;;; import those from the original xcvb-driver-test
;;; test asdf run-shell-command function
(with-test ()
#+asdf-unix
(progn
(assert (eql 1 (asdf:run-shell-command "false")))
(assert (eql 0 (asdf:run-shell-command "true")))
(unless (= 2 (asdf:run-shell-command "./bad-shell-command"))
(when (asdf::os-unix-p)
(setf asdf::*verbose-out* nil)
(assert-equal 1 (asdf:run-shell-command "false"))
(assert-equal 0 (asdf:run-shell-command "true"))
(unless (< 0 (asdf:run-shell-command "./bad-shell-command"))
(error "Failed to capture exit status indicating shell command failure."))
(unless (zerop (asdf:run-shell-command "./good-shell-command"))
(unless (equal 0 (asdf:run-shell-command "./good-shell-command"))
(error "Failed to capture exit status indicating shell command failure."))
(format t "~&a~%")
;; make sure we capture stderr from ASDF:RUN-SHELL-COMMAND to *VERBOSE-OUT*
#-(or clisp ecl)
(let ((string
(with-output-to-string (str)
(let ((asdf:*verbose-out* str))
(asdf:run-shell-command "./stderr")))))
(with-input-from-string (str string)
(loop for string = (read-line str nil nil)
while string
if (equalp "Writing to standard error." string)
return t
finally (format t "Actual content read was:~%")
(pprint string)
(error "Failed to capture output to standard error using *VERBOSE-OUT*"))))
;; make sure we /don't/ capture stderr from ASDF:RUN-SHELL-COMMAND when
;; *VERBOSE-OUT* is NIL
#-(or clisp ecl)
(let ((string
(with-output-to-string (str)
(let ((*error-output* str))
(let ((asdf:*verbose-out* nil))
(asdf:run-shell-command "./stderr"))))))
(unless (equalp string "")
(with-input-from-string (str string)
(format t "Actual content written to *error-output* was:~%")
(pprint string)
(error "Failed to capture output to standard error using *VERBOSE-OUT*"))))
#-ecl
(let* ((retval nil)
(string
(with-output-to-string (str)
(let ((asdf:*verbose-out* str))
(setf retval
(asdf:run-shell-command "echo \"Writing to standard output.\""))))))
(unless (zerop retval)
(error "echo did not run successfully in the shell."))
(with-input-from-string (str string)
(loop for s = (read-line str nil nil)
while s
if (equalp "Writing to standard output." s)
return t
finally (format t "Actual content read was:~%")
(pprint string)
(error "Failed to capture output to standard output using *VERBOSE-OUT*"))))
#-ecl
(let* ((retval nil)
(string
(with-output-to-string (str)
(let ((*standard-output* str))
(let ((asdf:*verbose-out* nil))
(setf retval
(asdf:run-shell-command "echo \"Writing to standard output.\"")))))))
(unless (zerop retval)
(error "echo did not run successfully in the shell."))
(unless (equalp string "")
(with-input-from-string (str string)
(format t "Actual content written to standard output was:~%")
(pprint string)
(error "Incorrectly captured output to standard output when not using *VERBOSE-OUT*"))))))
;; NB1: run-shell-command is deprecated. Use run-program/ instead.
;; NB2: we do NOT support stderr capture to *verbose-out* anymore in run-shell-command.
;; If you want 2>&1 redirection, you know where to find it.
(assert-equal '("ok 1") (asdf::run-program/ "echo ok 1" :output :lines))
(assert-equal '("ok 1") (asdf::run-program/ '("echo" "ok 1") :output :lines))
))
......@@ -247,6 +247,8 @@ run_upgrade_tests () {
: Skip, because it is so damn slow ;;
ccl:1.*|ccl:2.0[01]*)
: Skip, because ccl broke old asdf ;;
clisp:1.*|clisp:2.0[01]*)
: Skip, because ccl broke old asdf ;;
cmucl:1.*|cmucl:2.00*|cmucl:2.01[0-4]:*)
: Skip, CMUCL has problems before 2.014.7 due to source-registry upgrade ;;
ecl*:1.*|ecl*:2.0[01]*|ecl*:2.20:*)
......
......@@ -196,13 +196,17 @@ is bound, write a message and exit on an error. If
(catch :asdf-test-done
(handler-bind
((error (lambda (c)
(format *error-output* "~&TEST ABORTED: ~A~&" c)
(ignore-errors
(format *error-output* "~&TEST ABORTED: ~A~&" c))
(finish-outputs)
(cond
(*debug-asdf* (break))
(*debug-asdf*
(format t "~&It's your baby, fix it!~%")
(break))
(t
(acall :print-condition-backtrace
c :count 69 :stream *error-output*)
(ignore-errors
(acall :print-condition-backtrace
c :count 69 :stream *error-output*))
(leave-test "Script failed" 1))))))
(funcall thunk)
(leave-test "Script succeeded" 0)))))
......@@ -232,31 +236,37 @@ is bound, write a message and exit on an error. If
(register-directory *asdf-directory*)
(apply (asym :oos) (asym :load-op) :asdf keys)))
(defun call-with-asdf-conditions (thunk &optional verbose)
(handler-bind (#+sbcl
((or sb-c::simple-compiler-note sb-kernel:redefinition-warning)
#'muffle-warning)
#+(and ecl (not ecl-bytecmp))
((or c:compiler-note c::compiler-debug-note
c:compiler-warning) ;; ECL emits more serious warnings than it should.
#'muffle-warning)
#+mkcl
((or compiler:compiler-note) #'muffle-warning)
#-(or cmu scl)
;; style warnings shouldn't abort the compilation [2010/02/03:rpg]
(style-warning
#'(lambda (w)
;; escalate style-warnings to warnings - we don't want them.
(when verbose
(warn "Can you please fix ASDF to not emit style-warnings? Got a ~S:~%~A"
(type-of w) w))
(muffle-warning w))))
(funcall thunk)))
(defmacro with-asdf-conditions ((&optional verbose) &body body)
`(call-with-asdf-conditions #'(lambda () ,@body) ,verbose))
(defun compile-asdf (&optional tag verbose)
(let* ((alisp (asdf-lisp tag))
(afasl (asdf-fasl tag))
(tmp (make-pathname :name "asdf-tmp" :defaults afasl)))
(ensure-directories-exist afasl)
(multiple-value-bind (result warnings-p errors-p)
(handler-bind (#+sbcl
((or sb-c::simple-compiler-note sb-kernel:redefinition-warning)
#'muffle-warning)
#+(and ecl (not ecl-bytecmp))
((or c:compiler-note c::compiler-debug-note
c:compiler-warning) ;; ECL emits more serious warnings than it should.
#'muffle-warning)
#+mkcl
((or compiler:compiler-note) #'muffle-warning)
#-(or cmu scl)
;; style warnings shouldn't abort the compilation [2010/02/03:rpg]
(style-warning
#'(lambda (w)
;; escalate style-warnings to warnings - we don't want them.
(when verbose
(warn "Can you please fix ASDF to not emit style-warnings? Got a ~S:~%~A"
(type-of w) w))
(muffle-warning w))))
(compile-file alisp :output-file tmp #-gcl :verbose #-gcl verbose :print verbose))
(compile-file alisp :output-file tmp #-gcl :verbose #-gcl verbose :print verbose)
(flet ((bad (key)
(when result (ignore-errors (delete-file result)))
key)
......@@ -271,7 +281,7 @@ is bound, write a message and exit on an error. If
;; ECL 11.1.1 has spurious warnings, same with XCL 0.0.0.291.
;; SCL has no warning but still raises the warningp flag since 2.20.15 (?)
#+(or cmu ecl scl xcl) (good :expected-warnings)
(bad :unexpected-warnings)))
(bad :unexpected-warnings)))
(t (good :success)))))))
(defun maybe-compile-asdf (&optional tag)
......@@ -290,7 +300,7 @@ is bound, write a message and exit on an error. If
(defun compile-asdf-script ()
(with-test ()
(ecase (maybe-compile-asdf)
(ecase (with-asdf-conditions () (maybe-compile-asdf))
(:not-found
(leave-test "Testsuite failed: unable to find ASDF source" 3))
(:previously-compiled
......@@ -329,15 +339,19 @@ is bound, write a message and exit on an error. If
(defmacro test-asdf (&body body) ;; used by test-upgrade
`(testing-asdf #'(lambda () ,@body)))
(defun close-inputs ()
(close *standard-input*))
(defun configure-asdf ()
(untrace)
(setf *debug-asdf* (or *debug-asdf* (acall :getenvp "DEBUG_ASDF_TEST")))
(unless *debug-asdf* (close-inputs))
(eval `(trace ,@(loop :for s :in *trace-symbols* :collect (asym s))))
(acall :initialize-source-registry
`(:source-registry :ignore-inherited-configuration))
(acall :initialize-output-translations
`(:output-translations
((,*test-directory* :**/ :*.*.*) (,*asdf-directory* "build/fasls" :implementation "test"))
((,*asdf-directory* :**/ :*.*.*) (,*asdf-directory* "build/fasls" :implementation "asdf"))
(t (,*asdf-directory* "build/fasls" :implementation "root"))
:ignore-inherited-configuration))
(set (asym :*central-registry*) `(,*test-directory*))
......@@ -356,10 +370,9 @@ is bound, write a message and exit on an error. If
(setf *debug-asdf* t)
(setf *package* (find-package :asdf-test)))
(defun common-lisp-user::load-asdf ()
(load-asdf))
(defun common-lisp-user::debug-asdf ()
(debug-asdf))
(defun common-lisp-user::load-asdf () (load-asdf))
(defun common-lisp-user::debug-asdf () (debug-asdf))
(defun common-lisp-user::da () (debug-asdf))
#| The following form is sometimes useful to insert in compute-action-stamp to find out what's happening.
It depends on the DBG macro in contrib/debug.lisp, that you should load in your ASDF.
......
......@@ -2,6 +2,9 @@
(load "script-support.lisp")
(load-asdf)
#+clisp
(trace load compile-file)
#-gcl<2.7
(setf (logical-pathname-translations "ASDF")
#+(or allegro clisp)
......@@ -14,19 +17,21 @@
:wilden t))))
(with-test ()
(format t "~S~%" (translate-logical-pathname "ASDF:test;test-force.asd"))
(format t "~S~%" (truename "ASDF:test;test-force.asd"))
(DBG :logical
(logical-pathname-translations "ASDF")
(translate-logical-pathname "ASDF:test;test-force.asd")
(truename "ASDF:test;test-force.asd"))
#-(or xcl gcl<2.7)
(progn
(format t "Test logical pathnames in central registry~%")
(DBG "Test logical pathnames in central registry")
(setf *central-registry* '(#p"ASDF:test;"))
(initialize-source-registry '(:source-registry :ignore-inherited-configuration))
(load-system :test-logical-pathname :force t))
(DBG "loading" (oos 'load-op :test-logical-pathname :force t)))
#-(or xcl gcl<2.7)
(progn
(format t "Test logical pathnames in source-registry, non-recursive~%")
(DBG "Test logical pathnames in source-registry, non-recursive")
(clear-system :test-logical-pathname)
(setf *central-registry* '())
(initialize-source-registry
......@@ -35,13 +40,15 @@
#-(or xcl gcl<2.7)
(progn
(format t "Test logical pathnames in source-registry, recursive~%")
(DBG "Test logical pathnames in source-registry, recursive")
(clear-system :test-logical-pathname)
(setf *central-registry* '())
(initialize-source-registry
;; Bug: Allegro Express 8.2 incorrectly reads #p"ASDF:" as relative.
'(:source-registry (:tree #-allegro #p"ASDF:" #+allegro #.(asdf::pathname-root #p"ASDF:"))
;; Bug: Allegro Express 8.2 and 9.0 incorrectly read #p"ASDF:" as relative.
;; other bug: around 2.26.xx, CLISP borks badly if this is ASDF:
;; and it tries to load ASDF from a logical-pathname.
'(:source-registry (:tree #p"ASDF:test;")
:ignore-inherited-configuration))
(load-system :test-logical-pathname :force t))
(format t "Done~%"))
(DBG "Done"))
......@@ -32,7 +32,7 @@
;; "2.345.6" would be a development version in the official upstream
;; "2.345.0.7" would be your seventh local modification of official release 2.345
;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
(asdf-version "2.26.84")
(asdf-version "2.26.85")
(existing-asdf (find-class (find-symbol* :component :asdf nil) nil))
(existing-version *asdf-version*)
(already-there (equal asdf-version existing-version)))
......
......@@ -33,7 +33,13 @@
(eval-when (:load-toplevel :compile-toplevel :execute)
(defun undefine-function (function-spec)
(cond
((symbolp function-spec) (fmakunbound function-spec))
((symbolp function-spec)
#+clisp
(let ((f (and (fboundp function-spec) (fdefinition function-spec))))
(when (typep f 'clos:standard-generic-function)
(loop :for m :in (clos:generic-function-methods f)
:do (remove-method f m))))
(fmakunbound function-spec))
((and (consp function-spec) (eq (car function-spec) 'setf)
(consp (cdr function-spec)) (null (cddr function-spec)))
#-(or gcl<2.7) (fmakunbound function-spec))
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment