Commit d324c0ad authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

1.647:

* Fix initialize-output-translations to actually use the environment,
 map output destinations to themselves, and
 actually take a parameter as documented.
* Document same parameter for initialize-source-registry, which did take it.
* Tweak symbols between unintern and fmakunbound
 to make upgrade better on both current SBCL and ECL.
* Tweak run-tests to allow for parametrizable binaries,
 to redirect output to tmp/fasls, to output Lisp command being executed,
parent 550e4f93
Loading
Loading
Loading
Loading
+26 −41
Original line number Diff line number Diff line
;;; -*- mode: common-lisp; package: asdf; -*-
;;; This is asdf: Another System Definition Facility.
;;; This is ASDF: Another System Definition Facility.
;;;
;;; Feedback, bug reports, and patches are all welcome:
;;; please mail to <asdf-devel@common-lisp.net>.
;;; Note first that the canonical source for asdf is presently
;;; Note first that the canonical source for ASDF is presently
;;; <URL:http://common-lisp.net/project/asdf/>.
;;;
;;; If you obtained this copy from anywhere else, and you experience
@@ -147,7 +147,11 @@
     :use '(:common-lisp :asdf-utilities)
     :unintern '(#:*asdf-revision* #:around #:asdf-method-combination #:split #:make-collector
                 #:perform #:explain #:output-files #:operation-done-p
                 #:component-relative-pathname #:system-relative-pathname)
                 #-ecl #:component-relative-pathname)
     :fmakunbound '(#:system-source-file
                    #:component-relative-pathname #:system-relative-pathname
                    #:process-source-registry
                    #:inherit-source-registry #:process-source-registry-directive)
     :export
     '(#:defsystem #:oos #:operate #:find-system #:run-shell-command
       #:system-definition-pathname #:find-component ; miscellaneous
@@ -238,11 +242,6 @@
       #:ensure-source-registry
       #:process-source-registry))))

#+nil
(error "The author of this file habitually uses #+nil to comment out ~
        forms. But don't worry, it was unlikely to work in the New ~
        Implementation of Lisp anyway")

(in-package #:asdf)

;;;; -------------------------------------------------------------------------
@@ -252,7 +251,7 @@
  ;; This parameter isn't actually user-visible
  ;; -- please use the exported function ASDF:ASDF-VERSION below.
  ;; the 1+ hair is to ensure that we don't do an inadvertent find and replace
  (subseq "VERSION:1.646" (1+ (length "VERSION"))))
  (subseq "VERSION:1.647" (1+ (length "VERSION"))))

(defun asdf-version ()
  "Exported interface to the version of ASDF currently installed. A string.
@@ -292,11 +291,6 @@ Defaults to `t`.")
;;;; * define methods on UPDATE-INSTANCE-FOR-REDEFINED-CLASS
;;;;   for each of the classes we define that has changed incompatibly.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (when (and (fboundp 'system-source-file)
             (not (typep (fdefinition 'system-source-file) 'generic-function)))
    (fmakunbound 'system-source-file))
  (map () 'fmakunbound '(process-source-registry inherit-source-registry
                         process-source-registry-directive))
  #+ecl
  (when (find-class 'compile-op nil)
    (defmethod update-instance-for-redefined-class :after
@@ -2431,13 +2425,13 @@ with a different configuration, so the configuration would be re-read then."
          (return `(:output-translations ,@(nreverse directives)))))))))

(defparameter *default-output-translations*
  '(implementation-output-translations
  '(environment-output-translations
    user-output-translations-pathname
    user-output-translations-directory-pathname
    system-output-translations-pathname
    system-output-translations-directory-pathname))

(defparameter *implementation-output-translations*
(defun wrapping-output-translations ()
  `(:output-translations
    ;; Some implementations have precompiled ASDF systems,
    ;; so we must disable translations for implementation paths.
@@ -2449,9 +2443,6 @@ with a different configuration, so the configuration would be re-read then."
    ;; If we want to enable the user cache by default, here would be the place:
    :enable-user-cache))

(defun implementation-output-translations ()
  *implementation-output-translations*)

(defparameter *output-translations-file* #p"asdf-output-translations.conf")
(defparameter *output-translations-directory* #p"asdf-output-translations.conf.d/")

@@ -2471,9 +2462,7 @@ with a different configuration, so the configuration would be re-read then."
                                        (inherit *default-output-translations*)
                                        collect)
  (process-output-translations (funcall x) :inherit inherit :collect collect))
(defmethod process-output-translations ((pathname pathname) &key
                                        (inherit *default-output-translations*)
                                        collect)
(defmethod process-output-translations ((pathname pathname) &key inherit collect)
  (cond
    ((directory-pathname-p pathname)
     (process-output-translations (validate-output-translations-directory pathname)
@@ -2483,19 +2472,13 @@ with a different configuration, so the configuration would be re-read then."
                                  :inherit inherit :collect collect))
    (t
     (inherit-output-translations inherit :collect collect))))
(defmethod process-output-translations ((string string) &key
                                        (inherit *default-output-translations*)
                                        collect)
(defmethod process-output-translations ((string string) &key inherit collect)
  (process-output-translations (parse-output-translations-string string)
                               :inherit inherit :collect collect))
(defmethod process-output-translations ((x null) &key
                                    (inherit *default-output-translations*)
                                    collect)
(defmethod process-output-translations ((x null) &key inherit collect)
  (declare (ignorable x))
  (inherit-output-translations inherit :collect collect))
(defmethod process-output-translations ((form cons) &key
                                        (inherit *default-output-translations*)
                                        collect)
(defmethod process-output-translations ((form cons) &key inherit collect)
  (dolist (directive (cdr (validate-output-translations-form form)))
    (process-output-translations-directive directive :inherit inherit :collect collect)))

@@ -2521,19 +2504,21 @@ with a different configuration, so the configuration would be re-read then."
              (process-output-translations (pathname dst) :inherit nil :collect collect))
            (let* ((trusrc (truenamize (resolve-location src t)))
                   (trudst (if dst (resolve-location dst t) trusrc)))
              (funcall collect (list trudst trudst))
              (funcall collect (list trusrc trudst)))))))

(defun compute-output-translations
    (&optional (translations *default-output-translations*))
(defun compute-output-translations (&optional parameter)
  "read the configuration, return it"
  (remove-duplicates
   (while-collecting (c)
    (inherit-output-translations translations :collect #'c)))
     (inherit-output-translations
      `(wrapping-output-translations ,parameter ,@*default-output-translations*) :collect #'c))
   :test 'equal :from-end nil))

(defun initialize-output-translations
    (&optional (translations *default-output-translations*))
(defun initialize-output-translations (&optional parameter)
  "read the configuration, initialize the internal configuration variable,
return the configuration"
  (setf (output-translations) (compute-output-translations translations)))
  (setf (output-translations) (compute-output-translations parameter)))

;; checks an initial variable to see whether the state is initialized
;; or cleared. In the former case, return current configuration; in
@@ -2779,7 +2764,8 @@ with a different configuration, so the configuration would be re-read then."
    user-source-registry
    user-source-registry-directory
    system-source-registry
    system-source-registry-directory))
    system-source-registry-directory
    default-source-registry))

(defparameter *source-registry-file* #p"source-registry.conf")
(defparameter *source-registry-directory* #p"source-registry.conf.d/")
@@ -2891,8 +2877,7 @@ with a different configuration, so the configuration would be re-read then."
          (flatten-source-registry
           `(wrapping-source-registry
             ,parameter
             ,@*default-source-registries*
             default-source-registry)))
             ,@*default-source-registries*)))
         (simplified
          (remove-duplicates flattened :test 'equal :from-end nil))
         (processed
+13 −25
Original line number Diff line number Diff line
@@ -855,7 +855,8 @@ and in the usual case the user is recommended not to supply it.
Instead, ASDF follows a hairy set of rules that are designed so that
@enumerate
@item
@code{find-system} will load a system from disk
@code{find-system}
will load a system from disk
and have its pathname default to the right place.
@item
This pathname information will not be overwritten with
@@ -1693,8 +1694,16 @@ The specified functions are exported from your build system's package.
Thus for ASDF the corresponding functions are in package ASDF,
and for XCVB the corresponding functions are in package XCVB.

@defun initialize-source-registry
@defun initialize-source-registry PARAMETER
   will read the configuration and initialize all internal variables.
   You may extend or override configuration
   from the environment and configuration files
   with the given @var{PARAMETER}, which can be
   @code{NIL} (no configuration override),
   or a SEXP (in the SEXP DSL),
   a string (as in the string DSL),
   a pathname (of a file or directory with configuration),
   or a symbol (fbound to function that when called returns one of the above).
@end defun

@defun clear-source-registry
@@ -1708,31 +1717,11 @@ and for XCVB the corresponding functions are in package XCVB.
   where to look for systems not yet defined.
@end defun

@defun ensure-source-registry
@defun ensure-source-registry PARAMETER
   checks whether a source registry has been initialized.
   If not, initialize it.
   This function will be called before any attempt to find a system
   in the source registry.
   If your application wants to override the provided defaults,
   it will have to use the below function process-source-registry.
@end defun


@defun process-source-registry X &key inherit collect
   If X is a CONS, parse it as a SEXP in the configuration DSL,
   and extend or override inheritted configuration.
   If X is a STRING, first parse it into a SEXP
   as for the CL_SOURCE_REGISTRY
   environment variable (see above) then process it.
   If X is a PATHNAME, read the file as a single SEXP and process it.
   The inheritted configuration is provided in keyword argument inherit,
   itself a list of functions that take inherit
   and collect keyword arguments
   and defaulting to a list of functions
   that implements the default behavior.
   If not, initialize it with the given @var{PARAMETER}.
@end defun


@section Future

If this mechanism is successful, in the future, we may declare
@@ -2109,7 +2098,6 @@ To explicitly flush any information cached by the system, use the API below.

The specified functions are exported from package ASDF.


@defun initialize-output-translations PARAMETER
   will read the configuration and initialize all internal variables.
   You may extend or override configuration
+5 −0
Original line number Diff line number Diff line
@@ -284,6 +284,11 @@
 make-pathname)

(quit-on-error
 (asdf:initialize-source-registry)
 (format t "source registry: ~S~%" (asdf::source-registry))
 (asdf:initialize-output-translations)
 (format t "output translations: ~S~%" (asdf::output-translations))

 (or (test-component-pathnames :delete-host t :support-string-pathnames nil)
     (leave-lisp "test failed" 1)))

+21 −19
Original line number Diff line number Diff line
@@ -5,7 +5,6 @@
# - quit with exit status 0 on getting eof
# - quit with exit status >0 if an unhandled error occurs

export CL_SOURCE_REGISTRY="$PWD"
unset DEBUG_ASDF_TEST

while getopts "duh" OPTION
@@ -51,10 +50,12 @@ usage () {
    echo "    -u -h -- show this message."
}

DO () { ( set -x ; "$@" ); }

do_tests() {
  command="$1" eval="$2"
  rm -f ~/.cache/common-lisp/"`pwd`"/* || true
  ( cd .. && $command $eval '(load "test/compile-asdf.lisp")' )
  ( cd .. && DO $command $eval '(load "test/compile-asdf.lisp")' )
  if [ $? -ne 0 ] ; then
    echo "Compilation FAILED" >&2
  else
@@ -68,7 +69,7 @@ do_tests() {
      echo "Testing: $i" >&2
      test_count=`expr "$test_count" + 1`
      rm -f ~/.cache/common-lisp/"`pwd`"/* || true
      if $command $eval "(load \"$i\")" ; then
      if DO $command $eval "(load \"$i\")" ; then
        echo "Using $command, $i passed" >&2
	test_pass=`expr "$test_pass" + 1`
      else
@@ -104,54 +105,50 @@ fi
command= flags= nodebug= eval=
case "$lisp" in
  sbcl)
    command=sbcl
    command="${SBCL:-sbcl}"
    flags="--noinform --userinit /dev/null --sysinit /dev/null"
    nodebug="--disable-debugger"
    eval="--eval" ;;
  clisp)
    command=clisp
    command="${CLISP:-clisp}"
    flags="-norc -ansi -I "
    nodebug="-on-error exit"
    eval="-x" ;;
  allegro)
    command=alisp
    command="${ALLEGRO:-alisp}"
    flags="-q"
    nodebug="-batch"
    eval="-e" ;;
  allegromodern)
    command=mlisp
    command="${ALLEGROMODERN:-mlisp}"
    flags="-q"
    nodebug="-batch"
    eval="-e" ;;
  ccl)
    command=ccl
    command="${CCL:-ccl}"
    flags="--no-init --quiet"
    nodebug="--batch"
    eval="--eval" ;;
  cmucl)
    command=lisp
    command="${CMUCL:-lisp}"
    flags="-noinit"
    nodebug="-batch"
    eval="-eval" ;;
  ecl)
    #if [ -x /usr/lib/ecl/ecl-original ] ; then
    #  command=/usr/lib/ecl/ecl-original
    #else
      command=ecl
    #fi
    command="${ECL:-ecl}"
    flags="-norc"
    eval="-eval" ;;
  lispworks)
    command=lispworks
    command="${LISPWORKS:-lispworks}"
    flags="-siteinit - -init -"
    eval="-eval" ;;
  gclcvs)
    export GCL_ANSI=t
    command=gclcvs
    command="${GCL:-gclcvs}"
    flags="-batch"
    eval="-eval" ;;
  abcl)
    command=abcl
    command="${ABCL:-abcl}"
    eval="--eval" ;;
  *)
    echo "Unsupported lisp: $1" >&2
@@ -164,10 +161,17 @@ if ! type "$command" ; then
    exit 43
fi

asdfdir="$(cd .. ; /bin/pwd)"
export CL_SOURCE_REGISTRY="${asdfdir}"
export ASDF_OUTPUT_TRANSLATIONS="${asdfdir}:${asdfdir}/tmp/fasls/$(basename $command)"
env | grep asdf

command="$command $flags"
if [ -z "${DEBUG_ASDF_TEST}" ] ; then
  command="$command $nodebug"
fi


create_config () {
    mkdir -p ../tmp/test-source-registry-conf.d ../tmp/test-asdf-output-translations-conf.d
}
@@ -181,8 +185,6 @@ if [ -z "$command" ] ; then
else
    create_config
    mkdir -p results
    command="$command $flags"
    echo $command
    thedate=`date "+%Y-%m-%d"`
    do_tests "$command" "$eval" 2>&1 | \
	tee "results/${lisp}.text" "results/${lisp}-${thedate}.save"
+7 −7
Original line number Diff line number Diff line
@@ -10,9 +10,7 @@
    *load-truename*)))
(defvar *asdf-fasl*
  (compile-file-pathname
   (merge-pathnames
    (make-pathname :directory '(:relative "tmp")
                   :name (format nil "asdf-~(~A~)"
   (let ((impl (string-downcase
                (or #+allegro (format nil "~Alisp" excl:*current-case-mode*)
                                     #+armedbear :abcl
                                     #+clisp :clisp
@@ -24,9 +22,11 @@
                                     #+gcl :gcl
                                     #+lispworks :lispworks
                                     #+sbcl :sbcl
                                     #+scl scl))
                                     #+scl scl))))
     (merge-pathnames
      (make-pathname :directory `(:relative "tmp" "fasls" ,impl)
                     :defaults *asdf-lisp*)
    *asdf-lisp*)))
      *asdf-lisp*))))

(defun load-asdf ()
  (load *asdf-fasl*))