backward-interface.lisp 7.16 KB
Newer Older
1 2 3
;;;; -------------------------------------------------------------------------
;;; Backward-compatible interfaces

4 5
(asdf/package:define-package :asdf/backward-interface
  (:recycle :asdf/backward-interface :asdf)
6
  (:use :asdf/common-lisp :asdf/driver :asdf/upgrade
7
   :asdf/component :asdf/system :asdf/find-system :asdf/operation :asdf/action
8 9 10
   :asdf/lisp-build :asdf/operate :asdf/output-translations)
  (:export
   #:*asdf-verbose*
11
   #:operation-error #:compile-error #:compile-failed #:compile-warned
12
   #:error-component #:error-operation
13 14 15 16 17
   #:component-load-dependencies
   #:enable-asdf-binary-locations-compatibility
   #:operation-forced
   #:operation-on-failure
   #:operation-on-warnings
18
   #:component-property
19 20 21 22
   #:run-shell-command
   #:system-definition-pathname))
(in-package :asdf/backward-interface)

23 24 25 26 27 28 29 30 31 32 33
(define-condition operation-error (error) ;; Bad, backward-compatible name
  ;; Used by SBCL, cffi-tests, clsql-mysql, clsql-uffi, qt, elephant, uffi-tests, sb-grovel
  ((component :reader error-component :initarg :component)
   (operation :reader error-operation :initarg :operation))
  (:report (lambda (c s)
               (format s (compatfmt "~@<~A while invoking ~A on ~A~@:>")
                       (type-of c) (error-operation c) (error-component c)))))
(define-condition compile-error (operation-error) ())
(define-condition compile-failed (compile-error) ())
(define-condition compile-warned (compile-error) ())

34 35 36 37 38 39 40 41 42
(defun* component-load-dependencies (component)
  ;; Old deprecated name for the same thing. Please update your software.
  (component-sibling-dependencies component))

(defgeneric* operation-forced (operation)) ;; Used by swank.asd for swank-loader.
(defmethod operation-forced ((o operation)) (getf (operation-original-initargs o) :force))

(defgeneric* operation-on-warnings (operation))
(defgeneric* operation-on-failure (operation))
43 44
#-gcl2.6 (defgeneric* (setf operation-on-warnings) (x operation))
#-gcl2.6 (defgeneric* (setf operation-on-failure) (x operation))
45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73
(defmethod operation-on-warnings ((o operation))
  (declare (ignorable o)) *compile-file-warnings-behaviour*)
(defmethod operation-on-failure ((o operation))
  (declare (ignorable o)) *compile-file-failure-behaviour*)
(defmethod (setf operation-on-warnings) (x (o operation))
  (declare (ignorable o)) (setf *compile-file-warnings-behaviour* x))
(defmethod (setf operation-on-failure) (x (o operation))
  (declare (ignorable o)) (setf *compile-file-failure-behaviour* x))

(defun* system-definition-pathname (x)
  ;; As of 2.014.8, we mean to make this function obsolete,
  ;; but that won't happen until all clients have been updated.
  ;;(cerror "Use ASDF:SYSTEM-SOURCE-FILE instead"
  "Function ASDF:SYSTEM-DEFINITION-PATHNAME is obsolete.
It used to expose ASDF internals with subtle differences with respect to
user expectations, that have been refactored away since.
We recommend you use ASDF:SYSTEM-SOURCE-FILE instead
for a mostly compatible replacement that we're supporting,
or even ASDF:SYSTEM-SOURCE-DIRECTORY or ASDF:SYSTEM-RELATIVE-PATHNAME
if that's whay you mean." ;;)
  (system-source-file x))


;;;; ASDF-Binary-Locations compatibility

(defun* enable-asdf-binary-locations-compatibility
    (&key
     (centralize-lisp-binaries nil)
     (default-toplevel-directory
74
         (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
75 76
     (include-per-user-information nil)
     (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
77
     (source-to-target-mappings nil)
78 79 80 81 82 83
     (file-types `(,(compile-file-type)
                   "build-report"
                   #+ecl (compile-file-type :type :object)
                   #+mkcl (compile-file-type :fasl-p nil)
                   #+clisp "lib" #+sbcl "cfasl"
                   #+sbcl "sbcl-warnings" #+clozure "ccl-warnings")))
84 85 86
  #+(or clisp ecl mkcl)
  (when (null map-all-source-files)
    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
87 88 89
  (let* ((patterns (if map-all-source-files (list *wild-file*)
                       (loop :for type :in file-types
                             :collect (make-pathname :type type :defaults *wild-file*))))
90 91 92 93
         (destination-directory
          (if centralize-lisp-binaries
              `(,default-toplevel-directory
                ,@(when include-per-user-information
94
                        (cdr (pathname-directory (user-homedir-pathname))))
95 96 97 98 99 100 101
                :implementation ,*wild-inferiors*)
              `(:root ,*wild-inferiors* :implementation))))
    (initialize-output-translations
     `(:output-translations
       ,@source-to-target-mappings
       #+abcl (#p"jar:file:/**/*.jar!/**/*.*" (:function translate-jar-pathname))
       #+abcl (#p"/___jar___file___root___/**/*.*" (,@destination-directory))
102 103 104
       ,@(loop :for pattern :in patterns
               :collect `((:root ,*wild-inferiors* ,pattern)
                          (,@destination-directory ,pattern)))
105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122
       (t t)
       :ignore-inherited-configuration))))

(defmethod operate :before (operation-class system &rest args &key &allow-other-keys)
  (declare (ignorable operation-class system args))
  (when (find-symbol* '#:output-files-for-system-and-operation :asdf nil)
    (error "ASDF 2 is not compatible with ASDF-BINARY-LOCATIONS, which you are using.
ASDF 2 now achieves the same purpose with its builtin ASDF-OUTPUT-TRANSLATIONS,
which should be easier to configure. Please stop using ASDF-BINARY-LOCATIONS,
and instead use ASDF-OUTPUT-TRANSLATIONS. See the ASDF manual for details.
In case you insist on preserving your previous A-B-L configuration, but
do not know how to achieve the same effect with A-O-T, you may use function
ASDF:ENABLE-ASDF-BINARY-LOCATIONS-COMPATIBILITY as documented in the manual;
call that function where you would otherwise have loaded and configured A-B-L.")))


;;;; run-shell-command
;;
123
;; WARNING! The function below is dysfunctional and deprecated.
124 125
;; Please use asdf/run-program:run-program instead.
;;
126 127 128
(defun* run-shell-command (control-string &rest args)
  "Interpolate ARGS into CONTROL-STRING as if by FORMAT, and
synchronously execute the result using a Bourne-compatible shell, with
129 130 131 132 133
output to *VERBOSE-OUT*.  Returns the shell's exit code.

PLEASE DO NOT USE.
Deprecated function, for backward-compatibility only.
Please use ASDF-DRIVER:RUN-PROGRAM instead."
134 135
  (let ((command (apply 'format nil control-string args)))
    (asdf-message "; $ ~A~%" command)
136
    (run-program command :force-shell t :ignore-error-status t :output *verbose-out*)))
137

138
(defvar *asdf-verbose* nil) ;; backward-compatibility with ASDF2 only. Unused.
139 140 141 142 143 144 145 146 147 148 149 150 151 152 153

;; backward-compatibility methods. Do NOT use in new code. NOT SUPPORTED.
(defgeneric* component-property (component property))
#-gcl2.6 (defgeneric* (setf component-property) (new-value component property))

(defmethod component-property ((c component) property)
  (cdr (assoc property (slot-value c 'properties) :test #'equal)))

(defmethod (setf component-property) (new-value (c component) property)
  (let ((a (assoc property (slot-value c 'properties) :test #'equal)))
    (if a
        (setf (cdr a) new-value)
        (setf (slot-value c 'properties)
              (acons property new-value (slot-value c 'properties)))))
  new-value)